Add multiple contacts to outlook - from access table

[Moss100]

Hello I need help in how to add multiple contacts to outlook (contacts are in an access table tblContact)

I have code for enetering one, but can not seem to get it to work with record set and loop. Could someone help create a function to add all records from tblContacts. Thank you

Sub AddAContact()
Dim myOutlook As Outlook.Application
Dim myItems As ContactItem

Set myOutlook = CreateObject("Outlook.Application")
Set myItems = myOutlook.CreateItem(olContactItem)

With myItems
.FirstName = "John"
.LastName = "Smith"
.Email1Address = "j@yourserver.com"
.Save
End With
End Sub

 

[Moss100]

Ive tried below, but no luck

Dim myOutlook As Outlook.Application
Dim myItems As ContactItem

Set myOutlook = CreateObject("Outlook.Application")
Set myItems = myOutlook.CreateItem(olContactItem)

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblContactDetails")

'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst 'Unnecessary in this case, but still a good habit
Do Until rs.EOF = True

With myItems
.FirstName = rs("ContactName")
.Save


'Move to the next record. Don't ever forget to do this.
rs.MoveNext
End With
Loop
Else
MsgBox "There are no records in the recordset."
End If

MsgBox "Finished looping through records."

rs.Close 'Close the recordset
Set rs = Nothing 'Clean up

 

[Andrzejek]

no luck" is a very vague expression... Any errors? Are you getting any records from your DB? What doesn't work? What does?

And, it would be nice to have your code formatted as CODE in your posts.

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[Moss100]

Hello thank you for your help as ever.

I don't know why it does not format as code, when i paste it into the code (as usual), it just displays as blank in the preview.

I want it to loop through the recordset, but it only adds the first record. Sorry the code wont format.


Dim myOutlook As Outlook.Application
Dim myItems As ContactItem

Set myOutlook = CreateObject("Outlook.Application")
Set myItems = myOutlook.CreateItem(olContactItem)

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblContactDetails")

MsgBox rs.RecordCount
Exit Sub


'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
rs.MoveLast
rs.MoveFirst

Do Until rs.EOF()

With myItems
.FirstName = rs("ContactName")
.Save

'Move to the next record. Don't ever forget to do this.
End With
rs.MoveNext


Loop
Else
MsgBox "There are no records in the recordset."
End If

MsgBox "Finished looping through records."

rs.Close 'Close the recordset
Set rs = Nothing 'Clean up

 

[Moss100]

 

[Andrzejek]

Let's see...

Dim myOutlook As Outlook.Application
Dim myItems As ContactItem

Set myOutlook = CreateObject("Outlook.Application")
Set myItems = myOutlook.CreateItem(olContactItem)

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblContactDetails")

MsgBox rs.RecordCount
[green]'Exit Sub

'Check to see if the recordset actually contains rows[/green]
If Not (rs.EOF And rs.BOF) Then
    rs.MoveLast
    rs.MoveFirst

    Do Until rs.EOF()
        With myItems
            .FirstName = rs("ContactName")
            .Save
            [green]'Move to the next record. Don't ever forget to do this.[/green]
        End With
        rs.MoveNext
    Loop
Else
    MsgBox "There are no records in the recordset."
End If

MsgBox "Finished looping through records."

rs.Close [green]'Close the recordset[/green]
Set rs = Nothing 'Clean up

Must be something wrong with your browser... :-(

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[Moss100]

Mr browser and my code

 

[Andrzejek]

So if you step thru this code:

...
    Do Until rs.EOF()
        With myItems[blue]
            MsgBox "First Name to be added: " & rs("ContactName")[/blue]
            .FirstName = rs("ContactName")
            .Save
        End With [green]
        'Move to the next record. Don't ever forget to do this.[/green]
        rs.MoveNext
    Loop
...

ONLY first record gets saved in Outlook, and all other records are ignored?

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[Moss100]

Yes that’s correct. Thank you.

 

[Moss100]

I’ve just asked the Ai GBT to write me the code for it and it came back almost instantly with the following - I’ll give it a try tomorrow.

 

[Moss100]

Sub PopulateOutlookContacts()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olContact As Outlook.ContactItem

' Set up Outlook objects
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderContacts)

' Open Access database
Set db = OpenDatabase("C:\Path\To\Your\Database.accdb")

' Open table or query containing contacts
Set rs = db.OpenRecordset("YourTableOrQueryName")

' Loop through records and add contacts to Outlook
Do Until rs.EOF
Set olContact = olFolder.Items.Add(olContactItem)

' Set contact properties
olContact.FirstName = rs("FirstName")
olContact.LastName = rs("LastName")
olContact.Email1Address = rs("Email")
' Add more properties as needed

' Save and move to the next record
olContact.Save
rs.MoveNext
Loop

' Clean up objects
rs.Close
Set rs = Nothing
Set db = Nothing

' Display a message when the process is complete
MsgBox "Contacts have been populated in Outlook.", vbInformation
End Sub

 

[Andrzejek]

Did it work

---- Andy

"Hmm...they have the internet on computers now"--Homer Simpson

 

[Moss100]

It did - thank you for your help as always. Mark