VBA Import MS Access to MS Word - vba

I have a VBA module in MS-Access that is supposed to load data from a database into Form Fields in a MS-Word document. I thought it was working fine, but it appears to be inconsistent. Sometimes it works and sometimes it doesn't. I can't figure out what keeps it from working. When I step through the debugger it doesn't throw any errors, but sometimes it doesn't open MS-Word.
Here is the relevant code:
Dim appWord As Word.Application
Dim doc As Word.Document
'Avoid error 429, when Word isn't open.
On Error Resume Next
Err.Clear
'Set appWord object variable to running instance of Word.
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If Word isn't open, create a new instance of Word.
Set appWord = New Word.Application
End If
Set doc = appWord.Documents.Open("\\srifs01\hresourc\EHS Department\EHS Database\IpadUpload\Lab Inspection Deficiency Resolution Report.docx", , True)
'Sometimes word doesn't open and I think the issue is around here.
With doc
.FormFields("frmID").Result = Me!id
.FormFields("frmSupervisor").Result = Me!LabPOC
.FormFields("frmInspector").Result = Me!InspectorName
.FormFields("frmBuilding").Result = Me!BuildingName
.FormFields("frmRoom").Result = Me!Rooms
.FormFields("frmComments").Result = Me!Comments
.Visible = True
.Activate
.SaveAs "'" & Me!id & "'"
.Close
End With
Set doc = Nothing
Set appWord = Nothing
Any help is appreciated. Thanks in advance.

"When I step through the debugger it doesn't throw any errors, but sometimes it doesn't open MS-Word."
That's because you have On Error Resume Next. That instructs VBA to ignore errors.
Assume you've made this change in your code ...
Dim strDocPath As String
strDocPath = "\\srifs01\hresourc\EHS Department\EHS Database" & _
"\IpadUpload\Lab Inspection Deficiency Resolution Report.docx"
Then, when you attempt to open strDocPath, VBA would throw an error if appWord isn't a reference to a Word application instance ... AND you haven't used On Error Resume Next:
Set doc = appWord.Documents.Open(strDocPath, , True)
You can get rid of On Error Resume Next if you change your assignment for appWord to this:
Set appWord = GiveMeAnApp("Word.Application")
If Word was already running, GiveMeAnApp() would latch onto that application instance. And if Word was not running, GiveMeAnApp() would return a new instance.
Either way, GiveMeAnApp() doesn't require you to use On Error Resume Next in your procedure which calls it. Include a proper error handler there instead. And you can reuse the function for other types of applications: GiveMeAnApp("Excel.Application")
Public Function GiveMeAnApp(ByVal pApp As String) As Object
Dim objApp As Object
Dim strMsg As String
On Error GoTo ErrorHandler
Set objApp = GetObject(, pApp)
ExitHere:
On Error GoTo 0
Set GiveMeAnApp = objApp
Exit Function
ErrorHandler:
Select Case Err.Number
Case 429 ' ActiveX component can't create object
Set objApp = CreateObject(pApp)
Resume Next
Case Else
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure GiveMeAnApp"
MsgBox strMsg
GoTo ExitHere
End Select
End Function
You could also include a check to make sure appWord references an application before you attempt to use it. Although I don't see why such a check should be necessary in your case, you can try something like this ...
If TypeName(appWord) <> "Application" Then
' notify user here, and bail out '
Else
' appWord.Visible = True '
' do stuff with Word '
End If

