Hi,
I've got a problem importing Outlook Contacts into two joined tables. It's an address database, one table contains persons (the child table), the other one firms (the parent table)
I get the error code 3201: you cannot add or change a record because a
related record is required in table 'firmen'
Well, I expected this error, but how can I tell access that the data are related.
Here's the Code:
Function ImportOutlookContacts() As String
Dim ws As Workspace
Dim rsta As DAO.Recordset
Dim rstf As DAO.Recordset
On Error GoTo errHandler
Set ws = DBEngine.Workspaces(0)
Set rsta = CurrentDb.OpenRecordset("personen", dbOpenDynaset)
Set rstf = CurrentDb.OpenRecordset("firmen", dbOpenDynaset)
On Error GoTo errTrans
Dim ol As New Outlook.Application
Dim olns As Outlook.Namespace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(olFolderContacts)
Set objItems = cf.Items
iNumContacts = objItems.Count
If iNumContacts <> 0 Then
For I = 1 To iNumContacts
If TypeName(objItems(I)) = "ContactItem" Then
Set c = objItems(I)
rsta.AddNew
rstf.AddNew
rsta!vorname = c.FirstName
rsta!name = c.LastName
rsta.Update
rstf!strasse = c.BusinessAddressStreet
rstf!ort = c.BusinessAddressCity
rstf!land = c.BusinessAddressState
rstf!plz = c.BusinessAddressPostalCode
rstf.Update
End If
Next I
rsta.Close
rstf.Close
MsgBox "Fertig."
Else
MsgBox "Nix zu importieren."
End If
EndIt:
Set ws = Nothing
Set rsta = Nothing
Set rstf = Nothing
Exit Function
errTrans:
MsgBox "Error ImportOutlookContacts_Click (" & Err.Number & "): " & Err.Description, vbCritical
ws.Rollback
Resume EndIt
errHandler:
MsgBox "Error ImportOutlookContacts (" & Err.Number & "): " & Err.Descrition, vbCritical
Resume EndIt
End Function
Thanks very much for any hint.
Jochen