By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
446,326 Members | 1,938 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 446,326 IT Pros & Developers. It's quick & easy.

Access to Outlook Contacts

P: n/a
I have a Yacht Club Db with names addresse phone nos, emails etc.

I want to export them to Outlook. No problem in getting them into the
contact folder.

My problem is I have a folder within the contact folder called "Yacht Club"
How do I change the "active folder" from Contacts to "Yacht Club"

Existing code here:

Query 1 is a query containing the members with name field of "Name" and
email field "MemEMail"
Option Compare Database
Option Explicit

Public Function AccessToOutlook(DBName As String, TabName As String, _
Contact As String, Email As String, OFolder As String)

'?AccessToOutlook(CurrentDb.Name,"Query1", "Name", "MemEmail", "Yacht
Club")
Const ERR_TABLE_NOT_FOUND = 3078
Const ERR_FIELD_NOT_FOUND = 3265
Const ERR_ATTACHED_TABLE_NOT_FOUND = 3024
Const ERR_INVALID_ATTACHED_TABLE_PATH = 3044
Const Message_Caption = "XXXXX"
Dim WS As Workspace
Dim Db As Database
Dim tblContacts As Recordset
Dim oOutlook As Outlook.Application
Dim MyTable As TableDef
Dim MyQuery As QueryDef
Dim Fld As Field
Dim ContactFound As Boolean, EMailFound As Boolean
Dim strMessage As String
Dim i As Integer, ContactField As Integer, EMailField As Integer,
FolderNo As Integer
Dim MyFolder As MAPIFolder, MyOwnFolder As MAPIFolder
On Error GoTo ERR_ExportContactsTable
' Open the table. Dim tblContacts As Recordset

Set WS = DBEngine.Workspaces(0)
Set Db = WS.OpenDatabase(DBName)

' Check that the designated fields exist
Set MyTable = Db.TableDefs(TabName)
For i = 0 To MyTable.Fields.Count - 1
If MyTable.Fields(i).Name = Contact Then
ContactFound = True
ContactField = i
End If
If MyTable.Fields(i).Name = Email Then
EMailFound = True
EMailField = i
End If
Next i
GoTo AllOK

IsItAQuery:
Set MyQuery = Db.QueryDefs(TabName)
For i = 0 To MyQuery.Fields.Count - 1
If MyQuery.Fields(i).Name = Contact Then
ContactFound = True
ContactField = i
End If
If MyQuery.Fields(i).Name = Email Then
EMailFound = True
EMailField = i
End If
Next i
AllOK:
If ContactFound = False Then
MsgBox "The Contact field called " & Contact & " does not exist",
vbCritical
Exit Function
End If
If EMailFound = False Then
MsgBox "The EMail field called " & Email & " does not exist",
vbCritical
Exit Function
End If

'Open the table
Set tblContacts = Db.OpenRecordset(TabName)

' Open Outlook Dim oOutlook As OutLook.Application
Set oOutlook = CreateObject("Outlook.Application")
Dim olNS As Outlook.NameSpace

Set olNS = oOutlook.GetNamespace("MAPI")
For i = 1 To olNS.AddressLists.Count
If olNS.AddressLists(i).Name = OFolder Then
FolderNo = i
GoTo AddAddress
End If
Next i

MsgBox "The EMail address folder called " & OFolder, vbCritical
Exit Function

AddAddress:
Set MyFolder = olNS.GetDefaultFolder(olFolderContacts)
Set MyOwnFolder = MyFolder.Folders(OFolder)

olNS.GetFolderFromID (MyFolder.EntryID)

'''''DistListItem'''''''''''''''''''''''

MyOwnFolder.Display
olNS.Logon
' Get a reference to the Items collection of the contacts folder.
Dim colItems As Outlook.ContactItem ' Load Contacts From DBF
Do Until tblContacts.EOF
If Nz(tblContacts.Fields(EMailField)) "" Then
Set colItems = oOutlook.CreateItem(olContactItem)
With colItems
.FullName = tblContacts.Fields(ContactField)
.Email1Address =
Trim(LCase(tblContacts.Fields(EMailField)))
.Email1AddressType = "SMTP"
.Save
.Display
End With

