I want to remove all vba-modules from an MS Word template using VBScript. I wrote the following script.
const wdDoNotSaveChanges = 0
WScript.Echo "starting Word..."
Dim oApplication, doc
Set oApplication = CreateObject("Word.Application")
WScript.Echo "opening template..."
oApplication.Documents.Open "path\to\test.dot"
Set doc = oApplication.ActiveDocument
Dim comp, components
Set components = oApplication.ActiveDocument.VBProject.VBComponents
For Each comp In components
components.Remove comp
Next
WScript.Echo "exiting..."
doc.close wdDoNotSaveChanges
oApplication.Quit wdDoNotSaveChanges
When running similar code in a VBA-module in Word, that works, but when I run this VBScript, I get this error: test.vbs(14, 2) Microsoft VBScript runtime error: Invalid procedure call or argument
It turns out that it is not possible to remove the VBComponent named "ThisDocument" (If you right click it in the IDE the remove option is not active). You can use something like:
For Each comp In components
If comp.Name <> "ThisDocument" Then
components.Remove comp
End If
Next
Related
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.
(Using Windows 10 and MS Word 2016. Global templates are: Normal.dotx and Autoload.dotm. Attached template to some docs is: Reference.dotx)
Hello everyone,
I'm having problems in VBA getting the attached template of a document.
I have a global template that loads when I load MS Word, called Autoload.dotm. But, for some specific documents, they use an attached template, which is not the global template (Autload.dotm) or the regular template (Normal.dotx). This attached template is called Reference.dotx.
So I use ActiveDocument.AttachedTemplate. But this returns Autoload.dotm, not Reference.dotx. I need to find out if the attached template defined in Developer->Document Template->Templates tab->Document Template is Reference.dotx. (Don't think it makes a difference, but the "Automatically update document styles" checkbox is checked.) Does anyone know how I can find if a document uses Reference.dotx? I don't need any of the global templates returned.
The code I'm using to try to get the attached template is simple:
If (ActiveDocument.AttachedTemplate = "Reference.dotx") Then
PrepareDocument_enabled = True
End If
Maybe this will help you? It will show the template used.
Sub Macro1()
Dim strPath As String
strPath = Dialogs(wdDialogToolsTemplates).Template
MsgBox strPath
End Sub
Otherwise, you can use this to change the template
Sub ChangeAttachedTemplate()
Dim oDoc As Document
Dim oTemplate As Template
Dim strTemplatePath As String
Set oDoc = ActiveDocument
If oDoc.Type = wdTypeTemplate Then Exit Sub
Set oTemplate = oDoc.AttachedTemplate
Debug.Print oTemplate.FullName
' Path is probably: C:\Users\USERNAME\AppData\Roaming\Microsoft\Templates\
If InStr(UCase(oTemplate.FullName), UCase("Path of the template")) > 0 Then
oDoc.AttachedTemplate = "PATH TO TEMPLATE" & "TEMPLATE NAME.dotm"
End If
End Sub
I am using the Word.GetAddress function in an Excel document to retrieve the first & last names of someone if he is in the GAL.
From what I have understand, the only way to have the built-in "Check Names" dialog is to use the Word.GetAddress function.
When the name entered matches more than entry, the "Check Names" displays but in the background. I have to Alt+Tab to get it.
I have tried to use the "Activate" function or the "WindowsState" property to bring it upfront but I am stuck ...
Function getFirstAndLastNames(pName As String) As String
Dim oWord As Word.Application
Dim strAddress As String
On Error GoTo getFirstAndLastNames_Error
'If the search doesn't work, returns the argument
getFirstAndLastNames = pName
'Create the Word object to use GetAddress
Set oWord = CreateObject("Word.Application")
'Search
strAddress = oWord.GetAddress(Name:=pName, CheckNamesDialog:=True, AddressProperties:="<PR_GIVEN_NAME> <PR_SURNAME>")
'If there is a result, the function returns it
If strAddress <> "" Then getFirstAndLastNames = strAddress
'Quit Word
oWord.Quit
Set oWord = Nothing
On Error GoTo 0
Exit Function
getFirstAndLastNames_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getFirstAndLastNames of Module Test"
If Not (oWord Is Nothing) Then oWord.Quit
End Function
I have seen this post where there was a similar issue resolved but it doesn't say how ...
Thanks in advance for your help.
The edit to the other post does not state that they found a resolution for the box not coming to the front; only that it could be made visible using alt-tab to bring it to the front.
You have a deadlock in that your Excel code is stopped, waiting for Word and you need an action to have the Word (or rather Outlook) window brought to the front so the user can find it.
You could minimize and restore the Excel window but it is kludge and if there are other windows on screen then it'll be unreliable as the dialog you need will be hidden behind those too.
What you need to do is a bit ugly but will work. Which is to have a helper script or application which you can fire off asynchronously using Application.Run which will start the app and continue to execute in VBA. That script/app will wait for a little while (to give VBA time to run the GetAddress line) and then bring that dialog to the front using the windows API.
Most scripting or programming languages will be good enough and which one you choose depends on what you are most comfortable with. StackOverflow has an example for Powershell that you can adjust to your needs.
Finally, I found an article on the support of Microsoft.com that explain how to use CheckSpelling outside of Word. I adapted it to my use.
The code position the Word window off the screen but the dialogs appears in the foreground.
Function getFirstAndLastNames(pName As String) As String
Dim oWord As Word.Application
Dim strAddress As String
Dim lOrigTop As Long
Dim lOrigState As Byte
'Display the "Check names" dialog (available only with Word.Application ...)
On Error GoTo getFirstAndLastNames_Error
'If the search doesn't work, returns the argument
getFirstAndLastNames = pName
'Create the Word object to use GetAddress
Set oWord = CreateObject("Word.Application")
'Position Word off screen to avoid having document visible
'http://support.microsoft.com/kb/243844/en-us
lOrigTop = oWord.Top
lOrigState = oWord.WindowState
oWord.Top = -3000
oWord.Visible = True
oWord.WindowState = wdWindowStateMinimize
oWord.Activate
'Search
strAddress = oWord.GetAddress(Name:=pName, CheckNamesDialog:=True, AddressProperties:="<PR_GIVEN_NAME> <PR_SURNAME>")
'If there is a result, the function returns it
If strAddress <> "" Then getFirstAndLastNames = strAddress
'Reset the position and state of Word and quit the application
oWord.Visible = False
oWord.Top = lOrigTop
oWord.WindowState = lOrigState
oWord.Quit
Set oWord = Nothing
On Error GoTo 0
Exit Function
getFirstAndLastNames_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getFirstAndLastNames of Module Test"
'If an error raised, Reset the position and state of Word and quit the application
If Not (oWord Is Nothing) Then
oWord.Top = lOrigTop
oWord.WindowState = lOrigState
oWord.Quit
End If
End Function
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.
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.