G
Guest
I am trying to use VBA to write out a file, containing names and telephone
numbers contained in a non-default folder. It is a Contacts folder, in my
"Personal Folder" collection, called Hennepin, which exists as a subfolder
of the default Contacts folder. The routine attempts to write out all names
and business telephone numbers to a file called HennepinFile.txt. If and
when I can get this simple operation to work, I hope to do some more
complicated things with it. Unfortunately, It does not yet work.
I am an end user, not a programmer, and do not yet understand this very
well. The code I have so far is created from samples from this newgroup,
and Sue Mosher's very useful website, OutlookCode.com. It does not run, and
I think I am well out of my depth at this point. I would appreciate any
assistance. Thank you.
*******************************************
This is what I have so far -
*******************************************
' This function is lifted verbatim from Ms. Mosher's website,
www.outlookcode.com
Public Function GetFolder(strFolderPath As String) As MAPIFolder
strFolderPath = "Personal Folders\Contacts\Hennepin"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.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 GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Sub HennepinList()
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim oItm As ContactItem
Dim ContactName As String
Dim FS As Object
Dim mynewfile As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set mynewfile = FS.CreateTextFile("c:\temp\Hennepinfile.txt", True)
Set oApp = CreateObject("Outlook.Application")
Set oNspc = oApp.GetNamespace("MAPI")
' the lines below are currently where the problem is
For Each oItm In oNspc.GetFolder _
(olFolderContacts).Items
If Not oItm.BusinessTelephoneNumber = "" Then
ContactName = oItm.FileAs
ContactName = ContactName + " " + oItm.BusinessTelephoneNumber
mynewfile.writeline (ContactName)
End If
Next oItm
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
mynewfile.Close
End Sub
numbers contained in a non-default folder. It is a Contacts folder, in my
"Personal Folder" collection, called Hennepin, which exists as a subfolder
of the default Contacts folder. The routine attempts to write out all names
and business telephone numbers to a file called HennepinFile.txt. If and
when I can get this simple operation to work, I hope to do some more
complicated things with it. Unfortunately, It does not yet work.
I am an end user, not a programmer, and do not yet understand this very
well. The code I have so far is created from samples from this newgroup,
and Sue Mosher's very useful website, OutlookCode.com. It does not run, and
I think I am well out of my depth at this point. I would appreciate any
assistance. Thank you.
*******************************************
This is what I have so far -
*******************************************
' This function is lifted verbatim from Ms. Mosher's website,
www.outlookcode.com
Public Function GetFolder(strFolderPath As String) As MAPIFolder
strFolderPath = "Personal Folders\Contacts\Hennepin"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.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 GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Sub HennepinList()
Dim oApp As Outlook.Application
Dim oNspc As NameSpace
Dim oItm As ContactItem
Dim ContactName As String
Dim FS As Object
Dim mynewfile As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set mynewfile = FS.CreateTextFile("c:\temp\Hennepinfile.txt", True)
Set oApp = CreateObject("Outlook.Application")
Set oNspc = oApp.GetNamespace("MAPI")
' the lines below are currently where the problem is
For Each oItm In oNspc.GetFolder _
(olFolderContacts).Items
If Not oItm.BusinessTelephoneNumber = "" Then
ContactName = oItm.FileAs
ContactName = ContactName + " " + oItm.BusinessTelephoneNumber
mynewfile.writeline (ContactName)
End If
Next oItm
Set oItm = Nothing
Set oNspc = Nothing
Set oApp = Nothing
mynewfile.Close
End Sub