' Load email addresses into Contacts Address Book
Dim Menu As Object
Dim Command As Object
Set Menu = oOutlook.ActiveInspector.CommandBars("Tools")
Set Command = Menu.Controls("Check Names")
Command.Execute

Set Menu = oOutlook.ActiveInspector.CommandBars("File")
Set Command = Menu.Controls("Save")
Command.Execute

Set Command = Menu.Controls("Close")
Command.Execute
Set colItems = Nothing
End If
tblContacts.MoveNext
Loop

tblContacts.Close
Set tblContacts = Nothing
olNS.Logoff
Set olNS = Nothing
Set oOutlook = Nothing
strMessage = "Your contacts have been successfully imported."
MsgBox strMessage, vbOKOnly, Message_Caption

Exit_ExportContactsTable:
On Error Resume Next
Exit Function

ERR_ExportContactsTable:
Select Case Err
Case ERR_TABLE_NOT_FOUND
strMessage = "Cannot find table!"
MsgBox strMessage, vbCritical, Message_Caption
Resume Exit_ExportContactsTable

'These errors occur if an attached table is moved or deleted
'or if the path to the table file is no longer valid.
Case ERR_ATTACHED_TABLE_NOT_FOUND, ERR_INVALID_ATTACHED_TABLE_PATH
strMessage = "Cannot find attached table!"
MsgBox strMessage, vbCritical, Message_Caption
Resume Exit_ExportContactsTable

'If a field in the code does not match a field in the table
'then move on to the next field.
Case ERR_FIELD_NOT_FOUND
Resume IsItAQuery

Case Else
strMessage = "An unexpected error has occured. Error#" & Err & ": "
& Error
MsgBox strMessage, vbCritical, Message_Caption
Resume Exit_ExportContactsTable
End Select

End Function

Thanks

Phil
Dec 8 '06 #1
Share this Question
Share on Google+
1 Reply


P: n/a
On Fri, 8 Dec 2006 01:59:30 -0000, "Phil Stanton"
<ph**@stantonfamily.co.ukwrote:

