I'm trying to create a vbscript that I can distribute so an outlook rule is created for each user that runs it.
I have some code (below), however I have since found I can't create a rule via VBS with Actions.Run ("VBA Code"). I need a rule so that whenever an email is received from "test#test.com" a msgbox is displayed that the user must click OK an.
Through my research it indicates that the VBA may somehow be able to be implemented in the VBS file, but I can't find much on it.
The VBA I want to run is:
Sub newmsg(item As Outlook.MailItem)
MsgBox "You have an urgent message: " & item.Subject
End Sub
and the VBS is:
'--> Create some constants
Const RULE_NAME = "Urgent Message" '<-- Edit the name of the rule
Const olRuleReceive = 0
'--> Create some variables
Dim olkApp, olkSes, olkCol, olkRul, olkCon, olkAct
'--> Connect to Outlook
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName
'--> Get the rules collection
Set olkCol = olkSes.DefaultStore.GetRules()
'--> Create a new receive rule
Set olkRul = olkCol.Create(RULE_NAME, olRuleReceive)
'--> Set the rule's condition to look for a specific word in the subject
Set olkCon = olkRul.Conditions.From
With olkCon
.Enabled = True
.Recipients.Add ("email address here")
.Recipients.ResolveAll
End With
'--> Set the rule's action
Set olkAct = olkRul.Actions.Run("Project1.newmsg")
With olkAct
.Enabled = True
End With
'--> Save the rule
olkCol.Save False
'--> Disconnect from Outlook
olkSes.Logoff
Set olkCon = Nothing
Set olkAct = Nothing
Set olkRul = Nothing
Set olkCol = Nothing
Set olkSes = Nothing
Set olkApp = Nothing
'--> Terminate the script
WScript.Quit
The only supported way to modify VBA projects is by developing an add-in for the VBA editor using the Visual Basic Extensibility interfaces.
If you need to create a rule that performs a custom action then I recommend you build an Outlook add-in that processes incoming email messages and does the action within your add-in's code, rather than relying on a VBA method that may or may not exist.
Related
What I'd need guidance specifically:
To have an indication of a native VBA method available on a new mail compose that would be triggered at any written word / phrase (or as often as possible), or a guidance on how to create an observable of a dynamic form property.
Purpose:
One Outlook functionality that could be interesting to have is to know its readability values as the mail is composed. I know they can be obtained by doing the spell checker, but I'd like to avoid the burden of doing the spellcheck to get the result - I'd like to see numbers going up and down as the mail is written.
Problem:
I kind of created the function I'd need but I failed to find a method that could trigger it at every word written. I'd assume it'd be something like WordEditor_Change, HTMLBody_Change or something alike. It'd be similar to the Worksheet_Change we have in Excel, where values can be obtained as the Excel sheet is edited.
I tried to set an observable of WordEditor.words.count but also failed miserably.
What I have so far:
WithEvents myMail As Outlook.MailItem
Private Sub Application_ItemLoad(ByVal Item As Object)
Set myMail = Item
End Sub
Sub checkStatistics()
Dim objInsp As Outlook.Inspector
Set objInsp = myMail.GetInspector
'Enum Outlook: https://msdn.microsoft.com/es-es/VBA/Outlook-VBA/articles/olobjectclass-enumeration-outlook
If objInsp.EditorType = olEditorWord Then ' outlook 2013
'Doc obj: https://msdn.microsoft.com/en-us/vba/word-vba/articles/document-object-word
Set objdoc = objInsp.WordEditor
Dim var As ClassHandlesEvent
Dim tst As classWithEvent
Set var = New ClassHandlesEvent
Set tst = New classWithEvent
var.EventVariable = tst
tst.value = objdoc.Words.Count
MsgBox objdoc.ReadabilityStatistics(9) & ": " & objdoc.ReadabilityStatistics(9).value & vbCrLf & "(Ideal values above 60)"
MsgBox objdoc.ReadabilityStatistics(8) & ": " & objdoc.ReadabilityStatistics(8).value & vbCrLf & "(Ideal values above 60)"
End If
Set objdoc = Nothing
Set objInsp = Nothing
End Sub
The below code that you execute
Set objdoc = objInsp.WordEditor
Gives you a WordDocument so now you have a WordVBA question instead of a OutlookVBA question. So you want an onchange event on changes to the document
I got lot of threads inside and outside of SO, which confirms that such a event doesn't exists
http://www.vbaexpress.com/forum/showthread.php?15718-Is-there-a-text-change-event-for-Word
Is there a way to trigger "track changes" through VBA in Excel?
Detecting when data is added to a document, eg. a character or white space
http://www.vbaexpress.com/forum/showthread.php?40690-MS-WORD-2k7-Table-content-change-event
So you will need to use what you have now, which is to check the content on email send
I autofoward all messages in a folder that I ran this macro on. I upgraded yesterday to 2013 and it does not work. I searched the commands used and couldn't find any of the ones I'm using not being recognized in Outlook 2013.
Sub ChangeSubjectForward(Item As Outlook.MailItem)
Item.Subject = "TAG NUMBER1234" & Item.Subject
Item.Save
Set myForward = Item.Forward
myForward.Recipients.Add "Email#email.com"
myForward.Send
End Sub
Your code looks good, I don't see anything strange in the code. It looks like you need to create a rule and assign the VBA macro sub to run.
Some Questions:
What are your rule settings that run this?
Are you manually running the rule on the folder, or is the rule automatically running on a trigger?
Are you getting any error messages?
Try the following:
Make sure the rule that runs your autoforward macro is lower on the rule list than the rule that files messages in that subfolder (if you're using one).
Also, since I don't know what triggers your macro, exactly, it's possible it is stopping when it is encountering a non MailItem object. Try this change:
Sub ChangeSubjectForward(olObj As Object)
dim Item As Outlook.MailItem
If olObj.Class <> olMail Then 'Making sure it is an email message
msgbox("Object Was Not MailItem")
Exit Sub
End If
Set Item = olObj
Item.Subject = "TAG NUMBER1234" & Item.Subject
Item.Save
Set myForward = Item.Forward
myForward.Recipients.Add "Email#email.com"
myForward.Send
End Sub
If you keep getting the message "Object Was Not MailItem" then the wrong objects are getting passed to your sub.
i have about ten responses from StackOverflow open but none of them quite answer my problem.
i have created several UserForms in Excel VBA for this particular project. (Note: i have no formal training on VBA programming and everything i have done is self-taught or gleaned from copying other people's codes.) While interfacing with more than one of these forms, i want the user to be able to access a command to select a user-name from the company's Global Address List. With a command button on the form and the following function i am able to do this:
Public Function GetUsernameFromOutlook(sCap As String) As String
'fancy code to call Outlook dialog box to select names.
'Badresult is the default, gives username of operator if they try to:
' select more than one recipient
' cancel out of the dialog box
Dim olApp As Object ' Outlook.Application
Dim olDialog As Object ' Outlook.SelectNamesDialog
Dim hwnd As Long
Set olApp = CreateObject("Outlook.Application")
Set olDialog = olApp.Session.GetSelectNamesDialog
With olDialog
.Caption = sCap
.ForceResolution = True
.AllowMultipleSelection = False
.NumberOfRecipientSelectors = olShowTo
.ToLabel = "Select User"
If .Display = False Then GoTo BadResult
SetForegroundWindow (Excel.Application.hwnd)
If .Recipients.Count <> 1 Then GoTo BadResult
'Debug.Print .Recipients(1).Name
'Debug.Print .Recipients(1).Address
'Debug.Print .Recipients(1).AddressEntry.GetExchangeUser.Alias
GetUsernameFromOutlook = .Recipients.Item(1).AddressEntry.GetExchangeUser.Alias
End With
' hwnd = FindWindow(vbNullString, sCap & ": Global Address List")
Set olApp = Nothing
Set olDialog = Nothing
Exit Function
BadResult:
SetForegroundWindow (Excel.Application.hwnd)
GetUsernameFromOutlook = Environ("UserName")
End Function
As you can see i attempted to use the SetForegroundWindow and FindWindow API calls as suggested in other answers. But the code doesn't even reach these lines before causing the problem.
The line If .Display = False brings up the SelectNamesDialog box from Outlook, but because my UserForm is modal (i think), it stays as the visible window. i am forced to use Alt-Tab to switch to Outlook. Then, after either selecting a name or cancelling out of the Outlook dialog box, i need to Alt-Tab again to get back to Excel.
Also, because the code is waiting for a response from the Outlook box, there is no further code execution, so SetForegroundWindow doesn't even happen until i complete all of the Alt-Tab switching.
Other solutions posted have referred to using calls to MSWord, or looking up information from or saving to a spreadsheet. i'm trying to use this call to modify the caption or text of a form control, such as a command button or text box or text label. i only need to collect the Outlook alias, since i have another function which can collect other selected information from Outlook based on the alias, so the alias is saved in a tag (unseen) on the form and converted to full name, initials or e-mail address as needed using this other function.
So far everything works great and i'd really like to release this interface to my beta-testers, but i don't want to have to explain to everyone to use Alt-Tab after they click the "select name" button. They will believe their computer has locked up and do a hard re-start. (Or call IT who will start asking questions that they cannot answer.)
i'm sorry that this question is so long, but i wanted to include as much information as possible. i'm sure there will be things i need to clarify, so please send me your questions in a response and i will do my best to explain better. Thank you for your time.
I just spent an evening on this, so even if this thread is one year old it should help.
You should just try using:
"olApp.ActiveWindow.Activate"
It sums up to this fully working function:
enter Public Function GetUsernameFromOutlook(sCap As String) As String
'fancy code to call Outlook dialog box to select names.
'Badresult is the default, gives username of operator if they try to:
' select more than one recipient
' cancel out of the dialog box
Dim olApp As Outlook.Application ' Outlook.Application
Dim olDialog As Outlook.SelectNamesDialog
Dim hwnd As Long
Set olApp = New Outlook.Application
Set olDialog = olApp.Session.GetSelectNamesDialog
'Set olDialog = new Outlook.Application
With olDialog
.Caption = sCap
'.ForceResolution = True
.AllowMultipleSelection = False
.NumberOfRecipientSelectors = olShowTo
.ToLabel = "Select User"
olApp.ActiveWindow.Activate
.display
If .Recipients.Count <> 1 Then GoTo BadResult
'Debug.Print .Recipients(1).Name
'Debug.Print .Recipients(1).Address
'Debug.Print .Recipients(1).AddressEntry.GetExchangeUser.Alias
GetUsernameFromOutlook = .Recipients.Item(1).AddressEntry
End With
Set olApp = Nothing
Set olDialog = Nothing
Exit Function
BadResult:
GetUsernameFromOutlook = "A voir ultérieurement"
End Function here
Outlook Object Model does not let you specify the parent window of the address book dialog - it will always be Outlook.
On the Extended MAPI level (C++ or Delphi), you can specify the window handle when calling IAddbook::Address, but you cannot do that from VBA.
If using Redemption (I am its author) is an option, you can set the RDOSession.ParentWindow property before using the RDOSelectNames object.
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
Session.ParentWindow = Excel.Application.hwnd
set ABDialog = Session.GetSelectNamesDialog
ABDialog.Display true
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.
Possible Duplicate:
Send e-mail through VBA
Send email from Excel in Exchange environment
I have this so far
Dim objOutl
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
objMailItem.Display
strEmailAddr = "me.me#you.com"
objMailItem.Recipients.Add strEmailAddr
objMailItem.Body = "Hi"
objMailItem.Attachments.Add "access.xml"
Set objMailItem = nothing
Set objOutl = nothing
It works! But only on computers that have Outlook. How can I get this to work with computers that have Windows Live?
Windows Live Mail (WLM) doesn't support automation via VBA, so it isn't as straightforward as with Outlook.
For other options, try typing [vba] e-mail in the search field. You'll get quite a few hits; here is a relevant sample: Hit, hit, hit. Some of these give you working code for sending mail using CDO. This is what I would do if I were you.
If you must use WLM, then have a look at this mail add-ins for Excel which does support WLM.
Otherwise you're stuck using VBA's SendMail method, which is very limited:
Can only send an Excel object such as a sheet, workbook, chart, range, etc.
Can't write text in the body of the e-mail
Can't use the CC or BCC fields
Can't attach files (other than the Excel object calling the method)
Example code:
Dim wb As Workbook
Set wb = ActiveWorkbook
wb.SendMail "me.me#you.com", _
"Insert subject here"
For more examples look here: http://www.rondebruin.nl/sendmail.htm
the following suppose to work on access (vba) (code is not mine):
Public Function send_email()
Set cdomsg = CreateObject("CDO.message")
With cdomsg.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mygmail#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "mypassword"
.Update
End With
' build email parts With cdomsg
.To = "somebody#somedomain.com"
.From = "mygmail#gmail.com"
.Subject = "the email subject"
.TextBody = "the full message body goes here. you may want to create a variable to hold the text"
.Send
End With
Set cdomsg = Nothing
End Function
note if you want to use other email service you should alter the code a bit.
some other options here - msdn reference
Hope it helps.