I'm using this script to export email from outlook. My question is how do I export the body of the email without the html formatting?
Sub SaveItemsToExcel()
On Error GoTo ErrorHandlerExit
Dim oNameSpace As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim objFS As Scripting.FileSystemObject
Dim objOutputFile As Scripting.TextStream
Set objFS = New Scripting.FileSystemObject
Set objOutputFile = objFS.OpenTextFile("C:\Temp\Export.csv", ForWriting, True)
Set oNameSpace = Application.GetNamespace("MAPI")
Set oFolder = oNameSpace.PickFolder
If oFolder Is Nothing Then
GoTo ErrorHandlerExit
End If
If oFolder.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain mail messages"
GoTo ErrorHandlerExit
End If
objOutputFile.WriteLine "From,Subject,Recived, Body"
ProcessFolderItems oFolder, objOutputFile
objOutputFile.Close
Set oFolder = Nothing
Set oNameSpace = Nothing
Set objOutputFile = Nothing
Set objFS = Nothing
ErrorHandlerExit:
Exit Sub
End Sub
Sub ProcessFolderItems(oParentFolder As Outlook.MAPIFolder, ByRef objOutputFile As Scripting.TextStream)
Dim oCount As Integer
Dim oMail As Outlook.MailItem
Dim oFolder As Outlook.MAPIFolder
oCount = oParentFolder.Items.Count
For Each oMail In oParentFolder.Items
If oMail.Class = olMail Then
objOutputFile.WriteLine oMail.SenderEmailAddress & "," & Replace(oMail.Subject, ",", "") & "," & oMail.ReceivedTime
End If
Next oMail
Set oMail = Nothing
If (oParentFolder.Folders.Count > 0) Then
For Each oFolder In oParentFolder.Folders
ProcessFolderItems oFolder, objOutputFile
Next
End If
End Sub
Try setting BodyFormat to olFormatPlain before reading Body property.
Related
I tried to create email routing rule with below scenario.
Incoming email will be located at Inbox/Active folder. Subject of the email will contain the ticket ID and content
Once new email coming to Active subfolder, Outlook will get the email subject and create the subfolder with format "ticket ID - content" eg: "123123 - issue with outlook"
Then a rule will be created to route this incoming email with ticket ID to the subfolder that I just created
Below is my code but it did not work. Only subfolder is created as expected. Please help me to review if any idea. Thanks
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim olapp As Outlook.Application
Dim olnamespace As Outlook.NameSpace
Set olapp = Outlook.Application
Set olnamespace = olapp.GetNamespace("MAPI")
Set inboxItems = olnamespace.GetDefaultFolder(olFolderInbox).Folders("Filter").Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim olapp As Outlook.Application
Dim olnamespace As Outlook.NameSpace
Dim olActivefolder As Folder
Dim ticketnumber As String
Dim rightsubject As String
Dim leftsubject As String
Dim extsubject As String
Dim colRules As Outlook.Rules
Dim oRule As Outlook.Rule
Dim colRuleActions As Outlook.RuleActions
Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
Dim oFromCondition As Outlook.ToOrFromRuleCondition
Dim oExceptSubject As Outlook.TextRuleCondition
Dim oInbox As Outlook.Folder
Dim oMoveTarget As Outlook.Folder
Set olapp = Outlook.Application
Set olnamespace = olapp.GetNamespace("MAPI")
Set olActivefolder = olnamespace.GetDefaultFolder(olFolderInbox).Folders("Active")
If TypeName(Item) = "MailItem" Then
Debug.Print "triggered"
ticketnumber = Item.Subject
rightsubject = Right(ticketnumber, 16)
leftsubject = Left(ticketnumber, 60)
olActivefolder.Folders.Add (rightsubject & " - " & leftsubject)
End If
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Active")
Set oMoveTarget = oInbox.Folders(rightsubject & " - " & leftsubject)
Set colRules = Application.Session.DefaultStore.GetRules()
Set oRule = colRules.Create(rightsubject, olRuleReceive)
Set oFromCondition = oRule.Conditions.Subject
With oFromCondition
.Enabled = True
.Text = rightsubject
End With
Set oMoveRuleAction = oRule.Actions.MoveToFolder
With oMoveRuleAction
.Enabled = True
.Folder = oMoveTarget
End With
colRules.Save
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
The subject condition should look like this:
'Dim oFromCondition As Outlook.ToOrFromRuleCondition
'Set oFromCondition = oRule.Conditions.subject
'With oFromCondition
' .Enabled = True
' .Text = rightSubject
'End With
Dim oSubjectCondition As TextRuleCondition
Set oSubjectCondition = oRule.Conditions.subject
With oSubjectCondition
.Enabled = True
.Text = Array(rightSubject)
End With
There is likely no need for rules.
Private Sub inboxItems_ItemAdd_Test()
inboxItems_ItemAdd ActiveInspector.CurrentItem
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
' Folder created for first mail
' No folder created for subsequent mail
Dim oInbox As folder
Dim oActivefolder As folder
Dim oMoveTarget As folder
Dim oFolder As folder
Dim ticketNumber As String
Set oInbox = Session.GetDefaultFolder(olFolderInbox)
Set oActivefolder = oInbox.Folders("Active")
If TypeName(Item) = "MailItem" Then
Debug.Print "triggered"
' For testing
ticketNumber = "123123"
For Each oFolder In oActivefolder.Folders
If oFolder.Name = ticketNumber Then
Set oMoveTarget = oActivefolder.Folders(ticketNumber)
Debug.Print " Folder exists: " & oMoveTarget.Name
Exit For
End If
Next
If oMoveTarget Is Nothing Then
Set oMoveTarget = oActivefolder.Folders.Add(ticketNumber)
Debug.Print " Folder added: " & oMoveTarget.Name
End If
Item.Move oMoveTarget
End If
Debug.Print "Done."
End Sub
I created an Outlook rule to save an attachment then move it to the Deleted Items folder. The code works when I highlight the arrived email in the Inbox then move the email to the Deleted Items folder.
When the new email arrives, it is saving the attachment(s) from different email in the inbox and not moving the email to the Deleted Items folder.
The Outlook rule is:
Apply this rule after the message arrives
from Sender
and with Gift Card in the subject
and on this computer only
run Project1.SaveAttachments
Public Sub SaveAttachments(MItem As Outlook.Mailitem)
Dim objOL As Outlook.Application
Dim objMsg As Outlook.Mailitem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "Y:\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile = objAttachments.Item(i).FileName
strFile = strFolderpath & strFile
objAttachments.Item(i).SaveAsFile strFile
Next i
Set objNamespace = objOL.GetNamespace("MAPI")
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
objMsg.Move objDestFolder
End If
Next
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set objNamespace = Nothing
Set objDestFolder = Nothing
End Sub
According to my test, you could save email attachment and delete it using the below code:
Sub SaveAutoAttach()
Dim object_attachment As Outlook.attachment
Dim saveFolder As String
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
Dim some As String, other As String
Const olFolderInbox = 6
'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")
If unRead.Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Else
some = ""
other = ""
saveFolder = "D:\"
For Each m In unRead
If m.Attachments.Count > 0 Then
For Each object_attachment In m.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".doc") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
End If
m.Delete
Next m
End Sub
For more information, please refer to this link:
Auto Download Outlook Email Attachment – Code in VBA by Topbullets.com
I have the below code that runs through a folder looking for unread messages from a specific person with a specific subject. The loop is not beginning at the most recent emails. It's beginning a month ago where all the messages are read.
Sub MovingAttachmentsIntoNetworkFolders()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Email Subfolder") 'Specify Folder here
On Error GoTo ErrorHandler
For Each Item In olFolder.Items
Debug.Print Item.ReceivedTime
If Item.UnRead = True Then
If TypeOf Item Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = Item
Debug.Print Item.SenderEmailAddress
Debug.Print Item.Subject
Debug.Print Item.Attachments.Count
If Item.Sender = "emailaddress#email.com" And _
Item.Subject = "EmailSubject" And _
Item.Attachments.Count = 1 Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "mappednetworkdrive"
' save attachment
Set myAttachments = Item.Attachments
Att = myAttachments.Item(1).FileName
Debug.Print Att & "\" & Format(Item.ReceivedTime, "mm-dd-yyyy")
myAttachments.Item(1).SaveAsFile Format(Item.ReceivedTime, "mm.dd.yyyy") & " " & Att
' mark as read
Item.UnRead = False
End If
End If
End If
Next
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Any reason why my code is behaving this way?
For a For Each loop, you can sort a collection of the items in the folder by ReceivedTime as described here Email data exported to Excel - Sort by Received Date
Note: Untested code to demonstrate how to sort
Option Explicit
Sub MovingAttachmentsIntoNetworkFolders()
Dim objNS As NameSpace
Dim olFolder As Folder
dim objItem as object
dim fldItems as items
Set objNS = GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
'Specify Folder here
Set olFolder = olFolder.Folders("Email Subfolder")
On Error GoTo ErrorHandler
' https://stackoverflow.com/questions/14948295/email-data-exported-to-excel-sort-by-received-date
set fldItems = olFolder.Items
fldItems.Sort "ReceivedTime", true
For Each objItem In fldItems
Debug.Print objItem.ReceivedTime
If objItem.UnRead = True Then
If TypeOf objItem Is MailItem Then
Debug.Print objItem.SenderEmailAddress
Debug.Print objItem.Subject
Debug.Print objItem.Attachments.Count
If objItem.Sender = "emailaddress#email.com" And _
objItem.Subject = "EmailSubject" And _
objItem.Attachments.Count = 1 Then
' mark as read
objItem.UnRead = False
End If
End If
End If
set objItem = Nothing
Next
ProgramExit:
Set objNS = Nothing
Set olFolder = Nothing
set fldItems = Nothing
set objItem = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
If code is in Outlook there is no need to reference Outlook.
Avoid using Item and olMail for variable names as they already have a purpose.
I've been struggling with this for quite some time now, I don't get what I'm doing wrong.
I've got a script that will loop through emails in a folder. Then it checks the first 6 characters of the email subject. If it matches it must call a sub that will save the attachment to a specific folder, the only thing is that the file name changes every time depending on the subject of the email. Everything works fine if there is only 1 email in the folder, but as soon as there is more than 1 email it saves the last email attachment everytime but with the correct file name. So for example if you look at the underneath code it will save the attachment from ElseIf strLeft = "APPPE2" Then everytime with the filenames specified, eg report1.txt ... Help will be greatly appreciated.
Function LoopThroughFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Inbox").Folders("PPB")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Set Msg = Item
Dim strSubject As String
strSubject = Item.Subject
Dim strLeft As String
strLeft = Left(strSubject, 6)
If strLeft = "APP DA" Then
Call SaveAttachments1
ElseIf strLeft = "APPGR1" Then
Call SaveAttachments2
ElseIf strLeft = "APPPE2" Then
Call SaveAttachments3
End If
End If
Next
End Function
Public Sub SaveAttachments1()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile1 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "P:\database\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile1 = "report.txt"
MsgBox (strFile1)
strFile1 = strFolderpath & strFile1
MsgBox (strFile1)
objAttachments.Item(i).SaveAsFile strFile1
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Sub SaveAttachments2()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile2 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "P:\database\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile2 = "report2.txt"
MsgBox (strFile2)
strFile2 = strFolderpath & strFile2
MsgBox (strFile2)
objAttachments.Item(i).SaveAsFile strFile2
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Sub SaveAttachments3()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile3 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "P:\database\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile3 = "report3.txt"
strFile3 = strFolderpath & strFile3
objAttachments.Item(i).SaveAsFile strFile3
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Each of your SaveAttachments subs should have a objMsg parameter, which should be passed from LoopThroughFolder - there is no need to "re-find" the message just to save the attachments.
Untested but something like this:
Function LoopThroughFolder()
Dim objNS As Outlook.NameSpace, Item, Msg As Outlook.MailItem
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Inbox").Folders("PPB")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Set Msg = Item
Dim strSubject As String
strSubject = Msg.Subject
Dim strLeft As String
strLeft = Left(strSubject, 6)
If strLeft = "APP DA" Then
SaveAttachments1 Msg
ElseIf strLeft = "APPGR1" Then
SaveAttachments2 Msg
ElseIf strLeft = "APPPE2" Then
SaveAttachments3 Msg
End If
End If
Next
End Function
Public Sub SaveAttachments1(objMsg As Outlook.MailItem)
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFolderpath As String
strFolderpath = "P:\database\"
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
objAttachments.Item(i).SaveAsFile strFolderpath & "report.txt"
Next i
End If
End Sub
I am trying to write a script that saves attachments to a directory. When I run it, I get an error message "type mismatch" and the line Set olAtt = olMi.Attachments is highlighted. Could someone advise?
Sub SaveAttachments()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim MoveToFldr As MAPIFolder
Dim olMi As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim MyPath As String
Dim i As Long
Dim j As Long
Dim filesavename As String
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set MoveToFldr = Fldr.Folders("Survey")
MyPath = "C:\Users\temp"
For i = (Fldr.Items.Count - 150) To Fldr.Items.Count
Set olMi = Fldr.Items(i)
If InStr(1, olMi.Subject, "Survey") > 0 Then
j = olMi.Attachments.Count
Set olAtt = olMi.Attachments
filesavename = MyPath & olAtt.Filename
olAtt.SaveAsFile filesavename
olMi.Save
olMi.Move MoveToFldr
End If
Next i
Set olAtt = Nothing
Set olMi = Nothing
Set Fldr = Nothing
Set MoveToFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
olAtt is declared as a Outlook.Attachment (singular).
olMi.Attachments is a collection of attachments.