General comment (I didn't study each line of your code): each folder
has an ID value. You can find the values using this GREAT tool:
http://www.dimastr.com/outspy/ A must for the serious Outlook
programmer.
Otherwise that ID can probably be found with either a loop or some
FindByName function or some such.
So rather than GetDefaultFolder, you would call GetFolderByName (I'm
making this up) or some such.
The rest of your code (add items) should stay the same.

-Tom.
>I have a Yacht Club Db with names addresse phone nos, emails etc.

I want to export them to Outlook. No problem in getting them into the
contact folder.

My problem is I have a folder within the contact folder called "Yacht Club"
How do I change the "active folder" from Contacts to "Yacht Club"

Existing code here:

Query 1 is a query containing the members with name field of "Name" and
email field "MemEMail"
Option Compare Database
Option Explicit

Public Function AccessToOutlook(DBName As String, TabName As String, _
Contact As String, Email As String, OFolder As String)

'?AccessToOutlook(CurrentDb.Name,"Query1", "Name", "MemEmail", "Yacht
Club")
Const ERR_TABLE_NOT_FOUND = 3078
Const ERR_FIELD_NOT_FOUND = 3265
Const ERR_ATTACHED_TABLE_NOT_FOUND = 3024
Const ERR_INVALID_ATTACHED_TABLE_PATH = 3044
Const Message_Caption = "XXXXX"
Dim WS As Workspace
Dim Db As Database
Dim tblContacts As Recordset
Dim oOutlook As Outlook.Application
Dim MyTable As TableDef
Dim MyQuery As QueryDef
Dim Fld As Field
Dim ContactFound As Boolean, EMailFound As Boolean
Dim strMessage As String
Dim i As Integer, ContactField As Integer, EMailField As Integer,
FolderNo As Integer
Dim MyFolder As MAPIFolder, MyOwnFolder As MAPIFolder
On Error GoTo ERR_ExportContactsTable
' Open the table. Dim tblContacts As Recordset

Set WS = DBEngine.Workspaces(0)
Set Db = WS.OpenDatabase(DBName)

' Check that the designated fields exist
Set MyTable = Db.TableDefs(TabName)
For i = 0 To MyTable.Fields.Count - 1
If MyTable.Fields(i).Name = Contact Then
ContactFound = True
ContactField = i
End If
If MyTable.Fields(i).Name = Email Then
EMailFound = True
EMailField = i
End If
Next i
GoTo AllOK

IsItAQuery:
Set MyQuery = Db.QueryDefs(TabName)
For i = 0 To MyQuery.Fields.Count - 1
If MyQuery.Fields(i).Name = Contact Then
ContactFound = True
ContactField = i
End If
If MyQuery.Fields(i).Name = Email Then
EMailFound = True
EMailField = i
End If
Next i
AllOK:
If ContactFound = False Then
MsgBox "The Contact field called " & Contact & " does not exist",
vbCritical
Exit Function
End If
If EMailFound = False Then
MsgBox "The EMail field called " & Email & " does not exist",
vbCritical
Exit Function
End If

'Open the table
Set tblContacts = Db.OpenRecordset(TabName)

' Open Outlook Dim oOutlook As OutLook.Application
Set oOutlook = CreateObject("Outlook.Application")
Dim olNS As Outlook.NameSpace

Set olNS = oOutlook.GetNamespace("MAPI")
For i = 1 To olNS.AddressLists.Count
If olNS.AddressLists(i).Name = OFolder Then
FolderNo = i
GoTo AddAddress
End If
Next i

MsgBox "The EMail address folder called " & OFolder, vbCritical
Exit Function

AddAddress:
Set MyFolder = olNS.GetDefaultFolder(olFolderContacts)
Set MyOwnFolder = MyFolder.Folders(OFolder)

olNS.GetFolderFromID (MyFolder.EntryID)

'''''DistListItem'''''''''''''''''''''''

MyOwnFolder.Display
olNS.Logon
' Get a reference to the Items collection of the contacts folder.
Dim colItems As Outlook.ContactItem ' Load Contacts From DBF
Do Until tblContacts.EOF
If Nz(tblContacts.Fields(EMailField)) "" Then
Set colItems = oOutlook.CreateItem(olContactItem)
With colItems
.FullName = tblContacts.Fields(ContactField)
.Email1Address =
Trim(LCase(tblContacts.Fields(EMailField)))
.Email1AddressType = "SMTP"
.Save
.Display
End With

' Load email addresses into Contacts Address Book
Dim Menu As Object
Dim Command As Object
Set Menu = oOutlook.ActiveInspector.CommandBars("Tools")
Set Command = Menu.Controls("Check Names")
Command.Execute

Set Menu = oOutlook.ActiveInspector.CommandBars("File")
Set Command = Menu.Controls("Save")
Command.Execute

Set Command = Menu.Controls("Close")
Command.Execute
Set colItems = Nothing
End If
tblContacts.MoveNext
Loop

tblContacts.Close
Set tblContacts = Nothing
olNS.Logoff
Set olNS = Nothing
Set oOutlook = Nothing
strMessage = "Your contacts have been successfully imported."
MsgBox strMessage, vbOKOnly, Message_Caption

Exit_ExportContactsTable:
On Error Resume Next
Exit Function

ERR_ExportContactsTable:
Select Case Err
Case ERR_TABLE_NOT_FOUND
strMessage = "Cannot find table!"
MsgBox strMessage, vbCritical, Message_Caption
Resume Exit_ExportContactsTable

'These errors occur if an attached table is moved or deleted
'or if the path to the table file is no longer valid.
Case ERR_ATTACHED_TABLE_NOT_FOUND, ERR_INVALID_ATTACHED_TABLE_PATH
strMessage = "Cannot find attached table!"
MsgBox strMessage, vbCritical, Message_Caption
Resume Exit_ExportContactsTable

'If a field in the code does not match a field in the table
'then move on to the next field.
Case ERR_FIELD_NOT_FOUND
Resume IsItAQuery

Case Else
strMessage = "An unexpected error has occured. Error#" & Err & ": "
& Error
MsgBox strMessage, vbCritical, Message_Caption
Resume Exit_ExportContactsTable
End Select

End Function

Thanks

Phil
Dec 8 '06 #2

This discussion thread is closed

Replies have been disabled for this discussion.