vba importare in outlook i dati da un database access e salvare il messaggio di posta elettronica

Questo frammento di codice, illustra una tecnica che permette di estrapolare i dati da un file Access ed inserirli in Outlook, il tutto tramite VBA.
Le informazioni vengono salvate in un messaggio di posta elettronica in un'apposita cartella.


Option Explicit
'variabili per la gestione del folder
Dim fld As Outlook.MAPIFolder
Public Sub MiaMacro()
'etichetta errore
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")
'imposto la cartella calendario
strCartella = "Calendar" 'Calendario '"Task s" '"Importazione"
'effettuo una ricerca delle cartelle
fFound = TrovaCartella(nms.Folders(2).Folders, strCartella)
'verifico se esiste
If fFound = True Then
Set fld = nms.Folders(2).Folders(strCartella)
ElseIf fFound = False Then
'messaggio ed esco
'MsgBox ("La cartella non esiste, verificare la correttezza dei dati")
StrErrore = "Importazione dati nel Calendario non riuscita per i seguenti motivi: Nome o cartella calendario mancante"
' Exit Sub
'Set fld = nms.Folders(2).Folders.Add(strCartella, olFolderContacts)
End If
'carico il db
conDati.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\db1.mdb;User Id=;Password=;"
'apro la connessione db
conDati.Open
'apro il recordset carico i dati
recDati.CursorLocation = adUseClient
recDati.CursorType = adOpenDynamic
recDati.LockType = adLockOptimistic
recDati.Open "select * from dati", conDati
'mi connetto al database
If recDati.RecordCount = 0 Then
MsgBox ("Non ci sono dati da importare")
Exit Sub
End If
Set itms = fld.Items
Do Until recDati.EOF
'oggetto mail item
Set itm = itms.Add(olMailItem)
'campo nome
If IsNull(recDati!Nome) = False Then itm.CC = recDati!Nome
'cognome
If IsNull(recDati!Cognome) = False Then itm.BCC = recDati!Cognome
'posta
If IsNull(recDati!posta) = False Then itm.Body = recDati!posta
'oggetto
If IsNull(recDati!Oggetto) = False Then itm.Subject = recDati!Oggetto
itm.Close 0
'sposto il messaggio nell'apposita cartella per esserne certo
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
ErrorHandler:
'libero la memoria
If recDati.State = adStateOpen Then recDati.Close
If conDati.State = adStateOpen Then conDati.Close
Set recDati = Nothing
Set conDati = Nothing
MsgBox "Errore Numero: " & Err.Number & "; Descrizione: " & Err.Description
End Sub
Function TrovaCartella(fldsParent As Folders, strCartella As String) As Boolean
'strRoot = "Personal"
For Each fld In fldsParent
If fld.Name = strCartella Then
TrovaCartella = True
Exit Functi on
End If
Next
End Function
Private Sub cmdcarica_Click()
Call MiaMacro
End Sub