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.
Related
I'd like to create an Outlook calendar meeting request each time a workbook is saved.
The meeting requests need to be added to a shared mailbox so that all users that have access see the meeting invite.
So far it adds an entry to my personal calendar.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2021") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olApp.CreateItem(olAppointmentItem)
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Save
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Update:
I managed to get this. The problem now is that it'll only create the calendar entry for the last line.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2020") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
Dim olAppItem As Outlook.AppointmentItem
Dim myRequiredAttendee As Outlook.Recipient
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Set olAppItem = olRecItems.Items.Add(olAppointmentItem)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olAppItem
Set myRequiredAttendee = .Recipients.Add("email address")
myRequiredAttendee.Type = olRequired
.MeetingStatus = olMeeting
.ReminderMinutesBeforeStart = 30
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Send
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Instead of the following code:
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
You need to use the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders (for example, their shared Calendar folder). For example:
Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
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
I would like to import mail data from Outlook.
I have no problem to import classic fields such as: From, Subject ... etc. I cannot find how to import my "User-defined field".
The User-defined field is named "DemandQTY" and contains only numbers.
I get my data from a shared mailbox.
Sub GetFromOutlook()
Dim OutApp As Outlook.Application
Dim OutNS As Namespace
Dim Folder As MAPIFolder
Dim OutMail As Variant
Dim i As Integer
Dim objOwner As Outlook.Recipient
Dim FileName As String
Dim MI As Outlook.MailItem
Dim Item As Object
Dim Atmt As Attachment
Set OutNS = GetNamespace("MAPI")
Set OutApp = New Outlook.Application
Set objOwner = OutNS.CreateRecipient("emailadress")
objOwner.Resolve
If objOwner.Resolved Then
Set Folder = OutNS.GetSharedDefaultFolder(objOwner, olFolderInbox)
i=2
For Each OutMail In Folder.Items
Sheets(2).Cells(i, 1) = OutMail.EntryID
' (etc....)
Sheets(2).Cells(i, 32) = OutMail.ReminderTime
i = i + 1
Next OutMail
MsgBox "Importation Terminée"
Sheets(2).Select
Sheets(2).Cells(1, 1).Select
Set OutApp = Nothing
Set OutNS = Nothing
Set Folder = Nothing
End If
End Sub
I tried different methods found on internet, but nothing worked.
We can do this by first testing if the property exists. If it doesn't and you try to work with it, it will throw an error. Afterwards we can access the value if the property is found.
For Each OutMail In Folder.Items
Sheets(2).Cells(i, 1) = OutMail.EntryID
(etc....)
Sheets(2).Cells(i, 32) = OutMail.ReminderTime
If Not(OutMail.UserProperties.Find("DemandQTY", True) Is Nothing) Then
Sheets(2).Cells(i, 33) = OutMail.UserProperties("DemandQTY").Value
End If
i = i + 1
Next OutMail
I am looking for a way to pull down the information of a different Outlook account into an Excel spreadsheet.
The below code works only for my personal inbox:
Sub psinbox()
Dim olNs As Outlook.Namespace
Dim oltaskfolder As Outlook.MAPIFolder
Dim oltask As Outlook.TaskItem
Dim olitems As Outlook.Items
Dim xlapp As Excel.Application
Dim xlWB As Excel.Workbook
Dim x As Long
Dim arrheaders As Variant
Set olNs = GetNamespace("MAPI")
Set oltaskfolder = olNs.GetDefaultFolder(olFolderInbox)
Set olitems = oltaskfolder.Items
Set xlapp = CreateObject("Excel.Application")
xlapp.Visible = True
Set xlWB = xlapp.Workbooks.Add
x = 2
arrheaders = Array("Date Created", "Date Recieved", "Subject", "Sender",
"Senders Email", "CC", "Sender's Email Type", "MSG Size", "Unread?")
On Error Resume Next
xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrheaders)).Value = ""
Do
With xlWB.Worksheets(1)
If Not (olitems(x).Subject = "" And olitems(x).CreationTime = "") Then
.Range("A1").Resize(1, UBound(arrheaders) + 1) = arrheaders
.Cells(x, 1).Value = olitems(x).CreationTime
.Cells(x, 2).Value = olitems(x).recievedtime
.Cells(x, 3).Value = olitems(x).Subject
.Cells(x, 4).Value = olitems(x).SenderName
.Cells(x, 6).Value = olitems(x).CC
.Cells(x, 7).Value = olitems(x).SenderEmailType ' this is either internal or external server
.Cells(x, 8).Value = Format((olitems(x).Size / 1024) / 1024, "#,##0.00") & " MB"
.Cells(x, 9).Value = olitems(x).UnRead
x = x + 1
End If
End With
Loop Until x >= olitems.Count + 1
Set olNs = Nothing
Set oltaskfolder = Nothing
Set olitems = Nothing
Set xlapp = Nothing
Set xlWB = Nothing
End Sub
I want to record how many received emails are unread.
The closest I found was here Count Read and Unread Emails date wise for shared mailbox , which mentioned that would need to Set c = b.Folders("Name of shared mailbox"), however this appears to be for different folders inside the same mail account. What I am after though is access to two different accounts which outlook has access to?
Edit:
Having tried Niton's example, I am having an issue with the below.
If objOwner.Resolved Then
Set oltaskfolder = olNs.GetSharedDefaultFolder(objOwner,
olFolderInbox).Folders("admin")
Set olitems = oltaskfolder.Items
End If
I have tried to use the user name of the shared inbox, the email address, and the name of the email account, but all bring up the following error.
The answer it seems was to remove a section which caused complications.
If objOwner.Resolved Then
Set oltaskfolder = olNs.GetSharedDefaultFolder(objOwner,
olFolderInbox)
Set olitems = oltaskfolder.Items
End If
Removing .Folders("admin") fixed the error that was coming up and solved the issue. It then gave me the information about the inbox exactly as required.
Edit:
Side note which I just found out, if you do want to have a sub folder in a shared mail box, just add the .Folders("mailbox") next to the olFolderInbox instead like below.
If objOwner.Resolved Then
Set oltaskfolder = olNs.GetSharedDefaultFolder(objOwner,
olFolderInbox).Folders("mailbox")
Set olitems = oltaskfolder.Items
End If
The previous pages did not work adding it next to CreateRecipient ??
I am to write a VBA code that would retrive emails from Outlook based on certain conditions. The problem I have is that I have to denote a certain folder in my code (in the example below the folder denoted is "PRE Costumer". I would like to retrive all emails from my 'inbox' or in better case from all outlook folders. The problem is that my inbox consists of many subfolders (because of rules0. My problem is that I may not know all the subfolders names (as many useres are going to use the macro and even someone can have the e mails in Personal Folders).
Could you please advise is there a way to overcome this problem?
Please let me know if this question is vague (as I am newcomer)
Please find the line that I have probelm with marked with a comment.
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
'Below is the line I have problem with
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
i = 1
x = Date
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
ActiveSheet.Cells(i, 1).Value = olMail.Subject
ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.SenderName
i = i + 1
End If
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Just loop through all the folders in Inbox.
Something like this would work.
Edit1: This will avoid blank rows.
Sub test()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Set ws = Activesheet '~~> or you can be more explicit using the next line
'Set ws = Thisworkbook.Sheets("YourTargetSheet")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
'Debug.Print eFolder.Name
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
If InStr(olMail.Subject, "transactions") > 0 _
And InStr(olMail.ReceivedTime, x) > 0 Then
With ws
lrow = .Range("A" & .Rows.Count).End(xlup).Row
.Range("A" & lrow).Offset(1,0).value = olMail.Subject
.Range("A" & lrow).Offset(1,1).Value = olMail.ReceivedTime
.Range("A" & lrow).Offset(1,2).Value = olMail.SenderName
End With
End If
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
Above takes care of all subfolders in Inbox.
Is this what you're trying?
To fix your error (olFolderInbox is a Outlook only constant, so you need to define it in vba that is not Outlook):
Const olFolderInbox = 6
'...
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Also to prevent missing Reference when run from another computer, I would:
Dim olApp As Object
Dim olNs As Object
Dim Fldr As Object
Dim olMail As Object
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
'...
You might also want to disable ScreenUpdating, then enable it in Excel if you expect a long list.
UPDATE (Solution for all folders from a Root Folder)
I used something slightly different for comparing the dates.
Option Explicit
Private lRow As Long, x As Date, oWS As Worksheet
Sub GetFromInbox()
Const olFolderInbox = 6
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object ' Root folder to start
Dim lCalcMode As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("PRE Customer")
Set oWS = ActiveSheet
x = Date
lRow = 1
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
GetFromFolder oRootFldr
Application.ScreenUpdating = True
Application.Calculation = lCalcMode
Set oWS = Nothing
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub GetFromFolder(oFldr As Object)
Dim oItem As Object, oSubFldr As Object
' Process all mail items in this folder
For Each oItem In oFldr.Items
If TypeName(oItem) = "MailItem" Then
With oItem
If InStr(1, .Subject, "transactions", vbTextCompare) > 0 And DateDiff("d", .ReceivedTime, x) = 0 Then
oWS.Cells(lRow, 1).Value = .Subject
oWS.Cells(lRow, 2).Value = .ReceivedTime
oWS.Cells(lRow, 3).Value = .SenderName
lRow = lRow + 1
End If
End With
End If
Next
' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub