Outlook VBA Macro not modifying email - vba

I am running the following script on the event that I receive an email from a specific address with a specific subject. The goal is to tag an email with a hyperlink that will be useful for the recipient of said email to have in the original message's body.
Option Explicit
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
'On Error Resume Next
Set objOL = Application
strID = MyMail.EntryID
Set MyMail = Application.Session.GetItemFromID(strID)
If Not MyMail Is Nothing Then
Set objNS = objOL.Session
MyMail.BodyFormat = olFormatHTML
If MyMail.BodyFormat = olFormatHTML Then
MsgBox ("set to html")
End If
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
MsgBox ("Hyperlink appended!")
Else
MsgBox ("Failure!")
End If
End Sub
While I get the message box telling me that the proper event occurred it appears that no actual changes are made (or are not being saved properly?).
This is the first work I have done with any kind of programming. I've gone through some tutorials for VB specifically, but I am very new to this. Any help/guidance is much appreciated!

This is a classic case of needing to use Option Explicit to require explicit variable declarations. Use this, since you are learning VBA. Also avoid the habit of using On Error Resume Next as this ignores all error handling.
You might not realize this but you are referring to your mail item in the following ways:
MyMail
objItem
objMsg
objMail
Note that the following two commands
objMsg.HTMLBody
objMail.Save
are performed on non-existent objects.
Remove the above three extra references:
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objItem As Object
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
end Sub
You also don't need the cleanup either.

Related

VB.net - Read .msg file from the shared folder and extract the attachments inside it

I'm completely new to VB and I'm trying to extract the attachment which is saved available inside the .msg file using the below code.
Could someone help me if this is the right approach to do this ?
I'm facing below compiler errors. Could someone help me how to resolve this issue ?
Outlook.Attachment is not defined.
End Sub' must be preceded by a matching 'Sub'
Reference to a non-shared member requires an object reference.
Statement cannot appear within a method body. End of method assumed
Method arguments must be enclosed in parentheses.
Type 'Outlook.MailItem' is not defined.
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
Dim strFile As String
strFilePath = "C:\Users\...\Desktop\Test\"
strAttPath = "C:\Users\...\extracted attachment\"
strFile = Dir(strFilePath & "<Doc Name>.msg")
Do While Len(strFile) > 0
msg = Application.CreateItemFromTemplate(strFilePath & strFile)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
att.SaveAsFile strAttPath & att.FileName
Next
End If
strFile = Dir
Loop
End Sub
First of all, check out the file path where you try to find the template:
msg = Application.CreateItemFromTemplate(strFilePath & strFile)
The strFilePath string may include the file name already:
strFile = Dir(strFilePath & "<Doc Name>.msg")
Second, make sure attachments are saved using unique file names:
att.SaveAsFile strAttPath & att.FileName
The FileName string can be the same in different emails. I'd recommend adding IDs or the current time and etc. to the file name to uniquely name attached files on the disk.
Here is the code we use to grab a daily report attachment. I left a few commented statements in case you might need them (we didn't).
Sub Extract_Outlook_Email_Attachments()
On Error GoTo ErrHandler
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim olNS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Dim saveFolder As String
saveFolder = strAttPath ' SAVE THE ATTACHMENT TO
'this bit is added to get a shared email
Set objOwner = OutlookNamespace.CreateRecipient("SHARED FOLDER NAME")
objOwner.Resolve
If objOwner.Resolved Then
Debug.Print "Outlook GB Fulfillment is good."
Set folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) 'can use olFolderInbox or olFolderSentMail
End If
'Write mail to spreadsheet - create named range, from and to dates on the spreadsheet
i = 1
For Each OutlookMail In folder.Items
' Debug.Print "SenderEmailAddress: " & OutlookMail.SenderEmailAddress
'If OutlookMail.SenderEmailAddress = "no-reply#OurCompany.com" Then
If OutlookMail.subject = "Daily Report" Then
' If OutlookMail.SenderName = "no-reply#OurCompany.com" And OutlookMail.Subject = "Daily New Subscriber Plan Election Fulfillment" And OutlookMail.Attachments(1) = "NewSubscriberPlanElectionFulfillment_Subscription.xls" Then
Debug.Print "Received: " & OutlookMail.ReceivedTime
Debug.Print "Attach: " & OutlookMail.Attachments(1)
dateformat = Format(OutlookMail.ReceivedTime, "m-d-yy")
Debug.Print dateformat
FName = dateformat & " " & OutlookMail.Attachments(1).fileName
Debug.Print "FName: " & FName
Dim strFileExists As String
strFileExists = Dir(saveFolder & FName)
If strFileExists = "" Then
' MsgBox "The selected file doesn't exist"
Else
' MsgBox "The selected file exists"
Exit Sub
End If
OutlookMail.Attachments(1).SaveAsFile saveFolder & FName
Set outAttachment = Nothing
End If
Next OutlookMail
Set folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
ErrHandler:
Debug.Print Err.Description
End Sub
Instead of using CreateItemFromTemplate, you can use Namespace.OpenSharedItem to open an MSG file.
You also need to add Outlook to your VB.Net project references.