I don't use the New keyword when opening or finding an application.
This is the code I use for excel:
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number = 429 Then 'Excel not running
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
(note also the On Error GoTo 0 - I don't want the resume next to be active all through the code)

The GiveMeAnApp function worked great for me with a similar problem I was experiencing. Except, to avoid Error 462 (cannot connect to server etc) if I closed the Word document after the data merge and attempted another merge of data to Word. (which caused error 462) I did this: Once I call GiveMeAnApp I then called for a New Word document before calling the Word template I wished to transfer data to Word into.
By always having the New Word document present this avoided error 462 in my circumstances. It means I am left with an empty Word doc but this is ok for me and preferable to the only other solution I could come up with which was to quit the db and re open and run the merge to Word aga.
I am grateful for the help set out in this thread. Thanks all.

Related

Custom Outlook Macro only runs in VBA editor

I've created a Macro based on a blog post that only successfully runs in the VBA editor. When I run it from Outlook itself, nothing happens. Maybe you can see something obvious that I'm missing.
Pressed Alt+F11 to open the editor.
Named the module and pasted in the code.
Compiled and run. The e-mail in question opened in HTML-format as expected.
Closed the editor and added the button to the toolbar I wanted. Nothing happens.
Returned to the VBA editor and run the code. It works as expected.
Closed and re-opened Outlook to try the button again. Nothing happens.
Here's the code, with a screenshot of the code in the editor to follow.
Sub ReplyInHtmlFormat()
Dim olSel As Selection
Dim oMail As MailItem
Dim oReply As MailItem
Set olSel = Application.ActiveExplorer.Selection
Set oMail = olSel.Item(1)
If oMail.BodyFormat = olFormatPlain Or olFormatRichText Or olFormatUnspecified Then
oMail.BodyFormat = olFormatHTML
oMail.Save
End If
Set oReply = oMail.Reply
oReply.Display
Set olSel = Nothing
Set oMail = Nothing
Set oReply = Nothing
End Sub
You may want to check the macro permissions to make sure it is allowed to run. I hope that helps! ;-)
Try to add MsgBox statement outside of any If statement and you will be able to understand whether it is actually running or not when you click a button added to the toolbar.
Also, I'd recommend adding an error-handling routine to the function:
Public Sub OnErrorDemo()
On Error GoTo ErrorHandler ' Enable error-handling routine.
Dim x, y, z As Integer
x = 50
y = 0
z = x / y ' Divide by ZERO Error Raises
ErrorHandler: ' Error-handling routine.
Select Case Err.Number ' Evaluate error number.
Case 10 ' Divide by zero error
MsgBox ("You attempted to divide by zero!")
Case Else
MsgBox "UNKNOWN ERROR - Error# " & Err.Number & " : " & Err.Description
End Select
Resume Next
End Sub
So, you will be aware of any issues if any.

My Access Vba is giving an automation error '-2147023170 (800706be)' when automating word

I am using a database to extract data that I need to present. Because I need to present the data in both landscape and portrait an access report will not do the trick. I am therefore using Access vba to put the data into a word template. However when I run the code over the full data I keep encountering an automation error. The word application ceases to exist.
I have queried and I don't think I have any of the common code errors associated with this problem, so no unreferenced word objects etc. I have also replaced all references to word constants like wdcell with their integer values. I have run through the code in debug, and when I run through in debug, the code never fails. I have put in some pauses (a function that waits a specific time and performs DoEvents) to see if that helps
Function MoveMergePaste(wdInputName As String, oWord As Word.Application, oWdocMerged As Word.Document) As Long
Dim oWdocMove As Word.Document
Dim oWdocMoveMerged As Word.Document
Dim rst As Recordset
Dim strSQL As String
On Error GoTo ERR_MoveMergePaste
Pause 1
strSQL = "SELECT T.* FROM tblMovementTemp AS T INNER JOIN tblMovementHeader AS H "
strSQL = strSQL & "ON T.FundId = H.FundId ORDER BY tblPosition"
Set rst = CurrentDb.OpenRecordset(strSQL)
Pause 0.5
Set oWdocMove = oWord.Documents.Open(wdInputName)
Pause 0.5
oWdocMove.Bookmarks("PremiumDataStart").Select
rst.MoveFirst
oWord.Selection.TypeText rst!tblElement
oWord.Selection.MoveRight Unit:=12 '(wdcell)
oWord.Selection.TypeText rst!TotalUnits
rst.MoveNext
While Not rst.EOF
oWord.Selection.MoveRight Unit:=12 '(wdcell)
oWord.Selection.TypeText rst!tblElement
oWord.Selection.MoveRight Unit:=12 '(wdcell)
oWord.Selection.TypeText rst!TotalUnits
rst.MoveNext
Wend
'Start mail merge Claims
'------------------------------------------------
With oWdocMove.MailMerge
.MainDocumentType = 0 'wdFormLetters
.OpenDataSource _
Name:=CurrentProject.FullName, _
AddToRecentFiles:=False, _
LinkToSource:=True, _
Connection:="QUERY mailmerge", _
SQLStatement:="SELECT * FROM [tblMovementHeader] "
.Destination = 0 'wdSendToNewDocument
.Execute Pause:=False
End With
'Copy movement data into merged document
'------------------------------------------------
Set oWdocMoveMerged = oWord.ActiveDocument
oWdocMoveMerged.Select
oWord.Selection.WholeStory
oWord.Selection.Copy
oWdocMerged.Select
oWord.Selection.EndKey Unit:=6 '(wdstory)
oWord.Selection.PasteAndFormat (wdFormatOriginalFormatting)
MoveMergePaste = 0
EXIT_MoveMergePaste:
On Error Resume Next
'Close files
'------------------------------------------------
oWdocMove.Close SaveChanges:=False
oWdocMoveMerged.Close SaveChanges:=False
'Release objects
'------------------------------------------------
Set oWdocMove = Nothing
Set oWdocMoveMerged = Nothing
Set rst = Nothing
Exit Function
ERR_MoveMergePaste:
MoveMergePaste = Err.Number
MsgBox Err.Description
Resume EXIT_MoveMergePaste
End Function
I pass a string which is for the path of a word template, a word application object, and an existing open word document. the routine builds a record set of data, opens the word template, finds a bookmark in the template and then writes data from the recordset to the template. Once it has done this it performs a mail merge on the template and copies the data from the newly created merged document into the open document. It returns 0 if successful. It closes the template and merged document and releases the objects.
Mostly it works, but far too often to make it usable I get the automation error. '-2147023170 (800706be)'. The error usually occurs because the word has ceased to exist. If I break the code the line of code that returns the error is
oWdocMove.Bookmarks("PremiumDataStart").Select
But the line is OK, the error is because word no longer exists.

