Ecco il codice funzionante:
Private Sub Comando13_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim ConteggioRecord As Long
Dim CODICEID As String
Dim TITOLO As String
Dim COGNOME As String
Dim NOME As String
Dim DATAINIZIO As Date
Dim DATAFINE As Date
Dim EMAIL As String
Dim olApp As Object
Dim objMail As Object
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim iMsg, iConf, Flds
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
' Apre la query "QUERY PER ESTRAZIONE PRESTITI SCADUTI
Set db = CurrentDb
Set rst = db.OpenRecordset("QUERY PER ESTRAZIONE PRESTITI SCADUTI")
' Va avanti in caso di errore
' On Error Resume Next
' Controlla se Outlook è aperto
' Set olApp = GetObject(, "Outlook.Application")
' Se Outlook non è aperto, apre una nuova istanza
' If Err Then
' Set olApp = CreateObject("Outlook.Application")
' End If
' Conteggio record presenti nella query
ConteggioRecord = rst.RecordCount
' Se nessun record crea messaggio apposito
If ConteggioRecord = 0 Then
MsgBox "NESSUN PRESTITO IN SCADENZA", vbInformation
' Altrimenti inizia loop
Else
rst.MoveLast
rst.MoveFirst
Do Until rst.EOF
ConteggioRecord = ConteggioRecord + 1
' Crea una nuova mail
' Set objMail = olApp.CreateItem(olMailItem)
' Set iMsg = olApp.CreateItem(olMailItem)
' Imposta indirizzo destinatario
EMAIL = rst![EMAIL]
' Imposta NOME
NOME = UCase(rst![NOME])
' Imposta COGNOME
COGNOME = UCase(rst![COGNOME])
' Imposta il TITOLO
TITOLO = rst![TITOLO]
' Imposta DATA INIZIO PRESTITO
DATAINIZIO = rst![DATAINIZIO]
' Imposta DATA SCADENZA
DATAFINE = rst![DATAFINE]
' send one copy with Google SMTP server (with autentication)
schema = "
http://schemas.microsoft.com/cdo/configuration"
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = ""
Flds.Item(schema & "sendpassword") = "yyyyyyyy"
Flds.Item(schema & "smtpusessl") = 1
Flds.Update
' Compila il messaggio email
With iMsg
.To = EMAIL
.From = ""
.Subject = "SOLLECITO RIENTRO LIBRO IN PRESTITO"
.HTMLBody = "Gentile " & NOME & " " & COGNOME & ",<BR> dai dati in nostro possesso risulta che il prestito del libro:<BR> " & TITOLO & "<BR> da lei effettuato in data: <BR>" & DATAINIZIO & "<BR> è scaduto il giorno: <BR>" & DATAFINE & "<BR> <BR> La invitiamo a prendere contatto con la Biblioteca per la restituzione del libro. <BR> §§§§ <BR> Gestione Biblioteca"
.Sender = "smtp.gmail.com"
.Organization = "gmail"
.ReplyTo = "xxxxxxx"
Set .Configuration = iConf
SendEmailGmail = .Send
End With
' Modifica campo "richiamo inviato"
' rst.Edit
' rst![RICHIAMO INVIATO] = True
' rst.Update
' Passa al record successivo
' rst.Update
rst.MoveNext
Loop
' Messaggio di conferma
ConteggioRecord = ConteggioRecord - 1
MsgBox "Inviati correttamente " & ConteggioRecord & " richiami."
End If
'Chiude query e database
rst.Close
db.Close
Set rst = Nothing
Set db = Nothing
Close
End Sub
Grazie a tutti per l'aiuto