I have been researching this for some time and I have come up with the following code. However, I keep getting an error. See below.
The intent of this code is to produce an HTML document. Then it opens and prints the document from a printer. I have gotten the file to save successfully and even open it in an IE window. Then I get the error.
Function generateResults()
Dim resultsBrowser As SHDocVw.InternetExplorer
Set resultsBrowser = New SHDocVw.InternetExplorer
Dim resultsPath As String
Dim resultsFile As String
resultsPath = ThisWorkbook.Path & "\As-Run Test Results"
If Len(Dir(resultsPath, vbDirectory)) = 0 Then
MkDir resultsPath
End If
resultsFile = resultsPath & "\As-Run " & Format(Now, "mm-dd-yyyy hmmss") & ".html"
Open resultsFile For Output As #1
Print #1, "<html><title>Test</title><body>Hello World</body></html>"
Close #1
resultsBrowser.Navigate resultsFile
Do While resultsBrowser.ReadyState = READYSTATE_COMPLETE
Loop
resultsBrowser.Stop
resultsBrowser.ExecWB 7, 1
resultsBrowser.Quit
Set resultsBrowser = Nothing
End Function
Here is the error message.
When I go to debug, the VBA debugger points to the following line:
resultsBrowser.ExecWB 7, 1
What am I doing wrong? My research shows that this works for others, but it does not seem to work for me. Another oddity is that if I navigate to about:blank instead of the HTML file and comment out the ReadyState check loop, a blank Print Preview comes up successfully.
You need to use InternetExplorerMedium instead of InternetExplorer, as in this post: https://stackoverflow.com/a/19221313/6201755
(As a note, to make this clear for future users, the SHDocVw object is contained in the Microsoft Internet Controls reference library, make sure to add this reference in the VBE.)
Also as the comment above, this Do While resultsBrowser.ReadyState = READYSTATE_COMPLETE line makes it loop infinitely, so you need to change it to <>.
Here is the working code:
Private Sub test()
Dim resultsBrowser As SHDocVw.InternetExplorerMedium
Set resultsBrowser = New SHDocVw.InternetExplorerMedium
Dim resultsPath As String
Dim resultsFile As String
resultsPath = ThisWorkbook.Path & "\As-Run Test Results"
If Len(Dir(resultsPath, vbDirectory)) = 0 Then
MkDir resultsPath
End If
resultsFile = resultsPath & "\As-Run " & Format(Now, "mm-dd-yyyy hmmss") & ".html"
Open resultsFile For Output As #1
Print #1, "<html><title>Test</title><body>Hello World</body></html>"
Close #1
resultsBrowser.Navigate resultsFile
Do While resultsBrowser.ReadyState <> READYSTATE_COMPLETE
Loop
resultsBrowser.Stop
resultsBrowser.ExecWB 7, 1
resultsBrowser.Quit
Set resultsBrowser = Nothing
End Sub
Related
I am working on a code that uses VBA-Excel to navigate to a website and automate a daily task i do . Having said that , am stuck in between of trying to delete an html element . The following js code works perfect i.e. :-
var elmnt = document.getElementById("foregxyz");
elmnt.remove();
How could i make the above 2 lines of js code in vba excel ?
I tried the following but with no result . Please help , thanks in advance .
Sub DailyTask()
Dim ie As InternetExplorer
Set ie = New InternetExplorerMedium
Dim url As String
Dim elementToBeDeleted As String
url = "https://www.example.com"
ie.Visible = True
ie.Navigate url
While ie.Busy
DoEvents
Wend
ie.Document.getElementsByTagName("select")("toDOList").Value = "TEST1"
ie.Document.getElementsByTagName("select")("scheduleDate").Value = "TEST2"
ie.Document.getElementsByTagName("select")("descriptionTask").Value = "TEST3"
'Many more of data entry until submitting the form works fine .
elementToBeDeleted = ie.Document.getElementById("xyz")
Call DeleteTagById(elementToBeDeleted)
Set ie = Nothing
End Sub
Function DeleteTagById(elementToBeDeleted As String) As String
On Local Error GoTo MyError
Dim HTMLDoc As HTMLDocument
Dim Node As IHTMLDOMNode
If elementToBeDeleted = "" Then GoTo MyExit
Set HTMLDoc = New HTMLDocument
Set Node = HTMLDoc.getElementById("xyz") 'Node always equals to nothing , why ? hence i get stuck here and cant move further.
'If Node Is Nothing Then GoTo MyExit
Node.ParentNode.RemoveChild Node 'this line gives me run time error 91 object variable or with block variable not set .
MyExit:
Set Node = Nothing
Set HTMLDoc = Nothing
Exit Function
MyError:
'Handle Error
Resume MyExit
End Function
I've found this code that should find two matching pdf-filenames and merges them into 1 pdf-file always in the same order. File 1 then File 2.
The code matches filenames based on the first part of the filename, before the AnotherWord 2014.pdf or before SomeWord.pdf.
Example document name1: John Doe SomeWord.pdf
Example document name2: John Doe AnotherWord 2014.pdf
I use PDF reDirect Pro v2.5.2 (freeware) and a reference to the program.
The problem I have is that the line
Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD
That gives me the error:
User-defined type not defined
How can I fix this?
This is the whole code:
Private Sub Knop0_Click()
'Only works with PDF reDirect Pro v2.5.2
'And needs to have a reference to PDF_reDirect_v2500 and PDF reDirect Pro Remote Control
Dim fs As Object
Dim fld As Object
Dim fld2 As Object
Dim objFile As Object
Dim objFile2 As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD
Dim TempBool As Boolean
Dim Files_to_Merge(1) As String
Dim ObjFileName() As String
Dim CellNameValue() As String
Dim ofn As String
Dim cnv As String
Dim i As Integer
Set fld = fs.GetFolder("C:\pdf")
Set fld2 = fs.GetFolder("C:\pdf\merged")
i = 1
For Each objFile In fld.files
For Each objFile2 In fld.files
CellNameValue() = Split(objFile.Name, " SomeWord.pdf")
cnv = CellNameValue(0)
ObjFileName() = Split(objFile2.Name, " AnotherWord 2014.pdf")
ofn = ObjFileName(0)
Files_to_Merge(1) = fld & "\" & ofn & " AnotherWord 2014.pdf"
Files_to_Merge(0) = fld & "\" & cnv & " SomeWord.pdf"
If StrComp(ofn, cnv) = 0 Then
With oPDF
TempBool = .Utility_Merge_PDF_Files(fld2 & "\" & ofn & " AnotherWord 2014.pdf", Files_to_Merge) 'The file merges here unless it generates an error and goes to If Not TempBool Then...
If Not TempBool Then
MsgBox "An Error Occured: etc."
Else
'Optional
End If
End With
End If
i = i + 1
Next objFile2
i = i + 1
Next objFile
Set oPDF = Nothing
End Sub
As I said in my comments this should work assuming your trial Pro version will still allow this feature.
You just have to make sure you're using the correct version of the object that has been registered on your system.
Can you delete the line Dim oPDF As New PDF_reDirect_v25002.Batch_RC_AXD and start retyping it from scratch - not copy/pasting? Does the Object for the tool show up in Intellisense as you start typing PDF_Re
Put in the object that it finds PDF_reDirect_v2500 if that's what it is - then type the . and start typing Batch to fill in the last part. You have to use the current version of the object reference.
Compile your code and see if gets past that line
I'm a beginner with VBA and coding in general and I'm stuck with a problem with my VBA code. Here's what I want to do :
I have two fillable fields (f_autpar_nom and f_autpar_fiche) with my Access database who need to be on my Word file at two formfield (eleves_nom and eleves_numfiche) with a command_click(). Then, my Word document opens and prompts me with a "do you want to save this" and then the Word document save as a PDF and is sent by email.
Everything is working except one thing : The formfields aren't updated when I print the PDF and return the default message I set (which is "erreur").
What I need is to find a way to update the formfield before my messagebox prompt me to send the email.
Here's the code I have with Access
Function fillwordform()
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Error.Clear
Path = "P:\Commun\SECTEUR DU TRANSPORT SCOLAIRE\Harnais\Autorisations Parentales\Autorisation parentale vierge envoyée\Autorisation_blank.docm"
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
Set doc = appword.Documents.Open(Path, , False)
With doc
.FormFields("eleves_nom").Result = Me.f_autpar_nom
.FormFields("eleves_numfiche").Result = Me.f_autpar_fiche
appword.Visible = True
appword.Activate
End With
Set doc = Nothing
Set appword = Nothing
End Function
Private Sub Commande47_Click()
Dim mydoc As String
mydoc = "P:\Commun\SECTEUR DU TRANSPORT SCOLAIRE\Harnais\Autorisations Parentales\Autorisation_blank.docm"
Call fillwordform
End Sub
and with Word
Private Sub document_open()
Dim outl As Object
Dim Mail As Object
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Dim PDFname As String
Msg = "L'autorisation sera sauvegardée et envoyée par email. Continuer?"
Style = vbOKCancel + vbQuestion + vbDefaultButton2
Title = "Document"
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbOK Then
ActiveDocument.Save
PDFname = ActiveDocument.Path & "\" & "Autorisation Parentale " & FormFields("eleves_nom").Result & ".pdf"
ActiveDocument.SaveAs2 FileName:=PDFname, FileFormat:=wdFormatPDF
Set outl = CreateObject("Outlook.Application")
Set Mail = outl.CreateItem(0)
Mail.Subject = "Autorisation parentale " & FormFields("eleves_nom").Result & " " & FormFields("eleves_numfiche")
Mail.To = ""
Mail.Attachments.Add PDFname
Mail.Display
Application.Quit SaveChanges:=wdDoNotSaveChanges
Else
MsgBox "Le fichier ne sera pas envoyé."
Cancel = True
End If
End Sub
I didn't mean to remove the Set Doc = Nothing. My intention was to point out that whatever changes you made before that command must be lost because they weren't saved. In the code below the document is closed and saved.
Private Sub Commande47_Click()
Dim mydoc As String
mydoc = "P:\Commun\SECTEUR DU TRANSPORT SCOLAIRE\Harnais\Autorisations Parentales\Autorisation_blank.docm"
Call FillWordForm
End Sub
Function FillWordForm(Ffn As String)
Dim appWord As Word.Application
Dim Doc As Word.Document
On Error Resume Next
Set appWord = GetObject(, "word.application")
If Err.Number Then Set appWord = New Word.Application
appWord.Visible = True
On Error GoTo 0
Set Doc = appWord.Documents.Open(Ffn, , False)
' the newly opened document is activated by default
With Doc
.FormFields("eleves_nom").Result = Me.f_autpar_nom
.FormFields("eleves_numfiche").Result = Me.f_autpar_fiche
.Close True ' close the file and save the changes made
End With
Set appWord = Nothing
End Function
However, I also agree with #Kazimierz Jawor that your construct is unfortunate. Basically, the document's On_Open procedure should run when you open the document from Access. Therefore the email is probably sent before you even get to setting the form fields. My suggestion to save the changes is likely to take effect only when you run the code the second time.
The better way should be to send the mail from either Access or Word. My preference would be the latter. It should be easy to extract two values from an Access table using Word, add them to a Word document and mail out the whole thing. I don't see, however, why you should use the Open event to do that. If that choice is the more logical one then doing everything from within Access would be the conclusion.
I have a VBA code which allows me to read/place string in HTML objects (like input boxes).
This is the example of code:
Sub ReadCheck()
Dim objlement As Object
Dim i As Integer
Dim isNothing As Boolean
'
Dim shellWins As ShellWindows
Dim ie As InternetExplorer
'Set shellWins = New ShellWindows
Set shellWins = New ShellWindows
i = shellWins.Count
'On Error Resume Next
For i = 0 To i - 1
If shellWins.Item(i).Parent = "Internet Explorer" Then
If shellWins.Item(i).Document.URL = "https://intservices.mybebpage" Then
Set ie = shellWins.Item(i)
Exit For
End If
End If
Next i
On Error GoTo 0
isNothing = ie Is Nothing
Debug.Print Format(Now, "HH:MM:SS") & " IE is nothing: " & isNothing
If isNothing Then Exit Sub
'combo box
Set objlement = ie.Document.getelementsbyname("txtboxx")
objlement (0).Value = "Some text to place"
End Sub
Due to my testing, this code works fine with 99% of cases, but sometimes it returns error 91 (Object variable or With block variable not set), in the last line.
I'm pretty sure, that I can get correct object for objelement, but it looks like there were no .Value property for it.
This is wierd, becouse I know that this code works.
In my opinion the most possible reason for this is that I should use some different properties than .Value for this.
Do you have any comments for this?
I'm using VBA in access to open up a protected word template, fill in the data, and then re-protect it.... this way, if the database system goes down, the word template can still be used manually in its protected state.
I have just started using VBA and in this line:
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:=""
End If
I'm concerned that whilst running the code in access, that if the user opens up another word document and makes it the focus, that it will occidentally get protected instead of the other. How do I keep active focus on the document I'm writing to... or do I need to reference my document somehow using WordApp.protect (or something similar that works)
Private Sub Command0_Click()
Dim WordApp As Word.Application
Dim strDatabasePath As String
Dim strTemplatePath As String
Dim strTemplate As String
Dim strJobTitle As String
Dim strFile As String
strFile1 = "testcoc.dotx"
strFile2 = "testcoc-private.dotx"
strDatabasePath = CurrentProject.Path & "\"
strTemplatePath = "\templates\"
strTemplate = strDatabasePath & strTemplatePath & strFile2
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set WordApp = CreateObject("Word.Application")
End If
On Error GoTo ErrHandler
WordApp.Visible = True
WordApp.WindowState = wdWindowStateMaximize
WordApp.Documents.Add Template:=strTemplate, NewTemplate:=True
'strJobTitle = DLookup("JobTitle", "Job", "JobNum = " & [JobType])
strJobTitle = DLookup("JobTitle", "Job", "JobNum = 'J0456'")
With WordApp.Selection
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:=""
End If
.Goto what:=wdGoToBookmark, Name:="bm_0_4"
.TypeText strJobTitle
End With
'Reprotect the document.
'If ActiveDocument.ProtectionType = wdNoProtection Then
'ActiveDocument.Protect _
'Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=""
'End If
DoEvents
WordApp.Activate
Set WordApp = Nothing
Exit Sub
ErrHandler:
Set WordApp = Nothing
End Sub
Thank You
I haven't tried this but WordApp.Documents.Add Template:=strTemplate, NewTemplate:=True does return the new document. So I would do something like
Dim doc as Word.Document
Set doc = WordApp.Documents.Add(Template:=strTemplate, NewTemplate:=True)
and reference doc throughout my code instead of ActiveDocument. It seems like doing that should get help you avoid the particular situation you're concerned about.