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.
Related
I want to implement an VBA application, which uses the selected object (E-mail, task, folder).
My try with Application.ActiveExplorer.Selection.Item(i_item) seems to return only mails, tasks, calender entries or notes but never an folder (e.g. 'Inbox\').
When the user selects an e-mail, and then starts the VBA macro, the solution Application.ActiveExplorer.Selection.Item(i_item) delivers the desired results.
However, if the last item picked by the Outlook user was an folder (e.g. 'Sent Mails'). And the VBA makro started afterward, than the macro should recive the Folder Item (without additional user interaction). This is currently not the case. The code above still delivers the e-mail, or task.
How do I check, if the last selection was on an folder (not an e-mail, etc)?
How do I access the Folder item?
If this is not possible I will switch back to Pickfolder (like proposd by Darren Bartrup-Cook) but this is not me prefred solution.
I want to get the selected folder in order to change its icon, so our code is somehow the same.
I noticed that Application.ActiveExplorer.Selection.Item(i_item) it is not perfect, since it throws an exception for empty folders or on calendar etc.
So I use Application.ActiveExplorer.CurrentFolder.DefaultMessageClass (Application.ActiveExplorer.NavigationPane.CurrentModule.Name or Application.ActiveExplorer.NavigationPane.CurrentModule.NavigationModuleType) in order to figure out where I actually am.
By that approach it is easy to get current selected folder
Dim folder As Outlook.MAPIFolder
Dim folderPath As String, currItemType As String
Dim i As Integer
currItemType = Application.ActiveExplorer.CurrentFolder.DefaultMessageClass
If currItemType = "IPM.Note" Then 'mail Item types https://msdn.microsoft.com/en-us/library/office/ff861573.aspx
Set folder = Application.ActiveExplorer.CurrentFolder
folderPath = folder.Name
Do Until folder.Parent = "Mapi"
Set folder = folder.Parent
folderPath = folder.Name & "\" & folderPath
Loop
Debug.Print folderPath
End If
haven't got an problem with it yet. In your case, you can store the selection in a global variable, so you always know which folder was selected last.
This procedure will ask you to select the folder.
If you interrupt the code and examine the mFolderSelected or MySelectedFolder then you should be able to work something out:
Public Sub Test()
Dim MySelectedFolder As Variant
Set MySelectedFolder = PickFolder
End Sub
Public Function PickFolder() As Object
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
On Error GoTo ERROR_HANDLER
Set oOutlook = CreateObject("Outlook.Application")
Set nNameSpace = oOutlook.GetNameSpace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The commented out code will return only email folders. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Not mFolderSelected Is Nothing Then
' If mFolderSelected.DefaultItemType = 0 Then
Set PickFolder = mFolderSelected
' Else
' Set PickFolder = Nothing
' End If
Else
Set PickFolder = Nothing
End If
Set nNameSpace = Nothing
Set oOutlook = Nothing
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure PickFolder."
Err.Clear
End Select
End Function
NB: This was written to be used in Excel and has late binding - you'll need to update it to work in Outlook (no need to reference Outlook for a start).
Can anyone help me figure out what's going wrong and how to fix it?
I'm trying to automate sending an email with some daily status information. I'd tried automating this from Access but kept running into (known but apparently unsolved) problems with GetObject(, "Outlook.Application") with Windows 8.1 64 and Outlook 2013. So I decided to automate starting from Outlook.
Anyway, I moved the mail message creation code into Outlook vba and had it start Access and run the Access code. This is all well and good until I get to creating the mail message. Everything starts just fine until it gets to writing to the body of message (using Word as the body editor). At the first "TypeText" command, I'm getting the error message in the title. If I click debug on the error notification dialog and then single-step through the line of code in question, it works just fine. I thought that there was some timing problem, so I stuck a 2-second wait in the code. No luck. The code in question, with some other oddities associated with testing (notably trying to type and then delete text), is below:
Public Sub CreateMetrics()
' Mail-sending variables
Dim mailApp As Outlook.Application
Dim accessApp As Access.Application
Dim mail As MailItem
Dim wEditor As Word.Document
Dim boolCreatedApp As Boolean
Dim i As Integer
Set mailApp = Application
' Create an Access application object and open the database
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDatabase dbLoc
accessApp.Visible = True
' Open the desired form and run the click event hander for the start button
accessApp.DoCmd.OpenForm ("ProcessStatus")
accessApp.Forms![ProcessStatus].StartButton_Click
' Create the outgoing mail message
Set mail = Application.CreateItem(olMailItem)
mail.Display
mail.BodyFormat = olFormatHTML
Set wEditor = mailApp.ActiveInspector.WordEditor
With accessApp.Forms![ProcessStatus]
Debug.Print .lblToList.Caption
Debug.Print .lblSubject.Caption
Debug.Print .lblIntroduction.Caption
Debug.Print .lblAttachFilepath.Caption
End With
mail.To = accessApp.Forms![ProcessStatus].lblToList.Caption
mail.Recipients.ResolveAll
mail.Subject = accessApp.Forms![ProcessStatus].lblSubject.Caption
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
Sleep 2000
' Error occurs in the next line ***********************************************
wEditor.Application.Selection.TypeText Text:="Test"
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.Delete Count:=4
wEditor.Application.Selection.PasteSpecial DataType:=wdPasteBitmap
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.TypeText accessApp.Forms![ProcessStatus].lblIntroduction.Caption
wEditor.Application.Selection.TypeText Text:=Chr(13) & Chr(13)
wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.TypeText Text:=Chr(13)
' wEditor.Application.Selection.TypeText Text:=configs("EmailSignature")
' End With
With mailApp.Session.Accounts
i = 1
Do While i <= .Count
' Use either the specified email address OR the last outlook email address
If RegEx_IsStringMatching(.Item(i).SmtpAddress, accessApp.Forms![ProcessStatus].lblSenderRegex.Caption) Or i = .Count Then
mail.SendUsingAccount = .Item(i)
i = .Count + 1
Else
i = i + 1
End If
Loop
End With
mail.Save
accessApp.Quit
End Sub
I added a "mail.Display" just before the line that was causing the failure, which seemed, incorrectly, to have fixed the problem.
I have now solved this problem by executing a document.select on the document associated with the email I was creating. To select the right document (there doesn't seem to be any guarantee of which one that would be within the wEditor.Application.Documents collection, though it was typically the first one), I created an almost-certainly unique piece of text and assigned it to the body of the email, which I could then go and find. Here's the new code that I added to the code above:
Dim aDoc As Word.Document
Dim strUniqueID As String
. . .
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
strUniqueID = accessApp.Forms![ProcessStatus].lblSubject.Caption & Rnd(Now()) & Now()
mail.Body = strUniqueID
' Search for the unique text. aDoc.Content has extra characters at the
' end, so compare only for the length of the unique text
For Each aDoc In wEditor.Application.Documents
If Left(aDoc.Content, Len(strUniqueID)) = strUniqueID Then
aDoc.Select
mail.Body = ""
End If
Next aDoc
wEditor.Application.Selection.TypeText Text:="Test"
. . .
I looked at a lot of examples of code that did this kind of thing. None of them performed a select or said anything about needing one. Debugging was made that much harder because the select occured implicitly when the debugger was invoked.
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.