Detect if an object has been disconnected from its clients

I am having an issue with automating an Excel file. The VBA script within Excel first opens a Word application and Word document:
Dim wordApp As Object
Set wordApp = CreateObject("Word.Application")
vPath = Application.ActiveWorkbook.Path
Set wordDoc = wordApp.Documents.Open(vPath & "\test.doc")
And then I call a subroutine within the Word document passing some data from the Excel file:
Call wordApp.Run("StartWithData", variable1, variable2)
If Excel detects that an error occurs in that subroutine, I close the Word document and Word application from Excel in a label I call Err1:
On Error Goto Err1
'all the code from above
Exit Sub
Err1:
wordDoc.Close wdCloseWithoutSaving
wordApp.Quit SaveChanges:=wdDoNotSaveChanges
Set wordDoc = Nothing
Set wordApp = Nothing
This works perfectly fine under normal circumstances; however, if the Word document or application are closed before the Err1 label executes (such as the user manually closing the document), I get the following error:
Run-time error '-2147417848 (80010108)':
Automation error The object invoked has disconnected from its clients.
which makes perfect sense because the wordApp and/or wordDoc variables still reference the Application and Document objects and those objects do not exist anymore (yet are also not considered to be Nothing).
So here is my inquiry: Is there a way to check if an object has been disconnected from its client before the run-time error occurs so as to avoid having to rely on on error resume next?
Such as:
If Not isDisconnected(wordDoc) Then
wordDoc.Close wdCloseWithoutSaving
End If
If Not isDisconnected(wordApp) Then
wordApp.Quit SaveChanges:=wdDoNotSaveChanges
End If
Update 1:
After looking at omegastripes' answer, I realized that the error given above only occurs when the document (wordDoc) was the object that got disconnected. If the Word application (wordApp) is what got disconnected, I get the following error:
Run-time error '462':
The remote server machine does not exist or is unavailable
Consider the below example:
Sub Test()
Dim wordApp As Object
Dim wordWnd As Object
Dim wordDoc As Object
Set wordApp = CreateObject("Word.Application")
Set wordWnd = wordApp.Windows ' choose any object property as indicator
wordApp.Visible = True ' debug
Set wordDoc = wordApp.Documents.Open(Application.ActiveWorkbook.Path & "\test.doc")
MsgBox IsObjectDisconnected(wordWnd) ' False with opened document
wordDoc.Close
MsgBox IsObjectDisconnected(wordWnd) ' False with closed document
wordApp.Quit ' disconnection
MsgBox IsObjectDisconnected(wordWnd) ' True with quited application
End Sub
Function IsObjectDisconnected(objSample As Object) As Boolean
On Error Resume Next
Do
IsObjectDisconnected = TypeName(objSample) = "Object"
If Err = 0 Then Exit Function
DoEvents
Err.Clear
Loop
End Function
Seems any type detection of the variable, which references to the intrinsic Word objects, like .Documents, .Windows, .RecentFiles, etc., made immediately after document close or application quit commands have been invoked, may throw the error 14: Out of string space, while Word application processing the command. The same detection on the Applicationobject , may also hang Excel application.
In the example TypeName() call is wrapped into OERN loop, that should skip irrelevant results to get explicit disconnection feedback, relying on the type name, but not on the error number. To avoid hanging, .Windows property is being checked instead of Application.

