Importer fra Access til Outlook
Dim rstDim 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