Run time error 91, code was working before now it isn't?

My code is supposed to check my inbox for unopened emails that contain csv files. When it encounters one it is supposed to download it with a new name and mark the email as read in a new folder.
Everything was working yesterday and now I am getting a run-time error 91.
Option Explicit
Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim avDate() As String
Dim vDate As String
Dim Address As String
Dim i As Long
Dim j As Long
Dim csvCount As Long
Dim myDestFolder As Outlook.MAPIFolder
Const myPath As String = "C:\Saved CSV\"
ReDim Preserve avDate(3)
Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
i = 0
j = 0
Set myDestFolder = myFolder.Parent.Folders("CSV Emails")
For i = myFolder.Items.Count To 1 Step -1
If TypeName(myFolder.Items(i)) = "MailItem" Then
Set myItem = myFolder.Items(i)
End If
csvCount = 0
If myItem.UnRead = True Then 'Run time error Here'
avDate = Split(CStr(myItem.ReceivedTime), "/")
vDate = Mid(avDate(2), 1, 4) & "-" & avDate(1) & "-" & avDate(0)
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
If LCase(Right(myAttachment.FileName, 3)) = "csv" Then
j = j + 1
csvCount = csvCount + 1
Dim recipientsItem As Object
Dim OldMessage As Outlook.MailItem
Set OldMessage = ActiveExplorer.Selection.Item(1)
For Each recipientsItem In OldMessage.Recipients
If OldMessage.SenderEmailType = "EX" Then
Address = OldMessage.Sender.GetExchangeUser.PrimarySmtpAddress
End If
If OldMessage.SenderEmailType = "SMTP" Then
Address = mymessage.SenderEmailAddress
End If
Next recipientsItem
myAttachment.SaveAsFile ((myPath) & "," & Address & "," & vDate & " - " & j & " - " & myAttachment.FileName)
End If
Next myAttachment
If csvCount > 0 Then
myItem.UnRead = False
myItem.Move myDestFolder
End If
End If
End If
Next i
SaveAttachments_exit:
Set myAttachment = Nothing
Set myItem = Nothing
Set myNameSpace = Nothing
Set OldMessage = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub
I am getting an error on
If myItem.UnRead = True Then
Didn't have the error yesterday. Any help would be appreciated.
I am assuming that it is because the set statement for myItem is within the for loop and it isn't being set properly.
For anyone wondering why I am putting commas in the file name it is so I can extract the senders email address with a -split statement in powershell.
My suspect is that this line Set myItem = myFolder.Items(i) is never executed, and this will cause your If instruction to fail accessing the object property.
This can be caused by several reason:
Outlook doesn't return any mail (Items.Count = 0)
Your If condition is never satisfied (TypeName(myFolder.Items(i)) is never "MailItem")
Your default mailbox is changed, and doesn't contain any MailBox Item.
Technical problems (i.e Can't instantiate an instance of Outlook, Different version of Office, etc.)
Finding the error
To test which of this problem can be, I suggest you to run the code in debug mode and executing each instruction step-by-step (you can do it by pressing F8).
While still executing the code, check the value of your variables (using your Local Variable Window).
This can help you better understanding what's going on with your code, and can be a great help in finding where is the issue.
Check if the object is Not Null
In any case, it's a good practice to check if the object is initialized, before trying accessing it.
To do that, you can add this instruction:
If Not myItem Is Nothing then
If myItem.UnRead = True Then
'rest of your code...
Hope this helps.

How to search through results of instant search Outlook

I have the following code that does an instant search in Outlook, but I am unsure of how now to loop through these results to do further checks.
Any pointers would be gratefully received!
Sub SearchByAddress()
Dim myOlApp As New Outlook.Application
Dim ns As Outlook.NameSpace
Dim strFilter As String
Dim oMail As Outlook.MailItem
Set ns = myOlApp.GetNamespace("MAPI")
strFilter = "joebloggs#hotmail.com"
Set myOlApp.ActiveExplorer.CurrentFolder = ns.GetDefaultFolder(olFolderInbox)
txtSearch = "from:(" & Chr(34) & strFilter & Chr(34) & ") AND " & Chr(34) & "Check" & Chr(34)
myOlApp.ActiveExplorer.Search txtSearch, olSearchScopeAllFolders
Set myOlApp = Nothing
End Sub
Use Application.AdvancedSearch instead - it returns an instance of the Search object.

How to Search Items with Attachment and keyword in Subject using Filter

I am working on a code which attachment will be download to folder location in context to subject by using a subject filter.
After a long search on the internet, my code is working but the problem here is that I want to put the keyword in the subject filter so that it will download the attachment as the subject keep changing every day
e.g. Sub: training_24357 on one day and training_24359 on the next day.
Also, I want to run my code after every 5 minutes automatically, any help will be much appreciated,
below is my code.
Sub Attachment()
Dim OutOpened As Boolean
Dim App As Outlook.Application
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim Attach As Outlook.Attachment
Dim Item As Object
Dim MailItem As Outlook.MailItem
Dim subject As String
Dim saveFolder As String
Dim dateFormat As String
saveFolder = "D:\Outlook\POS Visit Report"
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
subject = """*POS Visit*"""
OutOpened = False
On Error Resume Next
Set App = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set App = New Outlook.Application
OutOpened = True
End If
On Error GoTo 0
If App Is Nothing Then
MsgBox "Cannot Start Outlook Mail", vbExclamation
Exit Sub
End If
Set Ns = App.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
If Not olFolder Is Nothing Then
For Each Item In olFolder.Items
If Item.Class = Outlook.ObjectClass.olMail Then
Set MailItem = Item
If MailItem.subject = subject Then
Debug.Print MailItem.subject
For Each Attach In MailItem.Attachments
dateFormat = Format(Now(), "yyyy-mm-dd H-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
Next
End If
End If
Next
End If
If OutOpened Then App.Quit
Set App = Nothing
End Sub
To Search for Items with Attachment and by Subject line you can use Items.Restrict Method to filter Items collection containing all the match from the filter
Filter Example: [Attachment & Subject Like '%training%']
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%training%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
VBA Example https://stackoverflow.com/a/42547062/4539709 Or https://stackoverflow.com/a/42777485/4539709
Now if your running the code from Outlook then you do not need to GetObject, or Set App = New Outlook.Application Just simply Set Ns = Application.GetNamespace("MAPI")
To run your code when Items are added to you Inbox - Try working with Application.Startup Event (Outlook) And Items_ItemAdd Event (Outlook)
Items.ItemAdd Event Occurs when one or more Items are added to the specified collection. This event does not run when a large number of items are added to the folder at once.
Code Example:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
'// call sub here
End If
End Sub

Opening and saving attachments

I have some code that searches the rfin#example.com inbox for messages with a certain subject and then debug prints the subject to the console, I'd like to add code that saves the attachments of those emails flagged by the search. The MSDN documentation was vague on this issue.
The area I'm looking for help with is commented out with '### about 12 lines from the bottom
Sub Search_Inbox()
'This subroutine searchest the RFin Inbox for the prior month's Acting / Additional forms
'Then it saves the .xlsx attachments
Dim objNamespace As Outlook.NameSpace
Dim olShareName As Outlook.Recipient
Dim myDestFolder As Outlook.Folder
Dim objFolder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim mon As String
mon = Format(Date - 30, "mmmm")
Set objNamespace = Application.GetNamespace("MAPI")
Set olShareName = objNamespace.CreateRecipient("rfin#example.com") 'contains secondary address
Set objFolder = objNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
Set DestFolder = objNamespace.GetSharedDefaultFolder(olShareName, olFolderToDo)
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & mon & " Acting / Additional Bonus %'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
' this loop displays the list of emails by subject in the debug console and saves the attachments to the specified folder
dim z as integer
z=0
For Each itm In filteredItems
z=z+1
Debug.Print itm.Subject
'### Insert code here to Open the attachments with .xlsx extensions, if any, in each of the emails found, save them as "[Mon] Acting / Additional Bonus (1 to n).xlsx"
Next
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
End Sub
Try something like the following:
for each attach in itm.Attachments
if (attach.Type = olByValue) or (attach.Type = olEmbeddeditem) Then
attach.SaveAsFile "c:\temp\" & itm.FileName
End If
next