Outlook 2010 GAL with Excel VBA - vba

I have the following code to get contacts out of Outlook from Excel:
Public Sub GetGAL()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Items
Dim olContact As Outlook.ContactItem
Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderContacts).Items
For Each olContact In olFldr
Debug.Print olContact.FullName
Next olContact
End
End Sub
It is failing on this line saying there is a type mismatch:
For Each olContact In olFldr
Does anyone know why this is?
Also, how do I access the GAL as opposed to just my own contacts?
Thanks for any help.
Edit: Here's my new code to access the addressEntry and ExchangeUser, however, not the country field yet:
Option Explicit
Public Sub GetGAL()
Application.ScreenUpdating = False
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olGAL As Outlook.addressEntries
Dim olAddressEntry As Outlook.addressEntry
Dim olUser As Outlook.ExchangeUser
Dim i As Long
'Dim sTemp As String
'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
Set olApp = CreateObject("Outlook.Application.14")
Set olNs = olApp.GetNamespace("MAPI")
Set olGAL = olNs.addressLists("Global Address List").addressEntries
'On Error Resume Next
For i = 1 To olGAL.Count
Set olAddressEntry = olGAL.Item(i)
If olAddressEntry.DisplayType = olRemoteUser Then
Set olUser = olAddressEntry.GetExchangeUser
'Debug.Print olUser.Name & ";" & olUser.StateOrProvince
'Debug.Print sTemp
'ws.Cells(i, 1) = olUser.Name
'ws.Cells(i, 2) = olUser.StateOrProvince
End If
Next i
End
Application.ScreenUpdating = True
End Sub

Give this a try. Although if you have tons and tons of entries in your GAL, it will take awhile to complete, and you may have to increase the 65000.
Sub tgr()
Dim appOL As Object
Dim oGAL As Object
Dim oContact As Object
Dim oUser As Object
Dim arrUsers(1 To 65000, 1 To 2) As String
Dim UserIndex As Long
Dim i As Long
Set appOL = CreateObject("Outlook.Application")
Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries
For i = 1 To oGAL.Count
Set oContact = oGAL.Item(i)
If oContact.AddressEntryUserType = 0 Then
Set oUser = oContact.GetExchangeUser
If Len(oUser.lastname) > 0 Then
UserIndex = UserIndex + 1
arrUsers(UserIndex, 1) = oUser.Name
arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress
End If
End If
Next i
appOL.Quit
If UserIndex > 0 Then
Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
End If
Set appOL = Nothing
Set oGAL = Nothing
Set oContact = Nothing
Set oUser = Nothing
Erase arrUsers
End Sub

Your code assumes that you can only have ContactItem objects in the folder. It will break if you encounter an object of type DistListItem.
Declare the item variable as a generic Object, then check the Class property (exposed by all Outlook objects) or use TypeName function to figure out the exact item type.
EDIT: PR_BUSINESS_ADDRESS_COUNTRY DASL name is "http://schemas.microsoft.com/mapi/proptag/0x3A26001F"
For address entries you can see the DASS property names in OutlookSpy (I am its author). For example, you can click IMAPISession button, click QueryIdentity, select a property, look at the DASL edit box.

Related

Folder path to enterprise vault using VBA for email migration

I have a long list of folders and to many rules for outlook to handle using the standard rules manager. I wrote code that would classify and move items to folders but recently I was migrated to an Enterprise Vault. I am trying to find the folder path to update my code. I tried something like
Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")
but honestly I have no idea what the correct path should be. Everything I find online deals with pulling selected items out of the vault and not moving items into it. Below is an excerpt of the existing code. This is on Office 365/Outlook 2016.
Sub Sort_Test(Item)
Dim Msg As Object
Dim Appt As Object
Dim Meet As Object
Dim olApp As Object
Dim objNS As Object
Dim targetFolder As Object
On Error GoTo ErrorHandler
Set Msg = Item
Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
checksub = Msg.Subject
checksend = Msg.Sender
checksendname = Msg.SenderName
checksendemail = Msg.SenderEmailAddress
checkbod = Msg.Body
checkto = Msg.To
checkbcc = Msg.BCC
checkcc = Msg.CC
checkcreation = Msg.CreationTime
checksize = Msg.Size
'Classes Folder
If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
Or checksend Like "*Award*eBooks*" Then
Set targetFolder = PST.Folders("Education").Folders("Classes")
Msg.Move targetFolder
GoTo ProgramExit
End If
If targetFolder Is Nothing Then
GoTo ProgramExit
' Else
' Msg.Move targetFolder
End If
' Set olApp = Nothing
' Set objNS = Nothing
Set targetFolder = Nothing
Set checksub = Nothing
Set checksend = Nothing
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Try this code:
Sub MoveToFolder()
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")
For M = 1 To olArcFolder.items.Count
Set myItem = olArcFolder.items(M)
myItem.Display
Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
Set myCopiedInspectors = myInspectors.copy
myCopiedInspectors.Move olCompFolder
myInspectors.Close olDiscard
Next M
Here is a link for you reference:
Do for all open emails and move to a folder

