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.
Related
I'm looking for some advice on Microsoft Access VBA - Basically, I have been asked to create a button on a form, upon this button being clicked it will display a box asking for a folder name (I can manually type in, then click 'Ok') which will then create a subfolder in a public folder within Outlook/Exchange 2013.
Any information / advice on this would be fantastic. I have tried some examples on the Internet but my VBA knowledge doesn't allow me to amend the code for my needs.
No doubt this code can be tidied up. It will create a folder called 'New One' within the Inbox.
You'll need to update the code to point to the correct folder and ask for the new name.
Sub CreateFolder()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object
Dim sFolder As String
sFolder = "Mailbox - Bill Gates\Inbox"
Set oOutlook = CreateObject("Outlook.Application")
Set nNameSpace = oOutlook.GetNameSpace("MAPI")
Set oFolder = GetFolderPath(sFolder)
oFolder.Folders.Add "New One" 'Add the 'New One' folder to the Inbox.
End Sub
'----------------------------------------------------------------------------------
' Procedure : GetFolderPath
' Author : Diane Poremsky
' Date : 09/06/2015
' Original : http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
' Purpose :
'-----------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Object 'Outlook.Folder
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim oFolder As Object 'Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
Set oOutlook = CreateObject("Outlook.Application")
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
FoldersArray = Split(FolderPath, "\")
Set oFolder = oOutlook.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Object
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Use the Shell command in VBA. You can execute DOS commands to make folders.
https://msdn.microsoft.com/en-us/library/office/gg278437%28v=office.15%29.aspx
I'm trying to extract US Patent titles using MSXML6.
On the full-text html view of a patent document on the USPTO website, the patent title appears as the first and only "font" element that is a child of "body".
Here is my function that is not working (I get no error; the cell with the formula just stays blank).
Can somebody help me figure out what is wrong?
An example URL that I am feeding into the function is http://patft.uspto.gov/netacgi/nph-Parser?Sect1=PTO1&Sect2=HITOFF&d=PALL&p=1&u=%2Fnetahtml%2FPTO%2Fsrchnum.htm&r=1&f=G&l=50&s1=6293874.PN.&OS=PN/6293874&RS=PN/6293874
Function getUSPatentTitle(url As String)
Static colTitle As New Collection
Dim title As String
Dim pageSource As String
Dim xDoc As MSXML2.DOMDocument
Dim xNode As IXMLDOMNode
On Error Resume Next
title = colTitle(url)
If Err.Number <> 0 Then
Set html_doc = CreateObject("htmlfile")
Set xml_obj = CreateObject("MSXML6.XMLHTTP60")
xml_obj.Open "GET", url, False
xml_obj.send
pageSource = xml_obj.responseText
Set xml_obj = Nothing
Set xDoc = New MSXML2.DOMDocument
If Not xDoc.LoadXML(pageSource) Then
Err.Raise xDoc.parseError.ErrorCode, , xDoc.parseError.reason
End If
Set xNode = xDoc.getElementsByTagName("font").Item(1)
title = xNode.Text
If Not title = "" Then colTitle.Add Item:=title, Key:=url
End If
On Error GoTo 0 ' I understand "GoTo" is dangerous coding but copied from somebody and so far haven't thought of a more natural substitute for a GoTo statement
getUSPatentTitle = title
End Function
Just a few points:
"On Error Goto 0" is not really a traditional Goto statement - it's just how you turn off user error handling in VBA. There were a few errors in your code but the "On Error Resume Next" skipped them so you saw nothing.
The data from the web page is in HTML format not XML.
There were a few "font" elements before the one with the title.
This should work:
Function getUSPatentTitle(url As String)
Static colTitle As New Collection
Dim title As String
Dim pageSource As String
Dim errorNumber As Integer
On Error Resume Next
title = colTitle(url)
errorNumber = Err.Number
On Error GoTo 0
If errorNumber <> 0 Then
Dim xml_obj As XMLHTTP60
Set xml_obj = CreateObject("MSXML2.XMLHTTP")
xml_obj.Open "GET", url, False
xml_obj.send
pageSource = xml_obj.responseText
Set xml_obj = Nothing
Dim html_doc As HTMLDocument
Set html_doc = CreateObject("HTMLFile")
html_doc.body.innerHTML = pageSource
Dim fontElement As IHTMLElement
Set fontElement = html_doc.getElementsByTagName("font").Item(3)
title = fontElement.innerText
If Not title = "" Then colTitle.Add Item:=title, Key:=url
End If
getUSPatentTitle = title
End Function
CSS selector:
You can re-write what you described, which in fact is first font tag within a body tag as a CSS selector of:
body > font
CSS query:
VBA:
As it is the first match/only you want you can use the querySelector method of document to apply the selector and retrieve a single element.
Debug.Print html_doc.querySelector("body > font").innerText
You may need to add a reference to HTML Object Library and use an early bound call of Dim html_doc As HTMLDocument to access the method. The late bound method may expose the querySelector method but if the interface doesn't then use early binding.
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.
I am using Access to send data to a template I created in Word. After it succesfully sends the data I need to make the open Word Document NON-editable.
Also, I notice that after I am done with the Document it prompts to save. Is it possible to remove this prompt, BUT allow the capability to save.
This is the code I am using to do the Word Automation:
' Create a Word document from template.
Dim WordApp As Word.Application
Dim strTemplateLocation As String
Dim myVariable As String
myVariable = “TEST!!”
' Specify location of template
strTemplateLocation = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "test.dot"
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.WindowState = wdWindowStateMaximize
WordApp.Documents.Add Template:=strTemplateLocation, NewTemplate:=False
' Replace each bookmark with field contents.
WordApp.Selection.GoTo what:=wdGoToBookmark, Name:="myBookmark"
WordApp.Selection.TypeText myVariable
DoEvents
WordApp.Activate
Set WordApp = Nothing
The Document object has a Saved property which normally changes to False if any changes are made. If you set this property to True then you won't be prompted to save the document when you close it but you can still save it manually (via Save or Save As...) if you want to.
You can use the Protect method of the Document object to restrict the changes which the user can make. For example, you can call it with the parameter wdAllowOnlyReading which will mean that no changes of any kind can be made. You may also need to look at password protecting the document to prevent the user from simply unprotecting it again
This should do what you need. Tested from Excel, not Access, so you'll need to fix the template path
Sub Tester()
' Create a Word document from template.
Dim WordApp As Word.Application
Dim strTemplateLocation As String
Dim myVariable As String
myVariable = "TEST!!"
' Specify location of template
strTemplateLocation = ThisWorkbook.Path & "\test.dotx"
Set WordApp = CreateObject("Word.Application")
With WordApp
.Visible = True
.WindowState = wdWindowStateMaximize
.Documents.Add Template:=strTemplateLocation, NewTemplate:=False
' Replace each bookmark with field contents.
.Selection.GoTo what:=wdGoToBookmark, Name:="myBookmark"
.Selection.TypeText myVariable
DoEvents
With .ActiveDocument
.Protect Type:=wdAllowOnlyReading, Password:="blah"
.Saved = True
End With
.Activate
End With
Set WordApp = Nothing
End Sub
I have created an application form using MS Word and a whole bunch of form fields, and I have an Access db that can import all the data I need from this Word doc, thanks to this:
http://msdn.microsoft.com/en-us/library/aa155434%28office.10%29.aspx
Now everything works just fine (I even managed to get it to import into multiple tables!), but the problem with the above is that I have to manually enter the name of each file one at a time... which is fine if it's just a case of importing the application form as it comes in... but I have quite a lot sitting in a folder that needs entered into the database.
Then I found this:
How to show "Open File" Dialog in Access 2007 VBA?
I've tried to tweak and merge the two to make it work... but as you can guess, to no avail... (it doesn't help when I'm very much an Access novice!)
What I am looking to do is to be able to import a bunch of Word docs / form fields into MS Access by using the Open / Select file dialogue box... what I've got works, but I'd like to make it easier to work with!
Thanks everyone
Jake
##### Codes I been using
Option Compare Database
Option Explicit
Private Sub cmdFileDialog_Click()
' This requires a reference to the Microsoft Office 11.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Dim appWord As Word.Application
Dim doc As Word.Document
' Dim cnn As New ADODB.Connection
' Dim rst As New ADODB.Recordset
Dim strDocName As String
Dim blnQuitWord As Boolean
' Clear the list box contents.
' Me.FileList.RowSource = ""
' Set up the File dialog box.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow the user to make multiple selections in the dialog box.
.AllowMultiSelect = True
' Set the title of the dialog box.
.Title = "Select One or More Files"
' Clear out the current filters, and then add your own.
.Filters.Clear
.Filters.Add "Microsoft Word", "*.DOC"
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
' Loop through each file that is selected and then add it to the list box.
For Each varFile In .SelectedItems
' Me.FileList.AddItem varFile
Set appWord = GetObject(, "Word.Application")
Set doc = appWord.Documents.Open(varFile)
' cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
' "Data Source=M:\Medical\GPAppraisal\Contacts & Databases\" & _
' "AppForm.mdb;"
' rst.Open "tbl_Applicants", cnn, _
' adOpenKeyset, adLockOptimistic
' With rst
.addnew
!Title = doc.FormFields("wTitle").Result
!FirstName = doc.FormFields("wFirstName").Result
!LastName = doc.FormFields("wLastName").Result
!Address1 = doc.FormFields("wAddress1").Result
!Address2 = doc.FormFields("wAddress2").Result
!Address3 = doc.FormFields("wAddress3").Result
!City = doc.FormFields("wCity").Result
!PostCode = doc.FormFields("wPostCode").Result
!Email = doc.FormFields("wEmail").Result
!Phone1 = doc.FormFields("wPhone1").Result
!Phone2 = doc.FormFields("wPhone2").Result
!LM = doc.FormFields("wLM").Result
!LMAddress1 = doc.FormFields("wLMAddress1").Result
!LMAddress2 = doc.FormFields("wLMAddress2").Result
!LMAddress3 = doc.FormFields("wLMAddress3").Result
!LMCity = doc.FormFields("wLMCity").Result
!LMPostCode = doc.FormFields("wLMPostCode").Result
!LMEmail = doc.FormFields("wLMEmail").Result
!LMPhone = doc.FormFields("wLMPhone").Result
!LMOK = doc.FormFields("wLMOK").Result
!Probity = doc.FormFields("wProbity").Result
!Practising = doc.FormFields("wPractising").Result
!Signature = doc.FormFields("wSignature").Result
!AppDate = doc.FormFields("wAppDate").Result
!e2011012028 = doc.FormFields("w2011012028").Result
!e2011021725 = doc.FormFields("w2011021725").Result
!e2011030311 = doc.FormFields("w2011030311").Result
!e2011031625 = doc.FormFields("w2011031625").Result
!e20110203 = doc.FormFields("w20110203").Result
!e20110211 = doc.FormFields("w20110211").Result
!e20110322 = doc.FormFields("w20110322").Result
!e20110330 = doc.FormFields("w20110330").Result
.Update
.Close
End With
doc.Close
If blnQuitWord Then appWord.Quit
cnn.Close
MsgBox "Application Imported!"
Cleanup:
' Set rst = Nothing
' Set cnn = Nothing
Set doc = Nothing
Set appWord = Nothing
Next
Else
MsgBox "You clicked Cancel in the file dialog box."
End If
End With
End Sub
#
I've tried to mess with me.tables and me!forms and .add etc etc - obviously I'm a complete novice here!!!
What I want is to be able to import data from form fields in a Word Doc into a MS Access table (which I have managed to do with the first URL in my original post above); by means of selecting the Word doc from the Open/Select dialogue box, instead of manually entering the names of each Word doc.
My apologies if it sounds obvious or simple - Access is not my strong point by any means!
Before I begin I didn't understand why you have so many uncommented lines (lines beginnig mit ' ) in you code example. I assume that most of those lines would normally not bei uncommented and be part of the working code. Or are there artifacts of the Stack Overflow Editor?
I see a few problems, that might to guide you to a solution.
1) When you use
With fDialog
you let this 'open' until the end of the code (even using a second With in between). I would recommend to set you corresponding 'End With' right after you no longer require it. Remeber (or take note): The
With fDialog
[... something]
' Set the title of the dialog box.
.Title = "Select One or More Files"
is really just a shorthand for
fDialog.Title
(i.e. a "naked" . means, that it has to be appendend to the object in the With) so you could do away with the "With" entirely. IN you example I would set the "End With" right before
If .Show = True Then
and then use
If fDialog.Show = True Then
2) I would set
Set appWord = GetObject(, "Word.Application")
outside your For Each loop (don't forget to take Set appWord = Nothing outside the loop as well). Remember that with GetObject you need an runnig Word-instance, otherwise you might want to use
Set appWord = CreateObject("Word.Application")
or to have it both ways, try to get a Word-object, and if it is not available (i.e. Err.Number = 429) create a new one.
On Error Resume Next
Set appWord = GetObject(, "Word.Application")
If Err.Number = 429 Then
Set appWord = CreateObject("Word.Application")
End If
On Error GoTo 0
3) When working or at least while developping using automation I would always set
objword.Visible = True
so you see error messages or other problems right within Word.
HTH for the next steps (in case you have this problem anymore)
Andreas