How to open outlook with VBA

I like to open Outlook with VBA. It should check if outlook is open and if not then it should open it. I have code but its to big and some times dont work with other macros with Call function. What should be the simple and short code to do this and work with all versions?
#Const LateBind = True
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6
#If LateBind Then
Public Function OutlookApp( _
Optional WindowState As Long = olMinimized, _
Optional ReleaseIt As Boolean = False _
) As Object
Static o As Object
#Else
Public Function OutlookApp( _
Optional WindowState As outlook.OlWindowState = olMinimized, _
Optional ReleaseIt As Boolean _
) As outlook.Application
Static o As outlook.Application
#End If
On Error GoTo ErrHandler
Select Case True
Case o Is Nothing, Len(o.Name) = 0
Set o = GetObject(, "Outlook.Application")
If o.Explorers.Count = 0 Then
InitOutlook:
'Open inbox to prevent errors with security prompts
o.session.GetDefaultFolder(olFolderInbox).Display
o.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set o = Nothing
End Select
Set OutlookApp = o
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set o = Nothing
Case 429, 462
Set o = GetOutlookApp()
If o Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function
#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As outlook.Application
#End If
On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
'Do not raise any errors
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function
Sub open_outlook()
Dim OutApp As Object
Set OutApp = OutlookApp()
'Automate OutApp as desired
End Sub
I think you can try below code.Its shortest code i tried to open in my all VBA coding.
Sub Open_Outlook()
Shell ("OUTLOOK")
End Sub
See How to automate Outlook from another program for the sample code. You can use the GetObject method for getting the running instance of Outlook instead of creating a new one:
Set objOutlook = GetObject(, "Outlook.Application")
However, Outlook is a singleton. Each time you call the CreateObject method you will get the same instance. You can't run two instances of Outlook at the same time. See GetObject in Word VBA script to find Outlook instance fails with 429 error unless both apps running as administrator for more info.
Be aware, Microsoft does not currently recommend, and does not support, Automation of Microsoft Office applications from any unattended, non-interactive client application or component (including ASP, ASP.NET, DCOM, and NT Services), because Office may exhibit unstable behavior and/or deadlock when Office is run in this environment.
If you are building a solution that runs in a server-side context, you should try to use components that have been made safe for unattended execution. Or, you should try to find alternatives that allow at least part of the code to run client-side. If you use an Office application from a server-side solution, the application will lack many of the necessary capabilities to run successfully. Additionally, you will be taking risks with the stability of your overall solution. Read more about that in the Considerations for server-side Automation of Office article.
Dim oOutlook As Object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
Shell ("OUTLOOK")
Else
'already open
End If
You could use something simplier:
Sub EmailMe()
dim mail as object
dim msg as object
set mail= createobject("Outlook.Application")
set msg=mail.createitem(0)
with msg
.to="someone#something.com;...."
.subject="What are you sending this for"
.body="Whatever you want to say"
.attachments.add Activeworkbook.fullname
.send
end with
end sub

Excel VBA to Open Multiple Word files in a loop