Count folders and subfolders in Sharedmailbox

i Would like to know if i can count folders and subfolders in sharedmailbox ;
Here is some code that im using , but it works only for my default mail account.
is there a way to modify it to get the number of subfolders in the folder "Test" from my shared mailbox name's (AJ47 BOX)
Private Sub CommandButton1_Click()
Dim outapp As Outlook.Application
Set outapp = CreateObject("Outlook.Application")
Dim olNs As Outlook.NameSpace
Set olNs = outapp.GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
TextBox1 = GetSubFolderCount(olNs.GetDefaultFolder(olFolderInbox).Folders("Tmp"))
End Sub
Private Function GetSubFolderCount(objParentFolder As MAPIFolder) As Long
Dim currentFolders As Folders
Dim fldCurrent As MAPIFolder
Set currentFolders = objParentFolder.Folders
If currentFolders.Count > 0 Then
Set fldCurrent = currentFolders.GetFirst
While Not fldCurrent Is Nothing
TempFolderCount = TempFolderCount + GetSubFolderCount(fldCurrent)
Set fldCurrent = currentFolders.GetNext
Wend
GetSubFolderCount = TempFolderCount + currentFolders.Count
Else
GetSubFolderCount = 0
End If
End Function
Use GetSharedDefaultFolder Method
Example
Dim olRecip As Recipient
Set olRecip = olNs.CreateRecipient("om3r#email.com") '// Owner's Name or email address
TextBox1 = GetSubFolderCount(olNs.GetSharedDefaultFolder(olRecip, olFolderInbox).Folders("Test"))

Outlook 2013 VBA Getting required data from Global Address List

I am using Outlook VBA codes to find a specific Email address by the unique job title in the Global Address List. I have the code below, but I am not sure how I can rope the identifying of specific Email address in. I am using this as a Function so that I can call it in the Subroutine.
I keep getting the error "Object variable or With block variable not set", but I don't know how I can edit in the code to remove the error. I get the error at this line: "Set olUser = olAddressEntry.GetExchangeUser".
Function GALEmail(specificTitle As String) As String
Dim olNs As Outlook.NameSpace
Dim olGAL As Outlook.AddressEntries
Dim olAddressEntry As Object
Dim olUser As Object
Dim sEmail As String
Dim i As Long
Dim GetCurrentItem As Object
Set olNs = Application.GetNamespace("MAPI")
Set olGAL = olNs.AddressLists("Global Address List").AddressEntries
Set GetCurrentItem = Application.ActiveInspector.currentItem
Set olUser = Nothing
'On Error Resume Next
With GetCurrentItem
For i = 1 To olGAL.Count
Set olAddressEntry = olGAL.Item(i)
Set olUser = olAddressEntry.GetExchangeUser
MsgBox olUser
sEmail = olGAL.Item(i).Title
If sEmail = specificTitle Then
Set olUser = olAddressEntry.GetExchangeUser
Debug.Print olUser.Email1Address
End If
Next i
End With
End Function
Any help would be greatly appreciated!!
I have figured how to get the Email Address with the job title as shown below:
Function GALEmail(specificTitle As String) As String
Dim olNs As Outlook.NameSpace
Dim olGAL As Object
Dim olAddressEntry As Object
Dim olUser As Object
Dim sEmail As String
Dim i As Long
Dim GetCurrentItem As Object
Set olNs = Application.GetNamespace("MAPI")
Set olGAL = olNs.AddressLists("Global Address List").AddressEntries
Set GetCurrentItem = Application.ActiveInspector.currentItem
'On Error Resume Next
With GetCurrentItem
For i = 1 To olGAL.Count
Set olAddressEntry = olGAL.Item(i)
If olAddressEntry.AddressEntryUserType = 0 Then
Set olUser = olAddressEntry.GetExchangeUser
sEmail = olUser.JobTitle
If sEmail = specificTitle Then
GALEmail = olUser.PrimarySmtpAddress
End If
End If
Next i
End With
End Function

