Importer fra Access til Outlook

Dim rst
    Dim dbe
    Dim wks
    Dim dbs
    Dim nms
    Dim fld
    Dim itms
    Dim itm
    Dim strAccessPath
    Dim appAccess
    Dim strFolder
    Dim fFound
    Dim txt

    Const olFolderContacts = 10

Sub cmdImport_Click

    Set nms = Application.GetNameSpace("MAPI")
    strFolder = "Contacts from Access"
    Set txt = Item.GetInspector.ModifiedFormPages("General").Controls("txtProgress")

'Check for existence of Contacts from Access folder and create it if not found
    fFound = FindFolder(nms.Folders("Personal Folders").Folders, 0, strFolder)

    If fFound = True Then
        Set fld = nms.Folders("Personal Folders").Folders(strFolder)
    ElseIf fFound = False Then
        Set fld = nms.Folders("Personal Folders").Folders.Add(strFolder, olFolderContacts)
    End If

'Pick up path to Access database directory from Access SysCmd function
    Set appAccess = Item.Application.CreateObject("Access.Application")
    strAccessPath = appAccess.SysCmd(9)
    strDBName = strAccessPath & "D:\Web-Bedsted\fpdb\Bedsted.mdb"
    txt.Value = "Database name: " & strDBName

'Use Office 97 DAO version
Set dbe = Item.Application.CreateObject("DAO.DBEngine.35")
    Set wks = dbe.Workspaces(0)
    Set dbs = wks.OpenDatabase(strDBName)

'Open Access table containing data to import into Outlook
    Set rst = dbs.OpenRecordset("Personale")
    RecCount = rst.RecordCount
    If RecCount = 0 Then
        txt.Value = txt.Value & vbCrLf &  "No contacts to import"
        Exit Sub
    Else
        txt.Value = txt.Value & vbCrLf & RecCount & " contacts to import"
    End If

'Set up the Outlook folder and items and iterate through the Access table, adding one contact item using the custom form for each Access record

    Set itms = fld.Items

    Do Until rst.EOF
        txt.Value = txt.Value & vbCrLf & "Importing " & rst.ContactName & "'s record"
        Set itm = itms.Add("IPM.Contact.Access Contact")

'Built-in Outlook properties
'Check whether field has data, and only import if it does
        If IsNull(rst.CustomerID) = False Then itm.CustomerID = rst.CustomerID
        If IsNull(rst.CompanyName) = False Then itm.CompanyName = rst.CompanyName
        If IsNull(rst.ContactName) = False Then itm.FullName = rst.ContactName
        If IsNull(rst.Address) = False Then itm.BusinessAddressStreet = rst.Address
        If IsNull(rst.City) = False Then itm.BusinessAddressCity = rst.City
        If IsNull(rst.Region) = False Then itm.BusinessAddressState = rst.Region
        If IsNull(rst.PostalCode) = False Then itm.BusinessAddressPostalCode = rst.PostalCode
        If IsNull(rst.Country) = False Then itm.BusinessAddressCountry = rst.Country
        If IsNull(rst.Phone) = False Then itm.BusinessTelephoneNumber = rst.Phone
        If IsNull(rst.Fax) = False Then itm.BusinessFaxNumber = rst.Fax
        If IsNull(rst.ContactTitle) = False Then itm.JobTitle = rst.ContactTitle

'Custom Outlook properties
        itm.UserProperties("Preferred") = rst.Preferred
        itm.UserProperties("Discount") = rst.Discount
        itm.Close(0)
        rst.MoveNext
       
    Loop
    rst.Close
    txt.Value = txt.Value & vbCrLf & "All contacts imported!"

End Sub

Function FindFolder(fldsParent, intDepth, strShortName)

  Dim strRoot

  strRoot = "Personal"
  For Each fld In fldsParent
      If fld.Name = strShortName Then
'Set function to True when folder is found
        FindFolder = True
        Exit Function
      End If
  Next
 
'Set function to False in case the folder is not found
  FindFolder = False
 
End Function


Jeg har fundet følgende kode som skal redigeres til at bruges
office 2003,outlook 2003,access 2003 - så det virker