I have an excel macro that works perfect in windows (email text extraction), but when I run it in my mac it gives me the error missing the library Microsoft Outlook 16.0 Object Library.
I was thinking in late binding (I tried but I wasn't able to fix it)
Can you pls help me to fix my code in order to run it in my mac? thanks in advance.
Code Below:
Sub DetailExtraction() 'MacVersion
On Error GoTo ErrHandler
Application.ScreenUpdating = False
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder As Object
Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox)
Dim Item As Object
Dim iRows, iCols As Integer
iRows = 2
' LOOP THROUGH EACH ITEMS IN THE FOLDER.
'For Each objItem In myFolder.Items
' LOOP THROUGH EACH ITEMS IN THE SELECTION.
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Dim objMail As Outlook.MailItem ' PROBLEM IS IN THIS LINE
Set objMail = objItem
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
Cells(iRows, 6) = objMail.Body
Cells(iRows, 6).WrapText = False
'MsgBox Prompt:=objMail.Body
End If
'WRAP UP FILE OFF
' Cells*i.WrapText = False
' SHOW OTHER PROPERTIES, IF YOU WISH.
'Cells(iRows, 6) = objMail.Body
'Cells(iRows, 5) = objMail.CC
'Cells(iRows, 6) = objMail.BCC
'Cells(iRows, 4) = objMail.Recipients(1)
iRows = iRows + 1
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
Application.ScreenUpdating = True
MsgBox "Environments Details Extracted from the Selected Emails (" & iRows - 2 & ")"
End Sub
Related
My code works fine in the default calendar but I am unable to get it to made an appointment in the AllPublicFolders Calendar. I am unable to call the function GetPublicFolder because I am new using VBA. Any help would be greatly appreciated.
Here is my code with "Big Store A Calendar in the all public folders:
Option Explicit
Sub RegisterAppointmentList()
' adds a list of appointments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
On Error Resume Next
'Worksheets("Schedule").Activate
Worksheets("Appt").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
'r = 6 ' first row with appointment data in the active worksheet
r = 2 ' first row with appointment data in the active worksheet
Dim mysub, myStart, myEnd
While Len(Cells(r, 2).Text) <> 0
mysub = Cells(r, 2) & ", " & Cells(r, 3)
myStart = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
myEnd = DateValue(Cells(r, 7).Value) + Cells(r, 8).Value
'DeleteTestAppointments mysub, myStart, myEnd
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
.Location = Cells(r, 2)
.Body = Cells(r, 3).Value
.ReminderSet = False
.BusyStatus = olFree
'.RequiredAttendees = "johndoe#microsoft.com"
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = Cells(r, 1)
.Location = Cells(r, 2)
.Body = Cells(r, 3).Value
'.ReminderSet = True
'.BusyStatus = olBusy
.Categories = Cells(r, 4).Value
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
' Print the Appt Sheet
Sheets("Sheet1").PrintOut
MsgBox "The Appt Sheet Printed and the Appt was entered in your default calendar on May 31st!"
End Sub
‘-------------------------I Need to get correct Public folder for the Exchange calendar -------------
‘I am using VBA for excel workbooks and need to create appointments in 2 public folder shared calendars
‘I need to get code like the code below to create appointments in the shared public calendar – ‘
‘I determine which calendar for the appointment using a workbook cell which is a list box of the 2 calendar names –
‘ Big Store A Calendar or Big Store B Calendar
' GetFolder - Gets a Public folder based on a string path - e.g.
'If Folder name in English is
'Public Folders\All Public Folders\Big Store A Calendar or
‘'Public Folders\All Public Folders\Big Store B Calendar
Public Function GetPublicFolder(strFolderPath)
Dim colFolders
Dim objFolder
Dim arrFolders
Dim i
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders = Split(strFolderPath, "\")
Set objFolder = Application.Session.GetDefaultFolder(18) ‘This is the correct folder # for “All Public Folders”
Set objFolder = objFolder.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetPublicFolder = objFolder
Set colFolders = Nothing
' Set objApp = Nothing
Set objFolder = Nothing
End Function
Application in Set objFolder = Application.Session.GetDefaultFolder(18) is Excel. You want to use Outlook.
Sub DisplyOutlookPublicFolderFromExcel()
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim pubCal As Folder
Set olApp = CreateObject("Outlook.Application")
Set pubCal = GetPublicFolder(olApp, "All Public Folders\Big Store A Calendar")
pubCal.Display
Set olAppItem = Nothing
Set olApp = Nothing
Set pubCal= Nothing
End Sub
Public Function GetPublicFolder(objApp, strFolderPath)
Dim colFolders
Dim objFolder
Dim arrFolders
Dim i
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders = Split(strFolderPath, "\")
Set objFolder = objApp.Session.GetDefaultFolder(18) 'This is the correct folder # for “All Public Folders”
Set objFolder = objFolder.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetPublicFolder = objFolder
Set colFolders = Nothing
Set objApp = Nothing
Set objFolder = Nothing
End Function
I have to sort about 8000 emails into the specific folders in Outlook (2013).
I created the folders in Outlook through an Excel list. This spreadsheet contains beside the foldername, as well the senders/receivers email address.
I want to create rules, following this example:
emails -> Received by sheet1.cells(i,4) -> move to folder =sheet1.cells(i,5)
Through googling I created this code:
Sub createOutlookRule()
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim moveToAction As Outlook.MoveOrCopyRuleAction
Dim fromAction As Outlook.ToOrFromRuleCondition
Dim myInbox As Outlook.Folder
Dim moveToFolder As Outlook.Folder
For i = 2 To 5
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)
Set olRules = appOutlook.Session.DefaultStore.GetRules()
Set myRule = olRules.Create(Sheet2.Cells(i, 1), olRuleReceive)
Set fromAction = myRule.Conditions.From
a = Sheet2.Cells(i, 3)
Set moveToFolder = myInbox.Folders("Mifid").Folders(a)
With fromAction
.Enabled = True
If IsEmpty(Sheet2.Cells(i, 4)) Then GoTo 4 Else
.Recipients.Add (Sheet2.Cells(i, 4))
If IsEmpty(Sheet2.Cells(i, 5)) Then GoTo 3 Else
.Recipients.adds (Sheet2.Cells(i, 5))
3:
End With
Set moveToAction = myRule.Actions.moveToFolder
With moveToAction
.Enabled = True
.Folder = moveToFolder
End With
olRules.Save
4:
Next i
End Sub
This essentially creates the rule but so far does not move items.
I adjusted it for the sent-items but during the "move part" I get an error
Sub createOutlookRuleSENTITEMS()
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim moveToAction As Outlook.MoveOrCopyRuleAction
Dim SENTAction As Outlook.ToOrFromRuleCondition
Dim myInbox As Outlook.Folder
Dim moveToFolder As Outlook.Folder
For i = 2 To 5
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)
Set olRules = appOutlook.Session.DefaultStore.GetRules()
Set myRuleSENT = olRules.Create(Sheet2.Cells(i, 1), olRuleSend)
Set TOAction = myRuleSENT.Conditions.SentTo
a = Sheet2.Cells(i, 3)
Set moveToFolder = myInbox.Folders("Mifid").Folders(a)
With TOAction
.Enabled = True
If IsEmpty(Sheet2.Cells(i, 4)) Then GoTo 4 Else
.Recipients.Add ("test#example.com")
If IsEmpty(Sheet2.Cells(i, 5)) Then GoTo 3 Else
.Recipients.adds (Sheet2.Cells(i, 5))
3:
End With
Set moveToAction = myRuleSENT.Actions.moveToFolder
With moveToAction
.Enabled = True
.Folder = moveToFolder
End With
olRules.Save
4:
Next i
End Sub
Error-Message:
Run-time error
Invalid operation. this rule action cannot be enabled because either the rule is read-only or invalid for the rule type, or the action conflicts with another action on the rule
The rules interface for sent items allows copy not move. (Does not prove it impossible.)
Option Explicit
Sub createOutlookRuleSENTITEMS()
' Reference Outlook nn.n Object Library
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRuleSENT As Outlook.Rule
Dim ToCondition As Outlook.ToOrFromRuleCondition
Dim CopySentItemRuleAction As Outlook.MoveOrCopyRuleAction
Dim myInbox As Outlook.Folder
Dim copyToFolder As Outlook.Folder
Dim i As Long
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)
For i = 2 To 5
Set olRules = appOutlook.Session.DefaultStore.GetRules()
Debug.Print "Sheet2.Cells(i, 1): " & Sheet2.Cells(i, 1)
Set myRuleSENT = olRules.Create(Sheet2.Cells(i, 1), olRuleSend)
Set ToCondition = myRuleSENT.Conditions.SentTo
Dim a As String
a = Sheet2.Cells(i, 3)
Debug.Print "a: " & a
Set copyToFolder = myInbox.Folders("Mifid").Folders(a)
With ToCondition
.Enabled = True
Debug.Print "Sheet2.Cells(i, 4): " & Sheet2.Cells(i, 4)
If Not IsEmpty(Sheet2.Cells(i, 4)) Then
.Recipients.Add ("test#example.com")
If Not IsEmpty(Sheet2.Cells(i, 5)) Then
.Recipients.Add (Sheet2.Cells(i, 5))
End If
' The rules interface for sent items allows copy not move.
' (Does not prove it impossible.)
'
'Action is to copy, not move, the sent item
Dim oCopyTarget As Outlook.Folder
Set copyToFolder = myInbox.Folders("Mifid").Folders(a)
Set CopySentItemRuleAction = myRuleSENT.Actions.copyToFolder
With CopySentItemRuleAction
.Enabled = True
.Folder = copyToFolder
End With
olRules.Save
End If
End With
Next i
Debug.Print "Done."
End Sub
I want to go into a specified folder in Outlook and based on a variable (value/named range in Excel) extract data from emails (To, Subject, etc.).
I can extract only the "Subject" and "Size" data of the emails.
If I try to pull in the "To" data, for example, it comes up with
"Run-time error '438': Object doesn't support this property or method error.
Sub FetchEmailData()
Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Integer
'Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olNs = appOutlook.GetNamespace("MAPI")
Set olFolder = olNs.Folders("Mailbox_name").Folders("Inbox").Folders("XYZ").Folders("2017").Folders("04. April").Folders("Etc")
'Clear
ThisWorkbook.Sheets("Test").Cells.Delete
'Build headings:
ThisWorkbook.Sheets("Test").Range("A1:D1") = Array("Sender_Email_Address", "Subject", "To", "Size")
For iRow = 1 To olFolder.Items.Count
ThisWorkbook.Sheets("Test").Cells(iRow, 1).Select
'ThisWorkbook.Sheets("Test").Cells(iRow, 1) = olFolder.Items.Item(iRow).SenderEmailAddress
ThisWorkbook.Sheets("Test").Cells(iRow, 2) = olFolder.Items.Item(iRow).Subject
'ThisWorkbook.Sheets("Test").Cells(iRow, 3) = olFolder.Items.Item(iRow).To
ThisWorkbook.Sheets("Test").Cells(iRow, 4) = olFolder.Items.Item(iRow).Size
Next iRow
End Sub
How could I extract fields such as "From" and "To"?
Also, if my Set olFolder value is a named range in Excel that dynamically changes with the date (=Today()) and uses Folder_Location as the named range in Excel, would it be correct to write;
Set olFolder = ThisWorkbook.Sheets("Setup").Range("Folder_Location")
Where
Folder_Location = olNs.Folders("Mailbox_name").Folders("Inbox").Folders("XYZ").Folders("2017").Folders("04. April").Folders("Etc")
This errors when I attempt to link it to olFolder.
I know this is an old question but I had the same problem recently and was able to figure it out after going through what you had done already.
There were only a few changes I needed to make; first I set my selected folder to be my inbox for simplicities sake:
Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason
Then, I changed the headings you made just a bit for my readability (not a functional change):
ThisWorkbook.Sheets("Data").Range("A1:D1") = Array("Sender Email Address:", "Subject:", "To:", "Size:")
Lastly to get the functionality you were looking for, a small change needed to be made to your indicies in your "Cells" parameter within your for loop:
For iRow = 1 To olFolder.Items.Count
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 1) = olFolder.Items.Item(iRow).SenderEmailAddress
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 2) = olFolder.Items.Item(iRow).Subject
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 3) = olFolder.Items.Item(iRow).To
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 4) = olFolder.Items.Item(iRow).Size
Next iRow
That "+1" in there makes it so we don't overwrite our headers. So the final version looks like this:
Sub FetchEmailData()
Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Integer
' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olNs = appOutlook.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason
' Clear
ThisWorkbook.Sheets("Test").Cells.Delete
' Build headings:
ThisWorkbook.Sheets("Test").Range("A1:D1") = Array("Sender Email Address:", "Subject:", "To:", "Size:")
For iRow = 1 To olFolder.Items.Count
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 1) = olFolder.Items.Item(iRow).SenderEmailAddress
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 2) = olFolder.Items.Item(iRow).Subject
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 3) = olFolder.Items.Item(iRow).To
ThisWorkbook.Sheets("Test").Cells(iRow + 1, 4) = olFolder.Items.Item(iRow).Size
Next iRow
End Sub
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.
Each employee gets an updated contact list. I'm creating a macro in Excel that will delete all outlook contacts, then import all the contacts on that sheet into their main outlook contacts. Not all users are on the same outlook version, so I can't use Early Binding methods since the Outlook OBJ Library cannot be referenced between versions.
I managed to get my delete loop into late binding easily, but I'm having trouble getting the import code to work in late binding. Here is the working early binding method I currently have for the import:
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olConItems As Outlook.Items
Dim olItem As Object
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
'Location in the imported contact list.
Dim lnContactCount As Long
Dim strDummy As String
'Turn off screen updating.
Application.ScreenUpdating = False
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)
'Format the target worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Company / Private Person"
.Cells(1, 2).Value = "Street Address"
.Cells(1, 3).Value = "Postal Code"
.Cells(1, 4).Value = "City"
.Cells(1, 5).Value = "Contact Person"
.Cells(1, 6).Value = "E-mail"
With .Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With
wsSheet.Activate
'Initalize the Outlook variables with the MAPI namespace and the default Outlook folder of the current user.
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(10)
Set olConItems = olFolder.Items
'Row number to place the new information on; starts at 2 to avoid overwriting the header
lnContactCount = 2
'For each contact: if it is a business contact, write out the business info in the Excel worksheet;
'otherwise, write out the personal info.
For Each olItem In olConItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.CompanyName, strDummy) > 0 Then
Cells(lnContactCount, 1).Value = .CompanyName
Cells(lnContactCount, 2).Value = .BusinessAddressStreet
Cells(lnContactCount, 3).Value = .BusinessAddressPostalCode
Cells(lnContactCount, 4).Value = .BusinessAddressCity
Cells(lnContactCount, 5).Value = .FullName
Cells(lnContactCount, 6).Value = .Email1Address
Else
Cells(lnContactCount, 1) = .FullName
Cells(lnContactCount, 2) = .HomeAddressStreet
Cells(lnContactCount, 3) = .HomeAddressPostalCode
Cells(lnContactCount, 4) = .HomeAddressCity
Cells(lnContactCount, 5) = .FullName
Cells(lnContactCount, 6) = .Email1Address
End If
wsSheet.Hyperlinks.Add Anchor:=Cells(lnContactCount, 6), _
Address:="mailto:" & Cells(lnContactCount, 6).Value, _
TextToDisplay:=Cells(lnContactCount, 6).Value
End With
lnContactCount = lnContactCount + 1
End If
Next olItem
'Null out the variables.
Set olItem = Nothing
Set olConItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
'Sort the rows alphabetically using the CompanyName or FullName as appropriate, and then autofit.
With wsSheet
.Range("A2", Cells(2, 6).End(xlDown)).Sort key1:=Range("A2"), order1:=xlAscending
.Range("A:F").EntireColumn.AutoFit
End With
'Turn screen updating back on.
Application.ScreenUpdating = True
MsgBox "The list has successfully been created!", vbInformation
End Sub
To use Late binding, you should declare all your Outlook-specific objects as Object:
Dim olApp As Object, olNamespace As Object, olFolder As Object, olConItems As Object
Then:
Set olApp = CreateObject("Outlook.Application")
This will make each computer create the olApp object from the Outlook library that is installed on it. It avoids you to set an explicit reference to Outlook14 in the workbook that you will distribute (remove that reference from the project before distributing the Excel file).
Hope this helps :)
All of your Outlook object declarations would first have to become non-Oulook related object declarations.
Dim olApp As Object
Dim olNamespace As Object
Dim olFolder As Object
Dim olConItems As Object
Dim olItem As Object
You will need a CreateObject function on the Outlook.Application object.
Set olApp = CreateObject("Outlook.Application")
Everything else should fall into place.