sshot1
11-06-2012, 07:26 PM
Hello All! This is my first post here. Let me forewarn you, I am very longwinded, but it is only so you will have all the details you might need! I am new to VBA, like 2 days new,so please forgive me if I have to ask seamingly dumb questions, but although I have had absolutely no VBA training, I am a quick learner! I just learned that Alt+F11 opens the VBA Editor in Outlook, then I found some code to extract Outlook emails into an existing excel file and created the module, enabled Macros in Outlook and it worked. :) I do need to tweak it abit though and I was hoping someone could help me. Below is the code I am using and I will also provide an example afterwards of what I need to do:
********************************************
Sub Exportoutlook()
On Error GoTo ErrHandler
'Declarations
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim Atmt As Attachment
'Specifying Output Name and Location. Note: In the current verison this location/Blank file must already exist.
strSheet = "MyFile.xlsx"
strPath = "C:\MyFolder\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Error Message if inbox is empty.
If fld Is Nothing Then
MsgBox "Il n'y a pas des messages électroniques à exporter/There are no mail messages to export.", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "Il n'y a pas des messages électroniques à exporter/There are no mail messages to export.", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "Il n'y a pas des messages électroniques à exporter/There are no mail messages to export.", vbOKOnly, _
"Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
'This tells the program to add all of the variables in the column to the right of the perivous variable.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
'First column is the to field in outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderName
intColumnCounter = intColumnCounter + 1
'Second Column is the CC field in Outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
'Third Column is the Body field in Outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Body
intColumnCounter = intColumnCounter + 1
'Fourth Column is the Send date field in Outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
Next itm
'Finally we clear the memory so the user has optimal performance once the tasks are complete.
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
'If the program run into an error while it is running it will cease operation and jump to here.
ErrHandler:
Resume Next
'Clear memory in case of error
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
***********************************************
The above code extracts the entire body of the email into column "C" of the excel file, but I really only need certain parts of the email. This is where it gets tricky. These particular emails come in a certain format each time, but then there are replies to these emails that are not in any set format. Here are examples of both:
Original email:
***********************************************
Subject: (Always the same, and is inserted into column B of the Excel file)
Communication Delays Detected
Msg Body: (Always the same with one exception, there may be multiple SiteNames, each having their own line)
11/06/2012 19:30
Communication Delays Detected
Site Last Communication
----------------------- ------------------
SiteName 11/06/2012 17:24
**********************************************
And here is a typical response:
**********************************************
Subject: (Always the same, and is inserted into column B of the Excel file)RE: Communication Delays Detected
Msg Body: (always different, sometimes few words, sometime paragraphs)
Tech Onsite! Reboot corrected the problem.
(Then the original email and all associated To,From,Time Sent info is appended to the bottom of the reply)
**********************************************
So, the way it currently works, on the response, I get the entire email chain in the cell in column C, including To,From,Time Sent, etc, but I only need the response, not the entire email chain in the message body.
I don't know if this is possible or not, but I figured this would be a good place to find out! Please let me know if you need any additional info!
Thanks in advance!
********************************************
Sub Exportoutlook()
On Error GoTo ErrHandler
'Declarations
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim Atmt As Attachment
'Specifying Output Name and Location. Note: In the current verison this location/Blank file must already exist.
strSheet = "MyFile.xlsx"
strPath = "C:\MyFolder\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Error Message if inbox is empty.
If fld Is Nothing Then
MsgBox "Il n'y a pas des messages électroniques à exporter/There are no mail messages to export.", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "Il n'y a pas des messages électroniques à exporter/There are no mail messages to export.", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "Il n'y a pas des messages électroniques à exporter/There are no mail messages to export.", vbOKOnly, _
"Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
'This tells the program to add all of the variables in the column to the right of the perivous variable.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
'First column is the to field in outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderName
intColumnCounter = intColumnCounter + 1
'Second Column is the CC field in Outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
'Third Column is the Body field in Outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Body
intColumnCounter = intColumnCounter + 1
'Fourth Column is the Send date field in Outlook
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
Next itm
'Finally we clear the memory so the user has optimal performance once the tasks are complete.
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
'If the program run into an error while it is running it will cease operation and jump to here.
ErrHandler:
Resume Next
'Clear memory in case of error
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
***********************************************
The above code extracts the entire body of the email into column "C" of the excel file, but I really only need certain parts of the email. This is where it gets tricky. These particular emails come in a certain format each time, but then there are replies to these emails that are not in any set format. Here are examples of both:
Original email:
***********************************************
Subject: (Always the same, and is inserted into column B of the Excel file)
Communication Delays Detected
Msg Body: (Always the same with one exception, there may be multiple SiteNames, each having their own line)
11/06/2012 19:30
Communication Delays Detected
Site Last Communication
----------------------- ------------------
SiteName 11/06/2012 17:24
**********************************************
And here is a typical response:
**********************************************
Subject: (Always the same, and is inserted into column B of the Excel file)RE: Communication Delays Detected
Msg Body: (always different, sometimes few words, sometime paragraphs)
Tech Onsite! Reboot corrected the problem.
(Then the original email and all associated To,From,Time Sent info is appended to the bottom of the reply)
**********************************************
So, the way it currently works, on the response, I get the entire email chain in the cell in column C, including To,From,Time Sent, etc, but I only need the response, not the entire email chain in the message body.
I don't know if this is possible or not, but I figured this would be a good place to find out! Please let me know if you need any additional info!
Thanks in advance!