Copy content of Excel attachment in Outlook VBA without saving the file - excel

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

Related

Extracting specific data from outlook emails and store it into excel file

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.

Convert Outlook Contact Group early binding Excel VBA to late binding

I am trying to insert a list of email addresses from Excel into a contact group in Outlook.
I found Excel VBA code online. It uses early binding. It is not an option to force the user to go into Tools-> References -> Outlook, when they open the file.
I need to transform the code from early to late binding.
Questions:
I understand that I need to change Outlook.Application to
CreateObject('Outlook.Application') and that I can access
olFolderContacts with the number 10 instead. See code below.
I can't figure out how to access the remaining items such as
CreateItem(olDistributionListItem).
Sub CreateContactGroupfromExcel()
Dim objContactsFolder As Outlook.Folder
Dim objContact As Outlook.ContactItem
Dim objContactGroup As Outlook.DistListItem
Dim objNameCell As Excel.Range
Dim objEmailCell As Excel.Range
Dim strName As String
Dim strEmail As String
Dim objTempMail As Outlook.MailItem
Dim objRecipients As Outlook.Recipients
Set objContactsFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Set objContactGroup = Outlook.Application.CreateItem(olDistributionListItem)
'You can change the contact group name
objContactGroup.DLName = "PlaceHolder_VBA"
i = 0
Do While Range("vba_email_outlook").Offset(i, 0).Value <> "":
strName = Range("vba_name_outlook").Offset(i, 0).Value
strEmail = Range("vba_email_outlook").Offset(i, 0).Value
Set objContact = objContactsFolder.Items.Find("[FullName] = '" & strName & "'")
'If there is no such a contact, create it.
If objContact Is Nothing Then
Set objContact = Outlook.Application.CreateItem(olContactItem)
With objContact
.FullName = strName
.Email1Address = strEmail
.Save
End With
End If
'Add the contacts to the new contact group
Set objTempMail = Outlook.CreateItem(olMailItem)
objTempMail.Recipients.Add (strName)
Set objRecipients = objTempMail.Recipients
objContactGroup.AddMembers objRecipients
i = i + 1
Loop
'Use "objContactGroup.Save" to straightly save it
objContactGroup.Display
objTempMail.Close olDiscard
End Sub
Declare object variables as generic Object
Dim objContactsFolder As Object
Determine number values of constants. With early binding, these values can be seen when hovering over constant or in VBA immediate window: ?olMailItem. Then reference number in place of constant or leave constants referenced as they are and declare them as constants with Const statements. Const olMailItem = 0
olFolderContacts = 10
olMailItem = 0
olDistributionListItem = 7
I am not an expert but this code allows you to add the reference when you run the VBA script, but it will mean that if it errors out the code quits running you will not be able to debug.
On Error Resume Next ''' If reference already exist this would cause an error
Application.VBE.ActiveVBProject.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office16\MSOUTL.OLB") ''' Might have to change file path
On Error GoTo 0

How to resolve error remote server machine does not exist or is unavailable?

I want to open many pdfs in specific folder using word document and copy the contents and paste in my excel sheet without format change. The code which i have written was able to perform the task for 2 pdf files only after that it is showing run time error 462 - The remote server machine does not exist or is unavailable. Kindly help me what is going wrong and how i can resolve it? Thanks in advance.
Sub test()
Dim s As String
Dim path As String
Dim col As Integer: col = 1
Dim t As Excel.Range
path = "C:\Users\121919\Desktop\Direct Dispatch Report_PENS\29 Jul\PDF to Word Try\"
s = Dir(path & "*.pdf")
Do Until s = ""
Dim wd As New Word.Application
Dim mydoc As Word.document
Set mydoc = Word.Documents.Open(Filename:=path & s, Format:="PDF Files", ConfirmConversions:=False)
Dim wr As Word.Range
Set wr = mydoc.Paragraphs(1).Range
wr.WholeStory
Set t = ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
wr.Copy
t.PasteSpecial xlPasteValues
mydoc.Close False: s = Dir
wd.Quit '<- This is where the code stops and throw error
Loop
End Sub

Export multiple emails to one csv file

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

update and existing excel file via outlook mail with excel file attachment

I currently have this next code in outlook VBA(found it in one of the topics here):
Public Sub FMK(Item As Outlook.MailItem)
Const PathName = "C:\Documents and Settings\Administrator\My Documents\files\Diary.xlsx"
Dim arrLines As Variant
Dim varLines As Variant
Dim RowNext As Long
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim excWkb As Object
Dim excWks As Object
Dim temp As String
arrLines = Split(Item.Body, vbCrLf)
Set xlApp = Application.CreateObject("Excel.Application")
Set excWkb = xlApp.Workbooks.Open(PathName)
Set excWks = excWkb.ActiveSheet
RowNext = excWks.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
With excWks
excWks.Cells(RowNext, 1) = temp
End With
RowNext = RowNext + 1
excWkb.SaveAs PathName
excWkb.Close
End Sub
Please help me ...
I need to update an Excel file that exists on my computer using a file that comes in Outlook ...
Always the same format files
I just want to add the lines that come Excel files by e-mail in addition to what is in the file on your PC
My knowledge is very limited in VBA
You can automate Outlook from Excel for extracting the required attached file. The Attachment class provides the SaveAs method which can be used to save the file on the disk. Then you can use the Open method of the Workbook class to open the just saved file.
See How to automate Outlook from another program for more information.

Resources