I am trying to export all emails in specific folder "Not actioned DO" to a CSV file then move these emails to another folder "Actioned DO".
I edited code I found.
Only the last email is saved on the csv file.
I need all emails to be in the same CSV file.
Sub PseudoArchive()
Dim objNamespace As Outlook.NameSpace
Dim sourceFolder As Outlook.MAPIFolder
Dim destinationFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim msg As String
Dim i As Long
Set objNamespace = GetNamespace("MAPI")
Set sourceFolder = objNamespace.Folders("msroumi#hotmail.com").Folders("Inbox").Folders("Not Actioned DO")
Set destinationFolder = objNamespace.Folders("msroumi#hotmail.com").Folders("Inbox").Folders("Actioned DO")
Set Items = sourceFolder.Items
'Move emails in sourceFolder to destinationFolder
msg = Items.Count & " Items in " & sourceFolder.Name & ", Move?"
If MsgBox(msg, vbYesNo) = vbYes Then
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
Item.Move destinationFolder
Item.SaveAs "D:\Excel\Learning Excel VBA\Outlook VBA\MyEmail.txt", olTXT
Next
End If
End Sub
Firstly, you are sving the item after it's already been moved (and deleted). Call SaveAs before calling Move. Or use the returned value of the Move function to reset the item: set Item = Item.Move destinationFolder.
Most importantly however, is that you are saving all message with the same file name, continuously overwriting the old files, thus only the last file survives. Make the file name unique - you can ether use the message Subject property for that (make sure you remove all invalid chars, such as ":") or you can do something as simple as adding a counter to te hfile name:
Item.SaveAs "D:\Excel\Learning Excel VBA\Outlook VBA\MyEmail" & i & ".txt", olTXT
Related
I'm trying to search Outlook by email received date and time, for specific subject email and then save its attachment in designated folder.
It gets stuck where I search for email with specific subject.
Set foundEmails = searchFolder.Items.Restrict("[Subject] = 'KSA RDC - ECOM Inventory Report'")
Sub SearchAndDownloadAttachments()
' Declare variables for the Outlook application and folder
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Namespace
Dim inboxFolder As MAPIFolder
Dim searchFolder As MAPIFolder
Dim foundEmails As Search
Dim email As Outlook.MailItem
Dim attach As Outlook.Attachment
' Set the Outlook application and namespace
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
' Set the inbox folder and search folder
Set inboxFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
Set searchFolder = inboxFolder.Folders("IT Reports")
' Search for emails with the specified subject
Set foundEmails = searchFolder.Items.Restrict("[Subject] = 'KSA RDC - ECOM Inventory Report'")
' Loop through the found emails
For Each email In foundEmails
' Declare variables for the email name and received time
Dim emailName As String
Dim receivedTime As Date
Dim attachmentName As String
' Set the email name and received time
emailName = email.SenderName
receivedTime = email.receivedTime
' Loop through the attachments of the email
For Each attach In email.Attachments
attachmentName = attach.Filename
' Copy the attachment to the specified folder
attach.SaveAsFile "C:\Attachments\" & attachmentName & "-" & emailName & " - " & Format(receivedTime, "yyyy-mm-dd hh-mm-ss")
Next
Next email
End Sub
Please, test the next adapted code. Take care to change the subject string, to be exactly as the one you try returning:
Sub SearchAndDownloadAttachments()
' Declare variables for the Outlook application and folder
Dim outlookApp As Outlook.Application, outlookNamespace As NameSpace
Dim inboxFolder As MAPIFolder, searchFolder As MAPIFolder
Dim foundEmails As Items, email As Outlook.MailItem
Dim attach As Outlook.Attachment
' Set the Outlook application and namespace
Set outlookApp = New Outlook.Application
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
' Set the inbox folder and search folder
Set inboxFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
Set searchFolder = inboxFolder.Folders("IT Reports")
' Search for emails with the specified subject
Set foundEmails = searchFolder.Items.Restrict("[Subject] = 'KSA RDC - ECOM Inventory Report'") 'change here the exact spelled subject string!
' Loop through the found emails
For Each email In foundEmails
' Declare variables for the email name and received time
Dim emailName As String, receivedTime As Date, attachmentName As String
Dim ext As String, nameRoot As String 'new declarations
' Set the email name and received time
emailName = email.SenderName
receivedTime = email.receivedTime
' Loop through the attachments of the email
For Each attach In email.Attachments
attachmentName = attach.FileName
ext = Right(attachmentName, Len(attachmentName) - InStrRev(attachmentName, ".") + 1) 'extract extension
nameRoot = left(attachmentName, Len(attachmentName) - Len(ext)) 'the remained name (without extension)
' Copy the attachment to the specified folder
attach.SaveAsFile "C:\Attachments\" & nameRoot & "-" & emailName & " - " & _
Format(receivedTime, "yyyy-mm-dd hh-mm-ss") & ext
Next
Next email
End Sub
Your last error may be related to the fact that Outlook is not able to save a file without extension and Excel remains hanged on this Outlook attempt...
Please, send some feedback after testing the code.
Message Body format:
> Hi All,
>
>
> Redwood.Harel.Harley.Miscare.Find failed. Below is the detailed report
>
> ************************************************************************************** Server Name : freedyishere1234
>
>
> Service Name : SantaIsRed
>
>
> Transaction Id : 32k23k23k-234jbk23b4k-32j4k23b-23231q
>
>
> Universal Id : 8979870
>
>
> Employee Id : 123123321
>
>
> Service Status : Failed
>
>
> Error Details : The family’s excitement over going to Disneyland was
> crazier than she anticipated. EmployeeId=123123321
>
>
> **************************************************************************************
>
> This is a system generated message. Do not reply to this message.
>
> Thank you, Cranberry Team
I want to write a VBA which runs everyday(or manually as well) at specific time and date (past, present,future). My script should extract EmployeeId and Error Details from the body and save it into an excel file which has to be maintained everyday.
Column A = EmployeeId
Column B = Error
of excel.
Everyday data should be seperated from last date by just 1 or 2 empty rows in excel.
My code:
Sub ExtractEmailData()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim strFile As String
Dim objFSO As Object
Dim objTS As Object
Dim strText As String
Dim EmployeeID As String
Dim Error As String
Dim OlInbox As Outlook.MAPIFolder
'Set Outlook application object
Set olApp = New Outlook.Application
'Set Outlook namespace
Set olNS = olApp.GetNamespace("MAPI")
'olFolderI is Inbox folder
Set olFolderI = olNS.GetDefaultFolder(olFolderInbox)
'Get the parent folder of the Inbox folder
Dim olParentFolder As Outlook.MAPIFolder
Set olParentFolder = olFolderI.Parent
' Loop through all the subfolders of the parent folder
For Each subfolder In olParentFolder.Folders
'set olFolder as TARGET123
If subfolder.Name = "TARGET123" Then
Set olFolder = subfolder
End If
Next
'Path of the Windows desktop folder
DesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
'Loop through emails in TARGET123 folder
For Each olMail In olFolder.Items
'Extract EmployeeID and Error from email body
EmployeeID = ExtractData(olMail.Body, "Employee Id:\s*(\d+)")
Error = ExtractData(olMail.Body, "Error Details:\s*(.+)")
'Create string to write to file
strText = EmployeeID + "," + Error + vbNewLine
'Set file name and location
strFile = DesktopPath + Format(Now(), "dd-MMM-yyyy") + ".csv"
'Check if file already exists
If Len(Dir(strFile)) = 0 Then
'Create new file and write headers
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTS = objFSO.CreateTextFile(strFile, True)
objTS.WriteLine "EmployeeID,Error"
objTS.Close
Else
'Open file and append data
Open strFile For Append As #1
Print #1, strText
Close #1
End If
Next olMail
'Clean up
Set objFSO = Nothing
Set objTS = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
'Function to extract data using regular expressions
Public Function ExtractData(strText As String, strPattern As String) As String
Dim objRegEx As Object
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Pattern = strPattern
objRegEx.Global = True
If objRegEx.Test(strText) Then
ExtractData = objRegEx.Execute(strText)(0).SubMatches(0)
Else
ExtractData = ""
End If
Set objRegEx = Nothing
End Function
'Application.OnTime TimeValue("20:00:00"), "ExtractEmailData"
'You can also specify a specific date and time for the macro to run using the Application.OnTime method, for example:
Public Sub ScheduleMacro()
Application.OnTime Now + TimeValue("00:00:10"), "ExtractEmailData"
End Sub
ScheduleMacro
End Sub
But this code just creates a new file everyday(which is also fine) and the columns created are also fine but there is not data being extracted from emails and populated into the excel file.
It seems the following code doesn't add the retrieved in Outlook data to the Excel file:
'Open file and append data
Open strFile For Append As #1
Print #1, strText
Close #1
Try to set a break point and go through each line of code under the debugger attached.
Also keep in mind that Outlook folders may contain different kind of items - emails, appointments, documents, notes and etc. So, it makes sense to make sure that you deal with mail items before accessing its properties. For example, not all properties may be available. In the code you iterate over items assuming they are all mail items:
Dim olMail As Outlook.MailItem
'Loop through emails in TARGET123 folder
For Each olMail In olFolder.Items
Instead, I'd suggest declaring the item as object and check the MessageClass before casting to the MailItem class to make sure you deal with a true mail item.
I get 50 mails with Excel sheets per day. I want to add the first line of each Excel sheet to an existing Excel sheet located on my computer.
I know how to save a file from an email, and then access the first line. I would like to directly access it, without having to save the file.
Something like this:
Sub Merge_Reports(itm As Outlook.MailItem)
Dim wb_path As String
Dim app_master As Object
Dim wb_master As Object
Dim ws_master As Object
Dim objAtt As Outlook.Attachment
Dim ws_email As Object
Dim content As String
wb_path = "\\swi56prof01\UserData$\heinreca\Documents\Outlook-Dateien\AllData.xlsx"
Set app_master = CreateObject("Excel.Application")
Set wb_master = app_master.Workbooks.Open(wb_path)
Set ws_master = wb_master.Sheets(1)
For Each objAtt In itm.Attachments
Set ws_email = objAtt.Sheets(1)
content = ws_email.Cells("A1")
ws_master.Cells("A1") = content
End Sub
I am struggling with ws_email = objAtt.Sheets(1). I get the error
object doesn't support this property or method
I tried this instead of the line that results in the error.
Set app_email = CreateObject("Excel.Application")
Set wb_email = app_email.Workbooks.Open(objAtt)
Set ws_email = wb_email.Sheets(1)
I don't know what objAtt is in terms of data type and how to address the worksheet, so that I can copy the first line from it.
I found Copy Contents of Outlook Attachment and that I have to save the file before accessing it. Is there no other way?
There is no way to access the workbook without saving it to the disk. After saving the attached file to the disk you can use the same code:
Set wb_master = app_master.Workbooks.Open(wb_path)
Set ws_master = wb_master.Sheets(1)
where wb_path is the file path of your saved attachment (Excel file).
The Attachment.SaveAsFile method saves the attachment to the specified path. For example:
Sub SaveAttachment()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem
Set myAttachments = myItem.Attachments
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the first attachment in the current item to the Documents folder? If a file with the same name already exists in the destination folder, it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") & "\My Documents\" & _
myAttachments.Item(1).DisplayName
End If
Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub
I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub
I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub