Export Access data to specific group in shared Outlook mailbox

[MXQ]

Hello my friends,
I have an Access form whose data I would like to export to some groups within the Outlook contacts of a shared mailbox. The following VBA code gives me a runtime error 13 (type mismatch) on row 19 (Next)

Dim MyOutlook As Outlook.Application
Dim KontaktOutlook As Outlook.ContactItem
Dim SharedMailboxName As String
Dim SharedContactsFolder As Outlook.Folder
Dim MemberGroup As Outlook.DistListItem
Dim TeamGroup As Outlook.DistListItem
Dim olDistributionList As Outlook.OlItemType

SharedMailboxName = "shared.mail@example.com"

Set MyOutlook = CreateObject("Outlook.Application")
Set SharedContactsFolder = MyOutlook.Session.Folders(SharedMailboxName).Folders("Contacts")

' Get the Member group
For Each MemberGroup In SharedContactsFolder.Items
    If MemberGroup.Class = olDistributionList And MemberGroup.DLName = "Member" Then
        Exit For
    End If
Next

' Get the group defined under .JobTitle
For Each TeamGroup In SharedContactsFolder.Items
    If TeamGroup.Class = olDistributionList And TeamGroup.GroupName = Nz(Me!txtTeam) Then
        Exit For
    End If
Next

' Insert the textbox values from the form
Set KontaktOutlook = SharedContactsFolder.Items.Add(olContactItem)
With KontaktOutlook
    .FirstName = Nz(Me![First Name])
    .LastName = Nz(Me![Last Name])
    .CompanyName = "Member"
    .JobTitle = Nz(Me!txtTeam)
    .HomeAddressStreet = Nz(Me!Address)
    .HomeAddressCity = Nz(Me!City)
    .HomeAddressPostalCode = Nz(Me!ZIP)
    .BusinessTelephoneNumber = Nz(Me![Business Phone])
    .HomeTelephoneNumber = Nz(Me![Home Phone])
    .MobileTelephoneNumber = Nz(Me![Mobile Phone])
    .Email1Address = Nz(Me![E-mail Address])
    If Not IsNull(Me!Birthday) Then
        .Birthday = Me!Birthday
    End If
    .Save
    .AddToGroup MemberGroup
    .AddToGroup TeamGroup
End With

Set KontaktOutlook = Nothing
Set MyOutlook = Nothing

MsgBox "Contact saved in Outlook"

Could somebody give me a hint where I made the mistake or how to solve that problem? Thank you in advance!

[Gicu]

Try to declare the MemberGroup as Outlook.Items instead of DistListItem:
https://learn.microsoft.com/en-us/of...item.getmember
Cheers,

[MXQ]

Thank you for the fast answer Vlad.
I tried your recommendation and I also tried to declare it as Object but got the same error 13. Dunno what to try further!?
Cheers back.

[MXQ]

At last, after some time of experimenting, I could finally solve the problem.
I found the following link from forum member June7 that helped me a lot:
How to get access to Contact Group folder in Outlook

in this thread:
can I create/update an Outlook email group from my Access data?

Now I was able to achieve my goal and to save the contact in the Member group and in the group defined under the combobox txtTeam with one mouse click.
The complete and working code now is as follows:

Private Sub cmdSaveAsOutlookContact_Click()
'Declare variables for Outlook objects
Dim olNS As Outlook.NameSpace
Dim olContactFolder As Outlook.MAPIFolder
Dim olTeamGroup As Outlook.MAPIFolder
Dim olMemberGroup As Outlook.MAPIFolder
Dim olTeamContact As Outlook.ContactItem
Dim olMemberContact As Outlook.ContactItem
Dim olTeamItems As Outlook.Items
Dim olMemberItems As Outlook.Items

'Name of shared mailbox
SharedMailboxName = "shared.mail@example.com"

'Error handling
On Error Resume Next

'Get the Outlook namespace and the contact folder in the shared mailbox
Set olNS = GetNamespace("MAPI")
Set olContactFolder = olNS.Folders(SharedMailboxName).Folders("Contacts")

'Check the value of the txtTeam field and set the corresponding Team group folder
If Nz(Me!txtTeam) = "FG 1" Then
Set olTeamGroup = olContactFolder.Folders("FG 1")
ElseIf Nz(Me!txtTeam) = "FG 2" Then
Set olTeamGroup = olContactFolder.Folders("FG 2")
ElseIf Nz(Me!txtTeam) = "FG 3" Then
Set olTeamGroup = olContactFolder.Folders("FG 3")
ElseIf Nz(Me!txtTeam) = "FG 4 Digital" Then
Set olTeamGroup = olContactFolder.Folders("FG 4 Digital")
End If

'Get the Member group folder
Set olMemberGroup = olContactFolder.Folders("Member")

' Check if contact already exists in Team folder
email = Nz(Me![E-mail Address])
If Not olTeamGroup Is Nothing Then
Set olTeamItems = olTeamGroup.Items
For Each olTeamContact In olTeamItems
If olTeamContact.Class = olContact And olTeamContact.Email1Address = email Then
MsgBox "Contact already exists in the '" & Nz(Me!txtTeam) & "' Group."
Exit Sub
End If
Next
End If

' Check if contact already exists in Member folder
If Not olMemberGroup Is Nothing Then
Set olMemberItems = olMemberGroup.Items
For Each olMemberContact In olMemberItems
If olMemberContact.Class = olContact And olMemberContact.Email1Address = email Then
MsgBox "Contact already exists in the 'Member' Group."
Exit Sub
End If
Next
End If

'If the Team group folder is found, create a contact in it
If Not olTeamGroup Is Nothing Then
Set olTeamItems = olTeamGroup.Items
Set olTeamContact = olTeamItems.Add(olContactItem)
With olTeamContact
.FirstName = Nz(Me![First Name])
.LastName = Nz(Me![Last Name])
.CompanyName = "Member"
.JobTitle = Nz(Me!txtTeam)
.HomeAddressStreet = Nz(Me!Address)
.HomeAddressCity = Nz(Me!City)
.HomeAddressPostalCode = Nz(Me!ZIP)
.BusinessTelephoneNumber = Nz(Me![Business Phone])
.HomeTelephoneNumber = Nz(Me![Home Phone])
.MobileTelephoneNumber = Nz(Me![Mobile Phone])
.Email1Address = Nz(Me![E-mail Address])
If Not IsNull(Me!Birthday) Then
    .Birthday = Me!Birthday
End If
.Save
End With
End If

'If the Member group folder is found, create a contact in it
If Not olMemberGroup Is Nothing Then
Set olMemberItems = olMemberGroup.Items
Set olMemberContact = olMemberItems.Add(olContactItem)
With olMemberContact
.FirstName = Nz(Me![First Name])
.LastName = Nz(Me![Last Name])
.CompanyName = "Member"
.JobTitle = Nz(Me!txtTeam)
.HomeAddressStreet = Nz(Me!Address)
.HomeAddressCity = Nz(Me!City)
.HomeAddressPostalCode = Nz(Me!ZIP)
.BusinessTelephoneNumber = Nz(Me![Business Phone])
.HomeTelephoneNumber = Nz(Me![Home Phone])
.MobileTelephoneNumber = Nz(Me![Mobile Phone])
.Email1Address = Nz(Me![E-mail Address])
If Not IsNull(Me!Birthday) Then
    .Birthday = Me!Birthday
End If
.Save
End With
End If

' Save the contact to both groups
olTeamContact.Move olTeamGroup
olMemberContact.Move olMemberGroup

'Clean up
Set olTeamContact = Nothing
Set olMemberContact = Nothing
Set olTeamItems = Nothing
Set olMemberItems = Nothing
Set olNS = Nothing
Set olTeamGroup = Nothing
Set olMemberGroup = Nothing
Set olContactFolder = Nothing

MsgBox "Contact saved in the group 'Member' and '" & Nz(Me!txtTeam) & "'."

End Sub

[MXQ]

Forgot one line within the With statement:

With olTeamContact
...
.FileAs = .FirstName & " " & .LastName
...
End With

With olMemberContact
...
.FileAs = .FirstName & " " & .LastName
...
End With

Otherwise the Display As field would be empty.