I want to loop through a list of email addresses and check if they have OOF's turned on (these will be other people's email addresses). Then if possible retrieve the OOF text.
I tried the options of getting the OOF through VBA but with my own trial and error and googling I can see that most people (and myself) realize it's only possible to get your own OOF information.
Sub Check_OOF()
Dim oNS As Outlook.NameSpace
Dim oStores As Outlook.Stores
Dim oStr As Outlook.Store
Dim oPrp As Outlook.PropertyAccessor
Set oNS = Outlook.GetNamespace("MAPI")
Set oStores = oNS.Stores
For Each oStr In oStores
If oStr.ExchangeStoreType = olPrimaryExchangeMailbox Then
Set oPrp = oStr.PropertyAccessor
MsgBox oPrp.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x661D000B")
End If
Next
End Sub
Is this possible with Outlook-Redemption? I can only see the syntax to interact with your own automatic reply.
You will need to use EWS - GetMailTips operation.
Also you can use Redemption, see RDOMailTips object for more information.
Thanks for pointing me in the right direction Eugene, also Dmitry thanks again for redemption.
I installed redemption by downloading here and installing it via the command line (thanks for the clear instructions). I'm using the RDOMailTips object which allowed me to loop through mailbox's and retrieve OOF messages and other helpful information.
Below is an example I quickly wrote to show the basic premise of looping through emails and getting OOF's text and start/end date.
Sub Get_OOF()
Dim session As Redemption.RDOSession
Dim arr As Variant
Set session = CreateObject("Redemption.RDOSession")
session.Logon
session.SkipAutodiscoverLookupInAD = True
arr = Array("user1#email.com", "user2#email.com", "user3#email.com")
For i = LBound(arr) To UBound(arr)
Set AdrEntry = session.AddressBook.ResolveName(arr(i))
Set mailtips = AdrEntry.GetMailTips
Debug.Print mailtips.OutOfOfficeMessage
Debug.Print mailtips.OutOfOfficeEndTime
Debug.Print mailtips.OutOfOfficeStartTime
Next i
Set session = Nothing
Set AdrEntry = Nothing
Set mailtips = Nothing
End Sub
Four things to note
If the person doesn't have an out of office it will return an empty string
If the person hasn't set out of office dates it will return 01/01/4501 which I assume is an error code formatted as a date
You will need to split the string from mailtips.OutOfOfficeMessage as it has a lot of formatting fluff around the out of office text
I didn't need to put my credentials in the parameters of AdrEntry.GetMailTips for this to work. But as the documentation says this is optional for EWS.
Related
I get emails from my old team/role about tech bridges during outages that I no longer attend. I would like to auto-decline them IF they are sent to a specific distribution list (that I'm still part of).
I don't know VBA at all but would this work (I modified another script I found and replaced SenderEmailAddress with Recipients). Don't want to run this until someone who actually knows that they are looking at confirms or denies that this will work (on the off chance it does something wild with me emails).
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim xEntryIDs
Dim xItem
Dim i As Integer
Dim xMeeting As MeetingItem, xMeetingDeclined As MeetingItem
Dim xAppointmentItem As AppointmentItem
On Error Resume Next
xEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(xEntryIDs)
Set xItem = Application.Session.GetItemFromID(xEntryIDs(i))
If xItem.Class = olMeetingRequest Then
Set xMeeting = xItem
xMeeting.ReminderSet = False
If VBA.LCase(xMeeting.Recipients) = VBA.LCase("support.bridge#company.com") Then
Set xAppointmentItem = xMeeting.GetAssociatedAppointment(True)
xAppointmentItem.ReminderSet = False
Set xMeetingDeclined = xAppointmentItem.Respond(olMeetingDeclined)
xMeetingDeclined.Body = "Declined"
xMeetingDeclined.Send
xMeeting.Delete
End If
End If
Next
End Sub
You can't compare the Recipients collection with a string in the following way:
If VBA.LCase(xMeeting.Recipients) = VBA.LCase("support.bridge#company.com") Then
The MeetingItem.Recipients property returns a Recipients collection that represents all the recipients for the Outlook item. Use Recipients(index), where index is the name or index number, to return a single Recipient object. The name can be a string representing the display name, the alias, or the full SMTP email address of the recipient.
The Recipient.DisplayType property returns a constant belonging to the OlDisplayType enumeration that describes the nature of the Recipient. It seems you are interested in the olDistList or olPrivateDistList values.
Also I've noticed the following line of code:
xEntryIDs = Split(EntryIDCollection, ",")
The NewMailEx behavior has been changed more than 10 years ago and now it is fired for each Outlook item separately. So, there is no need to split the string in the event handler, the parameter contains only a single entry ID value.
im using Outlook 2013 and need help activating Out Of Office with VBA. I have trouble setting a starting and endtime as well as formatting my message. I seem not to be able to use html tags...
Is there also a way of getting my current signature?
The code so far:
Sub absence(toggle As Boolean)
Const PR_OOF_STATE = "http://schemas.microsoft.com/mapi/proptag/0x661D000B"
Dim oStore As Outlook.Store, oProp As Outlook.PropertyAccessor
Dim oStorageItem As Outlook.StorageItem
Set oStorageItem = Application.Session.GetDefaultFolder(olFolderInbox).GetStorage("IPM.Note.Rules.OofTemplate.Microsoft", olIdentifyByMessageClass)
oStorageItem.Body = "<html><body><b>I am curerntly not available...</b></body></html>"
oStorageItem.Save
For Each oStore In Session.Stores
If oStore.ExchangeStoreType = olPrimaryExchangeMailbox Then
Set oProp = oStore.PropertyAccessor
oProp.SetProperty PR_OOF_STATE, toggle 'If true: start OOF, if false: quit OOF
End If
Next
Set olkIS = Nothing
Set olkPA = Nothing
End Sub
Anyone got an idea? Any help appreciated.
HTML OOF replies and time ranges can only be set using EWS - see SetUserOofSettings operation on MSDN (https://learn.microsoft.com/en-us/exchange/client-developer/web-service-reference/setuseroofsettings-operation)
Good Afternoon All,
About twice a year at my company I have to generate user reports for certain managers. I have no problem generating these reports and sending them to the proper user but this always requires operator action on my teams end. I wanted to see if there was an easier way to do this. My idea was to generate and email these mass reports using a single button. Could I do this through VBA or Macros? Or should I not have to go that route because there is a simpler way?
Thanks guys for any help.
yes, you can. Since you are asking only for direction, and this is not a freelancer group so that you can expect people write the whole code for you, I only give you a part that I already had on one of my files and explain how you should do the rest.
I am not sure the report you have will be presented in Excel, word or any other file, but the main idea would be to write a vba code that runs your queries and collects data and formats it in a way you want. That would be your challenge to figure out the details and you will not get the answer to all of your questions in one single posting.
For the part that you want to email, here is the code that I can help you with:
Sub Email_Recepients(sEMailSubj As String, sPath As String, sBody As String)
Dim olApp As Object
Dim olMail As Object
If bolHandleErrors Then On Error GoTo Handler
Set olApp = CreateObject("Outlook.Application")
' olApp.Visible=True
Set olMail = olApp.CreateItem(0)
With olMail
.To = Mat_EmailAddress
.Subject = sEMailSubj
' .Attachments.Add sPath
' .DeleteAfterSubmit = True
' .HTMLBody = sBody
' .Send
End With
Set olMail = Nothing
Set olApp = Nothing
Application.Wait Now + TimeValue("00:00:04")
Exit Sub
Handler:
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Oops! Something went worng. I could not get Outlook to send your message. Please try again later.",vbInformation, "Email HHI Governance Function"
End Sub
some of the lines have been commented out, but you can uncomment them and use them if you wanted to. Make sure you define variables that they use at the beginning of the code.
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.
When using the Move method on an AppointmentItem in an Outlook macro, I lose the ability to receive updates because it is creating a copy of the item instead of truly moving it. This behavior causes the item to no longer be linked with the original and will not retain item updates as a result.
I want to replicate through VBA the cut/paste behavior you get which is able to maintain the original object and does not cause updates to be lost.
I believe this has something to do with the GlobalAppointmentID based on searching around, however I have not been able to find a way to actually move the appointment.
The code I'm using is below. GetFolderFromPath is a helper function to just return a folder object from the path, which works perfectly well.
Sub MoveItem()
Dim targetPath As String: targetPath = "\\tnolan#microsoft.com\Calendar\OOFS"
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No item selected")
Exit Sub
Else
Dim targetFolder As Outlook.Folder
Set targetFolder = GetFolderFromPath(targetPath)
For x = 1 To Application.ActiveExplorer.Selection.Count
Dim oSelected As Variant
Set oSelected = Application.ActiveExplorer.Selection.Item(x)
If oSelected.Class = olAppointment Then
Dim NS As NameSpace: Set NS = Application.GetNamespace("MAPI")
Dim oAppt As AppointmentItem: Set oAppt = NS.GetItemFromID(oSelected.EntryID)
oAppt.Move targetFolder
Set oAppt = Nothing
Set NS = Nothing
End If
Set oSelected = Nothing
Next x
Set targetFolder = Nothing
End If
End Sub
Outlook processes incoming meeting updates/deletions only against the default Calendar folder. If you move an appointment to a different folder, meeting update in your Inbox will create a new appointment in the default Calendar folder.
After playing around with my code for a little bit, I've found that this code works for me in a similar situation:
oAppt.CopyTo(targetFolder, olCopyAsAccept)
oAppt.Delete
I have a feeling that for some reason the AppointmentItem.Move command passes as olCreateAppointment which would always create a new GlobalAppointmentID.
However, this still has a side-effect of responding accept to the Appointment.