C
Cass
I am trying to get a code for exporting data from an custom outlook
form to
default to export to a certain folder.
I keep getting the message " The Selected Folder Do Not Contain
Contacts" but I know for a fact I have 82 contacts in the folder
Public Folders\All Public Folder\Test. So what am i doing wrong?
Heres the code:
Option Explicit
Sub Auto_Open()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olTest As Outlook.MAPIFolder
Dim olTest2 As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long
Application.ScreenUpdating = False
'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.Folders("Public Folders")
Set olTest = olFolder.Folders("All Public Folders")
Set olTest2 = olTest.Folders("Test")
If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType <> olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)
'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
Cells(1, 1).Value = "Utility"
Cells(1, 2).Value = "City, State & Zip"
Cells(1, 3).Value = "Main Contact"
Cells(1, 4).Value = "Main Phone Number"
Cells(1, 5).Value = "Email Address"
With Range("A1:EV1")
.Font.Bold = True
.Font.ColorIndex = 30
.Font.Size = 11
End With
End With
Set olColItems = olFolder.Items
'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) > 0 Then
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .UserProperties("CityStateZip")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .PrimaryTelephoneNumber
Cells(i, 5).Value = .Email1Address
Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If
Next olItem
With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:EV").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "The list has successfully been updated!", vbInformation
ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub
form to
default to export to a certain folder.
I keep getting the message " The Selected Folder Do Not Contain
Contacts" but I know for a fact I have 82 contacts in the folder
Public Folders\All Public Folder\Test. So what am i doing wrong?
Heres the code:
Option Explicit
Sub Auto_Open()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olTest As Outlook.MAPIFolder
Dim olTest2 As Outlook.MAPIFolder
Dim olColItems As Outlook.Items
Dim olItem As Object
Dim strDummy As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim i As Long
Application.ScreenUpdating = False
'Instantiate the MS Outlook objects.
Set olApp = Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.Folders("Public Folders")
Set olTest = olFolder.Folders("All Public Folders")
Set olTest2 = olTest.Folders("Test")
If olFolder Is Nothing Then
GoTo ExitSub
ElseIf olFolder.DefaultItemType <> olContactItem Then
MsgBox "The selected folder does not contain contacts.",
vbOKOnly
GoTo ExitSub
ElseIf olFolder.Items.Count = 0 Then
MsgBox "No contacts to import.", vbOKOnly
GoTo ExitSub
End If
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1)
'Prepare the targeting worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
Cells(1, 1).Value = "Utility"
Cells(1, 2).Value = "City, State & Zip"
Cells(1, 3).Value = "Main Contact"
Cells(1, 4).Value = "Main Phone Number"
Cells(1, 5).Value = "Email Address"
With Range("A1:EV1")
.Font.Bold = True
.Font.ColorIndex = 30
.Font.Size = 11
End With
End With
Set olColItems = olFolder.Items
'Iterate the collection of contact items.
i = 2
For Each olItem In olColItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.FileAs, strDummy) > 0 Then
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .UserProperties("CityStateZip")
Cells(i, 3).Value = .UserProperties("MainContact")
Cells(i, 4).Value = .PrimaryTelephoneNumber
Cells(i, 5).Value = .Email1Address
Else
Cells(i, 1).Value = .FullName
Cells(i, 2).Value = .HomeAddressStreet
Cells(i, 3).Value = .HomeAddressPostalCode
Cells(i, 4).Value = .HomeAddressCity
Cells(i, 5).Value = .FullName
Cells(i, 6).Value = .Email1Address
End If
End With
i = i + 1
End If
Next olItem
With wsSheet
'Sort the list.
.Range("A2", Cells(2, 6).End(xlDown)).Sort Key1:=Range("A2"), _
Order1:=xlAscending
.Range("A:EV").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "The list has successfully been updated!", vbInformation
ExitSub:
Set olItem = Nothing
Set olColItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub