Export Custom Outlook Form Data to MS Access

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

Sub CommandButton1_Click()

Set nms = Application.GetNamespace("MAPI")
strFolder = "fbtest folder"
Set fld = nms.Folders("Personal Folders").Folders(strFolder)

'Pick up path to Access database directory from Access SysCmd function
Set appAccess = CreateObject("Access.Application")
strAccessPath = appAccess.SysCmd(9)

'Get DAO version from DBEngine
strDBEngine = appAccess.Application.DBEngine.Version

'MsgBox "DBEngine version: " & strDBEngine

appAccess.Quit

If strDBEngine = "3.51" Then
'Office 97 DAO version
Set dbe = CreateObject("DAO.DBEngine.35")
strDBName = strAccessPath & "fbtestdb.mdb"
ElseIf strDBEngine = "3.6" Then
'Office 2000 DAO version
Set dbe = CreateObject("DAO.DBEngine.36")
strDBName = strAccessPath & "fbtestdb.mdb"

Else

MsgBox "Unknown Office version; canceling"

Exit Sub

End If
'MsgBox "DBName: " & strDBName
Set wks = dbe.Workspaces(0)
Set dbs = wks.OpenDatabase("S:\sameer\fbtestdb.mdb")

'Open Access table containing contact data
Set rst = dbs.OpenRecordset("fbtesttable")
'Set up reference to Outlook folder of items to export

Set itms = fld.Items
ItemCount = itms.Count
If ItemCount = 0 Then
MsgBox "No FB requests to export"

Exit Sub
Else

MsgBox ItemCount & " FB requests to export"

End If
'Set up reference to Outlook folder of items to export
Set itms = fld.Items
ItemCount = itms.Count

If ItemCount = 0 Then

MsgBox "No Fund Builder requests to export"

Exit Sub
Else

MsgBox ItemCount & " FB requests to export"

End If
For Each itm In itms

rst.AddNew

'Custom Outlook properties
rst.Request=itm.userproperties("001 Request")
rst.AccountNumber=itm.userproperties("002 Account Number") rst.ClientName=itm.userproperties("002 Client Name")

rst.Update

Next

rst.Close

MsgBox "All FB requests exported!"

End Sub