Searching Outlook Folder

I want to search a specific Outlook folder using an activecell value.
I tried Excel VBA for searching in mails of Outlook and VBA Search in Outlook.
The closest I was able to get:
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim OutlookSearch as string
Outlooksearch = Cstr(Activecell.cells(1,4).Value)
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "sketch") > 0 Then
Debug.Print "Found"
Found = True
End If
End If
Next myitem
'If the subject isn't found:
If Not Found Then
MsgBox "Cannot find"
End If
myOlApp.Quit
Set myOlApp = Nothing
I want to use the string in Activecell.cells(1, 4) as the subject for a search in a specific Outlook folder in the inbox.
I get is the MsgBox even if I've sent an email containing values that match with activecell.
You can specify the folder to search in, within the inbox, by using the .Folders property.
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("myFolder")
I've had a play around and come up with the code below. No need to set references to Outlook.
Sub Test1()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim cFolder As Object
Dim oItem As Object
Dim oMyItem As Object
Dim sOutlookSearch As String
Dim aFolders() As String
Dim i As Long
'sOutlookSearch needs to be something like:
'"Mailbox - Darren Bartrup-Cook\Inbox"
sOutlookSearch = ThisWorkbook.Worksheets("Sheet1").Cells(1, 4)
sOutlookSearch = Replace(sOutlookSearch, "/", "\")
aFolders() = Split(sOutlookSearch, "\")
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.Folders.Item(aFolders(0))
If Not mFolderSelected Is Nothing Then
For i = 1 To UBound(aFolders)
Set cFolder = mFolderSelected.Folders
Set mFolderSelected = Nothing
Set mFolderSelected = cFolder.Item(aFolders(i))
If mFolderSelected Is Nothing Then
Exit For
End If
Next i
End If
'Set mFolderSelected = nNameSpace.PickFolder 'Alternative to above code block - just pick the folder.
For Each oItem In mFolderSelected.items
If oItem.class = 43 Then '43 = olmail
If InStr(1, oItem.Subject, "sketch") > 0 Then
Debug.Print "Found: " & oItem.sendername
Exit For
End If
End If
Next oItem
End Sub
The code block for finding the correct folder was taken from here:
http://www.outlookcode.com/d/code/getfolder.htm

Run time error 13 on for-each loop after a few items

I am trying to list all email in Excel within all sub folders from Outlook:
I have searched and researched this for weeks without any luck.
'Requires reference to Outlook library
Option Explicit
Public Sub ListOutlookFolders()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim rngOutput As Range
Dim lngCol As Long
Dim olItem As Outlook.MailItem
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Set rngOutput = ActiveSheet.Range("A1")
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
For Each olFolder In olNamespace.Folders
rngOutput = olFolder.Name
rngOutput.Offset(0, 1) = olFolder.Description
Set rngOutput = rngOutput.Offset(1)
For Each olItem In olFolder.Items
Set rngOutput = rngOutput.Offset(1)
With rngOutput
.Offset(0, 1) = olItem.SenderEmailAddress ' Sender
End With
Next
Set rngOutput = ListFolders(olFolder, 1, rngOutput)
Next
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub
Function ListFolders(MyFolder As Outlook.MAPIFolder, Level As Integer, theOutput As Range) As Range
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Outlook.MailItem
Dim lngCol As Long
For Each olFolder In MyFolder.Folders
theOutput.Offset(0, lngCol) = olFolder.Name
Set theOutput = theOutput.Offset(1)
If (olFolder.DefaultItemType = olMailItem) And (Not olFolder.Name = "Slettet post") Then
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
With theOutput
.Offset(0, 1) = olItem.SenderEmailAddress ' Sender
End With
Set theOutput = theOutput.Offset(1)
End If
Next olItem <--- ERROR 13 here
End If
If olFolder.Folders.Count > 0 Then
Set theOutput = ListFolders(olFolder, Level + 1, theOutput)
End If
Next olFolder
Set ListFolders = theOutput.Offset(1)
End Function
The code runs fine for 10-20 items and then gives me an run time error 13 in the line stated above and when I hit debug it tells me that olItem is = Nothing !? - When I hit single step the code runs again fine for a while again.
I have tried to insert a "ON ERROR" but then my list doesn't contain all emails.
I'm baring my code to you :)
Change
Dim olItem As Outlook.MailItem
to
Dim olItem As Object
Not all the folder items will be mailitems, so avoid dimensioning your olItem variable in this manner. This change worked fine on my machine, while originally I had the same error you did