I apologize in advance for the newbie question -- most of my VBA experience is in Excel, or Word to Excel. In this case, I am going from Excel to Word. I am trying to capture some data off of some Word forms and store it in an Excel file.
Right now, my code works for the first document in the folder, but after that, it hoses up with an automation error "the server threw an exception" (goo!)
Here is my code:
Dim objWordApp As Object
strCurFileName = Dir(strFilePath)
Set objWordApp = CreateObject("word.application")
objWordApp.Visible = True
Do While strCurFileName <> ""
objWordApp.documents.Open strFilePath & strCurFileName
objWordApp.activedocument.Unprotect password:="testcode"
{EXCEL PROCESSING HERE}
strCurFileName = Dir
objWordApp.activedocument.Close 0
Loop
objWordApp.Quit
Set objWordApp = Nothing
I notice that the code works fine if I quit the app and set the object = nothing within the loop. But the way it is now, it bombs-out on the second file in the folder on the "objWordApp.documents.Open strFilePath & strCurFileName" line.
Can I open and close Word documents in a loop without having to create the object over and over? It's really slow when I do it that way.
Thanks for the help -- I like your way much better. Unfortunately, I get the same result. The program dies the second time through the loop on the line that reads:
Set objWordDoc = objWordApp.Documents.Open(objFile.Path)
The error that I get is:
Run-time Error -2147417851 (80010105)
Automation Error
The server threw an exception.
I tried your code on regular word docs (not the ones I'm processing) and it worked fine. The docs I'm running have form fields and macros -- not sure if that makes a difference. I have set the macro security in Word to both "low" and "very high" to make sure the other macros don't interfere.
I just can't figure it out why it works for the first doc and then not the next. I even cloned the first doc but it made no difference.
Still no luck, though. The only thing I can get to work is if I completely wipe the objects and re-create them every time I want to open a file.
Set objFolder = FSO.GetFolder(strFilePath)
For Each objFile In objFolder.Files
Set objWordApp = CreateObject("word.application")
objWordApp.Visible = True
If Right(objFile.Name, 4) = ".doc" Then
Set objWordDoc = objWordApp.documents.Open(Filename:=objFile.Path, ConfirmConversions:=False, _
ReadOnly:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto)
[Process DOC]
objWordDoc.Close 0, 1
End If
Set objWordDoc = Nothing
objWordApp.Quit
Set objWordApp = Nothing
Next
I'm not sure why that works and why it won't work the other way. If I have to go this route, I can -- it just seems really slow and inefficient. Is this a bad idea?
I changed the Dir to a FileSystemObject (go to Tools\References and add Microsoft Scripting Runtime) and I was able to successfully open multiple files. If you are having problems, please describe the error you see in the debugger. Also, if you need to recurse into subdirectories, you will need to refactor this.
Private mobjWordApp As Word.Application
Sub Test()
ProcessDirectory "PathName"
End Sub
Property Get WordApp() As Word.Application
If mobjWordApp Is Nothing Then
Set mobjWordApp = CreateObject("Word.Application")
mobjWordApp.Visible = True
End If
Set WordApp = mobjWordApp
End Property
Sub CloseWordApp()
If Not (mobjWordApp Is Nothing) Then
On Error Resume Next
mobjWordApp.Quit
Set mobjWordApp = Nothing
End If
End Sub
Function GetWordDocument(FileName As String) As Word.Document
On Error Resume Next
Set GetWordDocument = WordApp.Documents.Open(FileName)
If Err.Number = &H80010105 Then
CloseWordApp
On Error GoTo 0
Set GetWordDocument = WordApp.Documents.Open(FileName)
End If
End Function
Sub ProcessDirectory(PathName As String)
Dim fso As New FileSystemObject
Dim objFile As File
Dim objFolder As Folder
Dim objWordDoc As Object
On Error Goto Err_Handler
Set objFolder = fso.GetFolder(PathName)
For Each objFile In objFolder.Files
If StrComp(Right(objFile.Name, 4), ".doc", vbTextCompare) = 0 Then
Set objWordDoc = GetWordDocument(objFile.Path)
' objWordDoc.Unprotect Password:="testcode" ' Need to check if it has Password?
ProcessDocument objWordDoc
objWordDoc.Close 0, 1
Set objWordDoc = Nothing
End If
Next
Exit_Handler:
CloseWordApp
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
'Resume Next ' or as above
End Sub
Sub ProcessDocument(objWordDoc As Document)
'{EXCEL PROCESSING HERE}'
End Sub
EDIT: I've added some error handling and a little refactoring although there is quite a bit more refactoring that could be done.
There must be something special about the documents you are opening. You might try using different parameters for opening the documents, such as:
Set objWordDoc = objWordApp.Documents.Open( _
FileName:=objFile.Path, ReadOnly:=True)
You may need to add Microsoft Word as a Reference, and if you do that then start using the Word constants (wdDoNotSaveChanges, etc.). Check out the help on Documents.Open and test different parameters.
Also, use the "Set Next Statement" from the Context Menu during debugging and maybe skip the first document and open the second document directly and see if there are issues.
EDIT: I've changed the code to close and reopen Word if you get the automation error you described. You may have to adjust the error numbers, or simply close Word on any error (If Err.Number <> 0 Then ...).
Again, something must be special about your documents (macros, protection, etc.) because this code works on the test cases I have tried. Have you tried manually opening the documents in Word in the same order as the script, updating information similar to your process script, and then closing the documents to see if Word does anything strange?
Closing the Word.Application won't hurt anything, but it will obviously significantly slower.