I am trying to extract 2 fields from the following email.
How would you like your name to appear on the CERTIFICATE OF PARTICIPATION?
Joe Johnson (sample name)
Email Address Required Joe.Johnson#xxxmail.com
and the email address after "Required" which is Joe.Johnson#xxxmail.com
I want to import those two fields to Excel so I can populate a certificate and return it to the email address. Ultimately I would like to have code that would do all of the above but for the time being I would be happy just to get the following code to work.
I get a run time error on the following: Set xlSheet = xlWB.Sheets("Sheet1")
Sub ExtractEmailData()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "D:\Joe\Documents\2018 TEAMS Certificate.xlsm" 'the path of the workbook
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "PARTICIPATION?") > 0 Then
vItem = Split(vText(i), Chr(60))
vItem = Split(vItem(1), Chr(62))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Email Address Required") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
I am new to VBA.
Just to offer a simple fix, in case the problem is simple. Does "D:\Joe\Documents\2018 TEAMS Certificate.xlsm" definitely have a worksheet named "Sheet1"? If not, maybe you meant:
Set xlSheet = xlWB.Sheets(1)
Related
I have been tasked with getting a list of all the users who sent mail to a mailbox in Outlook and transferring it to an excel sheet. Specifically, the sender's name, email address, as well as retrieving the sender's alias from the GAL address book.
For a somewhat large amount of the users, instead of their email address transferring, the X500 address is what shows up as follows: /O=OREGON STATE UNIVERSITY/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN
This is just an example I found online but the format is exactly the way it shows up in the Excel sheet.
I don't have a large knowledge of VBA, so maybe not getting too technical would be helpful.
Here's the code I have (the majority of which I found online):
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim oAL As Outlook.AddressList
Dim olAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD As String
enviro = CStr(Environ("USERPROFILE"))
'where to find excel sheet
strPath = enviro & "\Documents\EmailList.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'Where to transfer the info
Set xlWB = xlApp.workbooks.Open(strPath)
Set xlSheet = xlWB.sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(4000).Row
' where to find the information
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'extract the information
strColB = olItem.SenderName
strColC = olItem.SenderEmailAddress
strColD = olItem.Sender.GetExchangeUser.Alias
'Get the Exchange address
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.session.CreateRecipient(strColB)
If InStr(1, strColC, "/") > 0 Then
'if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If
'write them in the excel sheet
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("C" & rCount) = strColC
xlSheet.Range("D" & rCount) = strColD
'Next row
rCount = rCount + 1
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
You never guard for the fact that GetExchangeUser can return null. And why do you call CreateRecipient? You already have the AddressEntry object
Off the top of my head:
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim oAL As Outlook.AddressList
Dim olAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD As String
Dim olEU As Outlook.ExchangeUser
dim olSender As Object
enviro = CStr(Environ("USERPROFILE"))
'where to find excel sheet
strPath = enviro & "\Documents\EmailList.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'Where to transfer the info
Set xlWB = xlApp.workbooks.Open(strPath)
Set xlSheet = xlWB.sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(4000).Row
' where to find the information
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'extract the information
strColB = olItem.SenderName
strColC = olItem.SenderEmailAddress
set olSender = olItem.Sender
if Not (olSender Is Nothing) Then
set olEU = olSender.GetExchangeUser
if (olEU Is Nothing) Then
strColD = ""
Else
strColC = olEU.PrimarySmtpAddress
strColD = olEU.Alias
End If
'write them in the excel sheet
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("C" & rCount) = strColC
xlSheet.Range("D" & rCount) = strColD
'Next row
rCount = rCount + 1
End If
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
I have macro which exports all data from Outlook INBOX to Excel along with time and date, but I need to set up to a particular folder to be copied in a same way.
How do I setup to specific subfolder?
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim obj As Object
Dim olItem 'As Outlook.MailItem
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("Sheet1")
On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
xlSheet.Range("A1") = "Sender Name"
xlSheet.Range("B1") = "Sender Email"
xlSheet.Range("C1") = "Subject"
xlSheet.Range("D1") = "Body"
xlSheet.Range("E1") = "Sent To"
xlSheet.Range("F1") = "Date"
End If
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
' needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each obj In objItems
Set olItem = obj
'collect the fields
strColA = olItem.SenderName
strColB = olItem.SenderEmailAddress
strColC = olItem.Subject
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime
' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColB)
If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section
'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF
'Next row
rCount = rCount + 1
xlWB.Save
Next
' don't wrap lines
xlSheet.Rows.WrapText = False
xlWB.Save
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
You are using ActiveExplorer.CurrentFolder on your code, the CurrentFolder Property represents the current folder that is displayed in the explorer, code should run on any Active Explorer- just navigate on any folder that you like to run the code on.
If you prefer to change then You need to modify the following lines of code to set up your specified folder,
' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
To something like this
' get the values from outlook
Set objOL = Outlook.Application
Dim olNs As Outlook.NameSpace
Set olNs = objOL.GetNamespace("MAPI")
Set objFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("SubFolder Name Here")
See Folder Object (Outlook) MSDN Use the Folders property of a NameSpace object or another Folder object to return the set of folders in a NameSpace or under a folder. You can navigate nested folders by starting from a top-level folder, say the Inbox, and using a combination of the Folder.Folders property, which returns the set of folders underneath a Folder object in the hierarchy,
Example:
GetDefaultFolder(olFolderInbox).Folders("SubFolderName") _
.Folders("SubFolderName")
and the Folders.Item method, which returns a folder within the Folders collection.
I want to export messages to Excel. However, when I try running the macro, I don't see it in the list.
I just copied the code below from http://www.slipstick.com/developer/vba-copy-outlook-email-excel-workbook
Option Explicit
Const xlUp As Long = -4162
Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim strPath As String
Dim M1 As Object
Dim M As Object
Dim lgLastRow As Long 'specify the last data row
lgLastRow = Range("A1048576").End(xlUp).Row 'Take Note: very useful!!
enviro = CStr(Environ("username"))
'the path of the workbook
strPath = enviro & "C:\Desktop\Project\SR History File.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = lgLastRow = Range("A1048576").End(xlUp).Row + 1
xlSheet.Range("A" & rCount) = olItem.SentOn
xlSheet.Range("B" & rCount) = olItem.SenderEmailAddress
xlSheet.Range("C" & rCount) = olItem.Subject
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set M = Nothing
Set M1 = Nothing
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
The code cannot run without a parameter, olItem.
Open a mailitem then run this, which will be in the list.
Option Explicit
Sub CopyToExcel_Test
Dim currItem as mailitem
Set currItem = ActiveInspector.currentitem
CopyToExcel currItem
ExitRoutine:
Set currItem = Nothing
End Sub
Closed. This question is not reproducible or was caused by typos. It is not currently accepting answers.
This question was caused by a typo or a problem that can no longer be reproduced. While similar questions may be on-topic here, this one was resolved in a way less likely to help future readers.
Closed 5 years ago.
Improve this question
I am trying to extract Data from emails by using this script I found online with some changes to run for my specific information:
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\Rob\Documents\Excel\ExcelTest.xlsx" 'the path of the workbook
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Destination -") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
The information I have to extract from the emails are shown below in BOLD.
Destination State - Pennsylvania
Destination - Pittsburgh
UK Airport - London Gatwick
Airline - United Airlines
Flight Class - Premium - from £499
Depart Date - 27/07/2011
Return Date - 10/08/2011
Adults - 2
Children - 1
First Name - Andrew
Last Name - Leakey
Telephone - 07785 496123 // Number Is fake
Contact Email - AmdrewsEmail#Email.org.uk
When I run the code it says "Subscript out of range" and the debugger says it is occurring on this line.
xlSheet.Range("A" & rCount) = Trim(vItem(1))
Replace this:
vItem = Split(vText(i), Chr(58))
with this:
vItem = Split(vText(i),"-")
An integer number follows "Purchase Order:" in the email body.
All emails follow this format. http://i.stack.imgur.com/1Ck9Q.jpg
The number is to be pasted into the next empty row of the Excel spreadsheet.
I have a spreadsheet on my desktop named "test" to try this with.
I've tried about 4 or 5 different VBA codes I found using Google with no luck.
A method to address this frequently asked question is shown here. http://social.msdn.microsoft.com/Forums/en-US/f1ab97d9-8fef-46cc-bbe0-e597370ed1c2/export-content-from-outlook-2010-emails-to-excel-spreadsheet?forum=isvvba
The code goes into Outlook not Excel.
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = " C:\path\desktop\test.xlsx" 'the path of the workbook
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.UsedRange.Rows.Count
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
rCount = rCount + 1
If InStr(1, vText(i), "Purchase order:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
' Where more data is to be extracted add more of these lines.
'If InStr(1, vText(i), "Second label:") > 0 Then
' vItem = Split(vText(i), Chr(58))
' xlSheet.Range("B" & rCount) = Trim(vItem(1))
'End If
'If InStr(1, vText(i), "Third label:") > 0 Then
' vItem = Split(vText(i), Chr(58))
' xlSheet.Range("C" & rCount) = Trim(vItem(1))
'End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub