Ciao Phil, ecco il codice...
Ho dovuto assegnare al report un nome generico perchè in realtà avevo dichiarato una variabile che legava la strPath alla targa veicolo tipo
strPath = CurrentProject.Path & Me.Targa"
ma mi dava errore...dopo diversi tentativi, ho dovuto quindi ovviare assegnando un nome generico
P.S. quella dichiarazione, andava bene con il metodo SandObject qui non so perchè non va....
per la creazione del Report non impiega tempo, ho riscontrato che impiega diverso tempo (facendo il debug) sulla parte di codice ".Send"
Vi sono più cose indentate e non ancora utilizzate poichè le integrerò man mano, un problema x volta
Private Sub btnMailMassivo_Click()
Dim db As Database
Dim rst1 As DAO.Recordset
Dim EMail As String
Dim strTo As String
Dim strSubject As String, NomeFileStr As String, DenStr As String
Dim strMessageText As String
Dim i As Integer
Dim strSQL As String
' Variabile salvataggio report
Dim strPath As String
' Variabile body mail
Dim bodyTemplate As String
' Variabili C.D.O. - assegnazione valore
Dim sImageFile As String, SmtpServer As String, SendUserName As String, SendPassword As String
Dim SendUsing As Integer, SmtpServerPort As Integer, SmtpAutenticate As Integer, SmtpConnectionTimeOut As Integer
Dim SmtpUSesSl As Boolean
sImageFile = DLookup("ImagePath", "tblAzienda", "[IDAzienda] = 1")
SmtpServer = DLookup("SmtpServer", "tblAzienda", "[IDAzienda] = 1")
SendUserName = DLookup("SendUsername", "tblAzienda", "[IDAzienda] = 1")
SendPassword = DLookup("SendPassword", "tblAzienda", "[IDAzienda] = 1")
SendUsing = DLookup("SendUsing", "tblAzienda", "[IDAzienda] = 1")
SmtpServerPort = DLookup("SmtpServerPort", "tblAzienda", "[IDAzienda] = 1")
SmtpAutenticate = DLookup("SmtpAuthenticate", "tblAzienda", "[IDAzienda] = 1")
SmtpConnectionTimeOut = DLookup("SmtpConnectionTimeOut", "tblAzienda", "[IDAzienda] = 1")
SmtpUSesSl = DLookup("SmtpUsesSl", "tblAzienda", "[IDAzienda] = 1")
On Error GoTo LblErr
Set db = CurrentDb
Set rst1 = Me.RecordsetClone
rst1.MoveFirst
i = 0
Do While Not rst1.EOF
EMail = rst1("EMail")
KillFile
strPath = CurrentProject.Path & "\SendPromemoria\Veicolo targa" & Me.Targa & ".pdf"
DoCmd.OpenReport "RptPromemoria", acViewPreview, , "tblVeicoli.IDVeicolo = " & Me!IDVeicolo
DoCmd.OutputTo acOutputReport, "RptPromemoria", acFormatPDF, strPath
DoCmd.Close acReport, ObjectName:="RptPromemoria"
NomeFileStr = "Scadenza revisione veicolo: " & Me.txtVeicolo & " targa:" & Me.Targa
AziendaStr = DLookup("Azienda", "tblAzienda", "[IDAzienda] = 1")
DenStr = Me.txtDenom
Dim imsg, iconf, Flds, objBP
Set imsg = CreateObject("cdo.message")
Set iconf = CreateObject("cdo.configuration")
Set Flds = iconf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = SendUsing 'NTLM method
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SmtpServer
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = SmtpServerPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = SmtpAutenticate
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = SmtpUSesSl
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = SmtpConnectionTimeOut
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SendUserName
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SendPassword
.Update
End With
With imsg
Set .Configuration = iconf
.To = EMail
.From = SendUserName
'.CC = CCn
.Subject = NomeFileStr
.htmlbody = bodyTemplate
.AddAttachment strPath ' (assegnazione senza uguale)
Set objBP = .AddRelatedBodyPart(sImageFile, "logo.bmp", 1)
objBP.Fields.Update
.Fields.Update
.Send
End With
i = i + 1
rst1.MoveNext
Loop
ExitHere:
rst1.Close
Set rst1 = Nothing
Set db = Nothing
Exit Sub
LblErr:
MsgBox (Err.Description)
Exit Sub
End Sub
Function KillFile()
Dim strPath As String
strPath = CurrentProject.Path & "\SendPromemoria\Veicolo targa" & Me.Targa & ".pdf"
If Len(Dir$(strPath)) > 0 Then
Kill strPath
End If
End Function