vba importare i dati nelle attività di outlook

Questo frammento di codice, illustra una tecnica di come importare i dati di Microsoft Access nelle attività di Outlook, il tutto tramite VBA.

Option Explicit
'variabili per la gestione del folder
Dim fld As Outlook.MAPIFolder
''importa attività
Private Sub ImportaDatiAttivita(StrMessaggioErrore As String)
On Error GoTo ErrorHandler
'variabili per la gestione del db
Dim recDati As New ADODB.Recordset
Dim conDati As New ADODB.Connection
'variabile per la gestione degli elementi di outlook
Dim nms As Outlook.NameSpace
Dim itms As Outlook.Items
Dim itm As Outlook.MailItem
'varie impostazioni.
Dim strCartella As String
Dim fFound As Boolean
'variabile per il messaggio di errore
Dim StrErrore As String
'oggetto mapi
Set nms = Application.GetNamespace("MAPI")

'carico il db
conDati.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Attivita.mdb;User Id=;Password=;"
'apro la connessione db
conDati.Open
'apro il recordset carico i dati
recDati.CursorLocation = adUseClient
&n bsp; recDati.CursorType = adOpenDynamic
recDati.LockType = adLockOptimistic
recDati.Open "select * from Attività", conDati
'mi connetto al database
If recDati.RecordCount = 0 Then
MsgBox ("Non ci sono dati da importare per il Attività")
Exit Sub
End If
Set itms = fld.Items

Do Until recDati.EOF
'oggetto mail item
Set itm = itms.Add(olMailItem)

'campo Oggetto
If IsNull(recDati!Oggetto) = False Then itm.Subject = recDati!Oggetto
'Datainizio
If IsNull(recDati!Datainizio) = False Then itm.VotingResponse = recDati!Datainizio
'Orainizio
If IsNull(recDati!Orainizio) = False Then itm.CreationTime = recDati!Orainizio
'Datafine
If IsNull(recDati!Datafine) = False Then itm.VotingResponse = recDati!Datafine
'ora fine
If IsNull(recDati!Orafine) = False Then itm.ExpiryTime = recDati!Orafine
'ora Scadenza
If IsNull(recDati!Scandenza) = False Then itm.DeleteAfterSubmit = recDati!Scadenza
'Privato
If IsNull(recDati!Privato) = False Then itm.a = recDati!Privato
'Riservatezza
If IsNull(recDati!Riservatezza) = False Then itm.Recipients = recDati!Riservatezza
'Ruolo
If IsNull(recDati!Ruolo) = False Then itm.Mileage = recDati!Ruolo
'Società *
If IsNull(recDati!Società) = False Then itm.Companies = recDati!Società
'stato *
If IsNull(recDati!Scandenza) = False Then itm.RemoteStatus = recDati!Scadenza
itm.Close 0
'cambio l'elemento
itm.Move fld
recDati.MoveNext
Loop
'chiudo il recordset e libero la memoria
recDati.Close
Set recDati = Nothing
conDati.Close
Set conDati = Nothing
Exit Sub
errore:
End Sub