About Information Technology and electronics system.
Jumaat, 19 Oktober 2012
How to copy Outlook mail message into excel using VBA or Macros
* First paste the below mentioned code in the outlook module.
Click on Tools~~>Rules and Alerts
Click on "New Rule"
Click on "start from a blank rule"
Select "Check messages When they arrive"
Under conditions, click on "with specific words in the subject"
Click on "specific words" under rules description.
Type the word that you want to check in the dialog box that pops up and click on "add".
Click "Ok" and click next
Select "move it to specified folder" and also select "run a script" in the same box
In the box below, specify the specific folder and also the script (the macro that you have in module) to run.
Click on finish and you are done.
When the new email arrives not only will the email move to the folder that you specify but data from it will be exported to Excel as well.
Const xlUp AsLong=-4162Sub ExportToExcel(MyMail As MailItem)Dim strID AsString, olNS As Outlook.NamespaceDim olMail As Outlook.MailItem
Dim strFileName AsString'~~> Excel VariablesDim oXLApp AsObject, oXLwb AsObject, oXLws AsObjectDim lRow AsLong
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")Set olMail = olNS.GetItemFromID(strID)'~~> Establish an EXCEL application objectOnErrorResumeNextSet oXLApp = GetObject(,"Excel.Application")'~~> If not found then create new instanceIf Err.Number <>0ThenSet oXLApp = CreateObject("Excel.Application")EndIf
OnErrorGoTo0'~~> Show Excel
oXLApp.Visible =True'~~> Open the relevant fileSet oXLwb = oXLApp.Workbooks.Open("C:\Sample.xls")'~~> Set the relevant output sheet. Change as applicableSet oXLws = oXLwb.Sheets("Sheet1")
lRow = oXLws.Range("A"& oXLApp.Rows.Count).End(xlUp).Row +1'~~> Write to outlookWith oXLws
''~~> Code here to output data from email to Excel File'~~> For example'.Range("A"& lRow).Value = olMail.Subject
.Range("B"& lRow).Value = olMail.SenderName
'EndWith'~~> Close and Clean up Excel
Set oXLws =NothingSet oXLwb =NothingSet oXLApp =NothingSet olMail =NothingSet olNS =NothingEndSub
To extract the contents from your email body, you can split it using SPLIT() and then parsing out the relevant information from it. See this example
MyAr = Split(olMail.body, vbCrLf)For i = LBound(MyAr)To LBound(MyAr)'~~> This will give you the contents of your email'~~> on separate lines
Debug.Print MyAr(i)Next i
"How do I extract data from Outlook emails to Excel workbooks?" For example, two questions up on [outlook-vba] the same question was asked on 13 August. That question references a variation from December that I attempted to answer.
For the December question, I went overboard with a two part answer. The first part was a series of teaching macros that explored the Outlook folder structure and wrote data to text files or Excel workbooks. The second part discussed how to design the extraction process. For this question Siddarth has provided an excellent, succinct answer and then a follow-up to help with the next stage.
What the questioner of every variation appears unable to understand is that showing us what the data looks like on the screen does not tell us what the text or html body looks like. This answer is an attempt to get past that problem.
The macro below is more complicated than Siddarth’s but a lot simpler that those I included in my December answer. There is more that could be added but I think this is enough to start with.
The macro creates a new Excel workbook and outputs selected properties of every email in Inbox to create this worksheet:
Near the top of the macro there is a comment containing eight hashes (#). The statement below that comment must be changed because it identifies the folder in which the Excel workbook will be created.
All other comments containing hashes suggest amendments to adapt the macro to your requirements.
How are the emails from which data is to be extracted identified? Is it the sender, the subject, a string within the body or all of these? The comments provide some help in eliminating uninteresting emails. If I understand the question correctly, an interesting email will have Subject = "Task Completed".
The comments provide no help in extracting data from interesting emails but the worksheet shows both the text and html versions of the email body if they are present. My idea is that you can see what the macro will see and start designing the extraction process.
This is not shown in the screen image above but the macro outputs two versions on the text body. The first version is unchanged which means tab, carriage return, line feed are obeyed and any non-break spaces look like spaces. In the second version, I have replaced these codes with the strings [TB], [CR], [LF] and [NBSP] so they are visible. If my understanding is correct, I would expect to see the following within the second text body:
Activity[TAB]Count[CR][LF]Open[TAB]35[CR][LF]HCQA[TAB]42[CR][LF]HCQC[TAB]60[CR][LF]HAbst[TAB]50 45 5 2 2 1[CR][LF] and so on
Extracting the values from the original of this string should not be difficult.
I would try amending my macro to output the extracted values in addition to the email’s properties. Only when I have successfully achieved this change would I attempt to write the extracted data to an existing workbook. I would also move processed emails to a different folder. I have shown where these changes must be made but give no further help. I will respond to a supplementary question if you get to the point where you need this information.
Option ExplicitPublicSub SaveEmailDetails()' This macro creates a new Excel workbook and writes to it details' of every email in the Inbox.Dim ExcelWkBk As Excel.Workbook
Dim FileName AsStringDim FolderTgt As MAPIFolder
Dim HtmlBody AsStringDim InterestingItem AsBooleanDim InxItemCrnt AsLongDim PathName AsStringDim ReceivedTime AsDateDim RowCrnt AsLongDim SenderEmailAddress AsStringDim SenderName AsStringDim Subject AsStringDim TextBody AsStringDim xlApp As Excel.Application
' The Excel workbook will be created in this folder.' ######## Replace "C:\DataArea\Play" with the name of a folder on your disc.
PathName ="C:\DataArea\Play"' This creates a unique filename.' #### If you want to update an existing workbook, set FileName to its name
FileName = Format(Now(),"yymmdd hhmmss")&".xls"' Open own copy of ExcelSet xlApp = Application.CreateObject("Excel.Application")With xlApp
.Visible =True' This slows your macro but helps during debugging.ScreenUpdating =False' Reduces flash and increases speed' Create a new workbook' #### If updating an existing workbook, replace with an' #### Open workbook statement.Set ExcelWkBk = xlApp.Workbooks.Add
' #### None of this code will be useful if you are adding' #### to an existing workbook. However, it demonstrates a' #### variety of useful statements..Worksheets("Sheet1").Name ="Inbox"' Rename first worksheetWith.Worksheets("Inbox")' Create header lineWith.Cells(1,"A").Value ="Field".Font.Bold =TrueEndWithWith.Cells(1,"B").Value ="Value".Font.Bold =TrueEndWith.Columns("A").ColumnWidth =18.Columns("B").ColumnWidth =150EndWithEndWith
RowCrnt =2EndWith' FolderTgt is the folder I am going to search. This statement says' I want to seach the Inbox. The value "olFolderInbox" can be replaced' to allow any of the standard folders to be searched. I have a routine' that will find other folders which I will share if it would be useful.Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)' This examines the emails in reverse order. I will explain why later.For InxItemCrnt = FolderTgt.Items.Count To1Step-1With FolderTgt.Items.Item(InxItemCrnt)' A folder can contain several types of item: mail items, meeting items,' contacts, etc. I am only interested in mail items.If.Class= olMail Then' Save selected properties to variables
InterestingItem =FalseEndIfEndWith' The most used properties of the email have been loaded to variables but' there are many more properies. Press F2. Scroll down classes until' you find MailItem. Look through the members and note the name of' any properties that look useful. Look them up using VB Help.' #### You need to add code here to eliminate uninteresting items.' #### For example:'If SenderEmailAddress <> "JohnDoe@AcmeSoftware.co.zy" Then' InterestingItem = False'End If'If InStr(Subject, "Accounts payable") = 0 Then' InterestingItem = False'End If' #### If the item is still thought to be interesting I' #### suggest extracting the required data to variables here.' #### You should consider moving processed emails to another' #### folder. The emails are being processed in reverse order' #### to allow this removal of an email from the Inbox without' #### effecting the index numbers of unprocessed emails.If InterestingItem ThenWith ExcelWkBk
With.Worksheets("Inbox")' #### This code creates a dividing row and then' #### outputs a property per row. Again it demonstrates' #### statements that are likely to be useful in the final' #### version' Create dividing row between emails.Rows(RowCrnt).RowHeight =5.Range(.Cells(RowCrnt,"A"),.Cells(RowCrnt,"B")) _
.Interior.Color = RGB(0,255,0)
RowCrnt = RowCrnt +1.Cells(RowCrnt,"A").Value ="Sender name".Cells(RowCrnt,"B").Value = SenderName
RowCrnt = RowCrnt +1.Cells(RowCrnt,"A").Value ="Sender email address".Cells(RowCrnt,"B").Value = SenderEmailAddress
RowCrnt = RowCrnt +1.Cells(RowCrnt,"A").Value ="Received time"With.Cells(RowCrnt,"B").NumberFormat ="@".Value = Format(ReceivedTime,"mmmm d, yyyy h:mm")EndWith
RowCrnt = RowCrnt +1.Cells(RowCrnt,"A").Value ="Subject".Cells(RowCrnt,"B").Value = Subject
RowCrnt = RowCrnt +1If TextBody <>""ThenWith.Cells(RowCrnt,"A").Value ="text body".VerticalAlignment = xlTop
EndWithWith.Cells(RowCrnt,"B")' The maximum size of a cell 32,767.Value = Mid(TextBody,1,32700).WrapText =TrueEndWith
RowCrnt = RowCrnt +1With.Cells(RowCrnt,"A").Value ="text body".VerticalAlignment = xlTop
TextBody = Replace(TextBody, Chr(160),"[NBSP]")
TextBody = Replace(TextBody, vbCr,"[CR]")
TextBody = Replace(TextBody, vbLf,"[LF]")
TextBody = Replace(TextBody, vbTab,"[TB]")With.Cells(RowCrnt,"B")' The maximum size of a cell 32,767.Value = Mid(TextBody,1,32700).WrapText =TrueEndWith
RowCrnt = RowCrnt +1EndIfIf HtmlBody <>""ThenWith.Cells(RowCrnt,"A").Value ="Html body".VerticalAlignment = xlTop
EndWithWith.Cells(RowCrnt,"B").Value = Mid(HtmlBody,1,32700).WrapText =TrueEndWith
RowCrnt = RowCrnt +1EndIfEndWithEndWithEndIfNextWith xlApp
' Write new workbook to discIf Right(PathName,1)<>"\"Then
PathName = PathName &"\"EndIf.SaveAs FileName:=PathName & FileName
EndWith.Quit ' Close our copy of ExcelEndWithSet xlApp =Nothing' Clear reference to ExcelEndSub