I have a function that find a specific mail with subject, i also want to add some methods to find out if the mail has a valid digital signature.
Set objOutlook = CreateObject("Outlook.Application")
Set myNameSpace = objOutlook.GetNameSpace("MAPI")
Set ClientFolder = myNameSpace.GetDefaultFolder(6) 'Inbox = 6
Set myItems = ClientFolder.Items
Set myItem = myItems.GetFirst
Set colSyc = myNameSpace.SyncObjects
Set syc = colSyc.AppFolders
ClientFolder.InAppFolderSyncObject = True
syc.Start 'Sync inbox at most updated state
For intMailCount = 0 to ClientFolder.Items.Count - 1 ' Check subject line for a match
If Instr(myItem.Subject, Subject) = 1 AND myItem.Unread = True then
VerifyEmailSubject = "True"
'validation under here does not work properly and allways returns true and need to find something here for validation
If myItem.MessageClass <> "IPM.Note.SMIME" Or myItem.MessageClass <> "IPM.Note.Secure" Or myItem.MessageClass <> "IPM.Note.Secure.Sign" then
msgbox "signed"
End If
myItem.Unread = false 'Set mail status to read to avoid further test assertion errors.
Exit For
End If
Set myItem = myItems.GetNext
Next
Solved
If myItem.MessageClass = "IPM.Note.SMIME.MultipartSigned" Then
VerifyEmailSignature = "True"
End If
Related
I have a script found on https://www.crestwood.com/2018/08/17/automating-outlook-calendar-to-send-daily-agenda/. This works but I can not control the details of the calendar. Or more correctly I can't figure out how to send Meeting subject and Location.
Is there a way with this code? Or could I go about it in some other way?
When doing it manually in Outlook it is called "Limited details" - this is my desired outcome.
I can change the constant: olFreeBusyAndSubject between 0, 1, 2. But none of these return my desired outcome. They result in (only seeing busy/free, Only seeing subject, Full details including description of event). I do not want full details since their might be sensitive information which I do not want on my secondary e-mail.
' -------------------------------------------------
' Modify this \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Const myEmailAddress = "some#email.com"
Const includePrivateDetails = TRUE
Const howManyDaysToDisplay = 1
' Modify this /////////////////////////////////////
' -------------------------------------------------
Const olCalendarMailFormatDailySchedule = 0
Const olFreeBusyAndSubject = 2
' Const olFullDetails = 1
Const olFolderCalendar = 9
SendCalendar myEmailAddress, Date, (Date + (howManyDaysToDisplay - 1))
Sub SendCalendar(strAdr, datBeg, datEnd)
Dim olkApp, olkSes, olkCal, olkExp, olkMsg
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = OlkApp.GetNameSpace("MAPI")
olkSes.Logon olkApp.DefaultProfileName
Set olkCal = olkSes.GetDefaultFolder(olFolderCalendar)
Set olkExp = olkCal.GetCalendarExporter
With olkExp
.CalendarDetail = olFreeBusyAndSubject
.IncludePrivateDetails = includePrivateDetails
.RestrictToWorkingHours = False
.StartDate = datBeg
.EndDate = datEnd
End With
Set olkMsg = olkExp.ForwardAsICal(olCalendarMailFormatDailySchedule)
With olkMsg
.To = strAdr
.Send
End With
Set olkCal = Nothing
Set olkExp = Nothing
Set olkMsg = Nothing
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing
End Sub
As described desired outcome is to thorugh a VBA-script (or other automated way) send "Limited details"-Outlook-calendar by e-mail.
Thank you in advance!
In .CalendarDetail = olFreeBusyAndSubject replace olFreeBusyAndSubject by olFullDetails.
To discover this I used Bing and searched for "Outlook CalendarDetail". I find this an easy method for discovering the permitted values for a property.
I get the exchange online addresses from users, but I want to convert or somehow get the SMTP Address of them.
I am not sure how to get the SMTP Address from Email1Address.
Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
Set objItems = objContactsFolder.Items
For Each obj In objItems
'Test for contact and not distribution list
If obj.Class = olContact Then
Set objContact = obj
With objContact
If .Email1Address <>"" Then
'I want to add the SMTP-Address after the .LastNameAndFirstName of a User
strFileAs = .LastNameAndFirstName
.Email1DisplayName= strFileAs
.Save
End If
End With
End If
Err.Clear
Next
I used this for the email object, see if you can implement it:
dim email as string
If myItem.SenderEmailType = "EX" Then
email = myItem.Sender.GetExchangeUser.PrimarySmtpAddress
Else
email = myItem.SenderEmailAdress
End If
So I have multiple mailboxes under my Outlook account and I am trying to get them to generate reply template based on the mailbox I am replying from (one is private, one is shared). I have tried to base the condition on SenderName and SenderEmailAddress, but to no avail (reply email gets generated with the contents of the previous email retrieved but the text I intend to put in front of it is not there; the cause is that the value of oReply.SenderEmailAddress is empty as Else clause will write the stuff as intended).
(and yes, there are snippets from code enabling reply with attachments)
Sub ReplyWithAttachments()
Dim oReply As Outlook.MailItem
Dim oItem As Object
Dim sSignature As String
Set oItem = GetCurrentItem()
If Not oItem Is Nothing Then
Set oReply = oItem.Reply
If oReply.SenderEmailAddress = "mailbox.private#something.com" Then
sSignature = "Hello and welcome!"
ElseIf oReply.SenderEmailAddress = "mailbox.shared#something.com" Then
sSignature = "Go to hell!"
End If
CopyAttachments oItem, oReply
oReply.HTMLBody = sSignature & oReply.HTMLBody
oReply.Display
oItem.UnRead = False
End If
Set oReply = Nothing
Set oItem = Nothing
End Sub
Edit:
so I managed to get somewhere with
Set oReply = oItem.Reply
sMailBox = oReply.Sender.GetExchangeUser.Address
If sMailBox = "mailbox.private#something.com" Then
sSignature = "whatever"
ElseIf sMailBox = "mailbox.shared#something.com" Then
sSignature = "bla bla bla"
Else
sSignature = "Something"
The code works as intended for the shared mailbox but for the private one, it errors out with Object variable or With block variable not set pointing to .Sender
sMailBox = oReply.Sender.GetExchangeUser.Address
I have something that I use to get sender email (as its dependent on your email exchange)
Dim strSendersEmailAddress As String
If oItem.SenderEmailType = "EX" Then
strSendersEmailAddress = oItem.Sender.GetExchangeUser.PrimarySmtpAddress
Else
strSendersEmailAddress = oItem.SenderEmailAddress
End If
You will have to get the email address before you Set oReply = oItem.Reply
My VBA experience is incredibly limited.I have created basic macros for excel primarily by frankensteining multiple macros I find online together.
Here's what I am looking to do. Every morning I send out an email to a list of 200 customers, I open the new message from a list and the message auto populates (as it is a signature). Currently I then go through all these emails and add my subject and BCC. Could I possibly create a macro to open all of these emails, add my BCC, add my subject, and then send the emails.
Any and all help is much appreciated.
The following code defines an instance of Outlook.Application, and sets up a MailItem ready for sending. It uses a Dictionary object called EmailData to hold the various bits of info to populate To, BCC etc but those can be replaced with your own strings etc. I've pulled this from a function I wrote and made it a little more generic:
Public Function OL_SendMail()
Dim bOpenedOutlook, sComputer, iLoop, iAccount, sAttachArray, sAttachment
bOpenedOutlook = False
sComputer = "."
Dim oWMIService : Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
Dim colItems : Set colItems = oWMIService.ExecQuery ("Select * from Win32_Process Where Name = 'outlook.exe'")
Dim oOutlook : Set oOutlook = CreateObject("Outlook.Application")
Dim oNamespace : Set oNamespace = oOutlook.GetNamespace("MAPI")
If colItems.Count = 0 Then
' Outlook isn't open, logging onto it...
oNamespace.Logon "Outlook",,False,True
bOpenedOutlook = True
End If
Dim oFolder : Set oFolder = oNamespace.GetDefaultFolder(olFolderInbox)
If EmailData("SendFrom") = "" Then
' default to first email account the user has access to
iAccount = 1
Else
' Checking to see if the account to send from is accessible by this user...
iAccount = 0
For iLoop = 1 To oOutlook.Session.Accounts.Count
If UCase(Trim(oOutlook.Session.Accounts.Item(iLoop))) = UCase(Trim(EmailData("SendFrom"))) Then
iAccount = iLoop
Exit For
End If
Next
If iAccount = 0 Then
sErrorMsg = "Cannot send email from specified account: " & EmailData("SendFrom") & " as this user doesn't appear to have access to it in Outlook!"
OL_SendMail = False
Exit Function
End If
End If
Dim oMailItem : Set oMailItem = oOutlook.CreateItem(olMailItem)
With oMailItem
Set .SendUsingAccount = oOutlook.Session.Accounts.Item(iAccount)
.To = EmailData("To")
.CC = EmailData("CC")
.BCC = EmailData("BCC")
.Subject = EmailData("Subject")
.Body = EmailData("Body")
sAttachArray = Split(EmailData("AttachmentPaths"), ";")
For Each sAttachment In sAttachArray
.Attachments.Add(sAttachment)
Next
.Recipients.ResolveAll
.Display ' debug mode - uncomment this to see email before it's sent out
End With
'Mail Item created and ready to send
'oMailItem.Send ' this is commented out so the mail doesn't auto send, allows checking of it!!
Set oMailItem = Nothing
Set oNamespace = Nothing
If bOpenedOutlook Then
'oOutlook.Quit
End If
Set oOutlook = Nothing
Set colItems = Nothing
Set oWMIService = Nothing
OL_SendMail = True
End Function
I need to add bcc recipients to an email loaded from a template. The recipients should be all of the contacts in a certain category. I have the following so far, except it is extremely inefficient and causes Outlook to become unresponsive:
Sub Distribute_Newsletter()
Set newItem = Application.CreateItemFromTemplate("P:\Subscription Templates\subscription template.oft")
newItem.Display
Set oNS = Application.GetNamespace("MAPI")
Set oContacts = oNS.Folders(1).Folders("Contacts")
Dim emailAddress As String
For Each oContactItem In oContacts.Items
If oContactItem.Class = olContact Then
emailAddress = oContactItem.Email1Address
If Not emailAddress = "" Then 'And oContactItem.Categories
Set objRecip = newItem.Recipients.Add(emailAddress)
objRecip.Type = olBCC
End If
End If
Next
Set oNS = Nothing
Set oContacts = Nothing
Set objRecip = Nothing
Set newItem = Nothing
End Sub
What I ended up doing was moving newItem.Display down to just before Set newItem = Nothing. This may not be the most efficient solution, but it gets the job done without causing a crash.