Allora... le prove sono state laboriose e non so se decisive...
La tua macro in linea di massima mi funziona; mi permetto un paio di modifiche:
-qualche Application.Wait qua e là, per dare modo a operazioni asincrone di completarsi
-eliminato qualche OnError Resume Next, se non ci sono errori possibili anche in situazioni regolari
-sulla CopyRangeToJPG, modifiche per killare un nome file prima di crearne uno nuovo con lo stesso nome; eliminazione del blocco che si fermava su MsgBox in caso di errore (la gestione viene fatta dal chiamante, se la stringa e' di lunghezza nulla); aggiunta la possibilita' di modificare una parte del nome (puo' essere utile se si vuole inviare messaggi a piu' destinatari in sequenza)
Il codice che ho usato per le prove:
- Codice: Seleziona tutto
Sub Mail_con_Immagine()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim MakeJPG As String
With Application
.EnableEvents = False
'' .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:01"))
Dim cSec As Long, mySplit, cCID
cSec = Second(Now) / 3 'PER PROVA, serve a variare la tabella da inviare
strbody = "Testo dell’email" & "<br><br>" & _
" Testo dell’email." & "<br>" & _
" Testo dell’email." & "<br><br>" & _
"Cordiali saluti<br>"
MakeJPG = CopyRangeToJPG("Master", "A1:H" & cSec + 5, CStr(cSec)) 'dove si trova l’immagine
If MakeJPG = "" Then
MsgBox "Tentativo fallito"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
'' On Error Resume Next
With OutMail
.To = "Indirizzo@Domain.com"
.CC = ""
.BCC = ""
.Subject = "Oggetto " & cSec & Format(Now, " dd-mmm-hh:mm:ss")
.Attachments.Add MakeJPG, 1, 0
'Calcolo CID
mySplit = Split(MakeJPG, Application.PathSeparator, , vbTextCompare)
cCID = mySplit(UBound(mySplit))
Debug.Print MakeJPG
Debug.Print cCID, .Subject
.HTMLBody = "<html><p>" & strbody & "</p><img src=" & "'" & cCID & "' width=450 height=400></html>"
' .Display '.Send (se vuoi spedire in automatico)
.send
End With
Application.Wait (Now + TimeValue("0:00:01"))
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String, _
Optional ByVal Suffix As String = "") As String
Dim PictureRange As Range
Dim PicName As String
'Definizione Nome Immagine
If Len(Suffix) = 0 Then
PicName = "NomePicture.jpg"
Else
PicName = "NomePicture_" & Suffix & ".jpg"
End If
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
' MsgBox "Area inesistente"
' On Error GoTo 0
CopyRangeToJPG = "" 'Se immagine non creata, restituisce stringa Nulla
Exit Function
End If
On Error Resume Next
Kill Environ$("temp") & Application.PathSeparator & PicName
On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:04"))
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & PicName, "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & PicName
Set PictureRange = Nothing
End Function
Mi permetto anche di segnalare una possibile soluzione che allega alla mail direttamente l'area del foglio sotto forma di Tabella dati, non Immagine (potrebbe consentire al ricevente di estrarre informazioni utili dal corpo mail, non limitarsi solo a guardare l'immagine. Inoltre il tutto e' scritto direttamente nel testo, non dipende dall'invio di allegati che potrebbero cambiare prima dell'invio)
Il codice di questa versione:
- Codice: Seleziona tutto
Sub Mail_con_AreaFoglio()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim MakeJPG As String
With Application
.EnableEvents = False
.ScreenUpdating = False 'Eliminare per debug
End With
Set OutApp = CreateObject("Outlook.Application")
Application.Wait (Now + TimeValue("0:00:01"))
Dim cSec As Long
cSec = Second(Now) / 2 'Per le prove
Set OutMail = OutApp.CreateItem(0)
strbody = "Testo dell’email" & "<br><br>" & _
" Testo dell’email." & "<br>" & _
" Testo dell’email." & "<br><br>" & _
"Cordiali saluti<br>"
'Eliminata la fase MakeJPG = etc etc
' On Error Resume Next
'''>>>>> Eventuale loop per invio multiplo >>>>
With OutMail
.To = "Indirizzo@domain.com"
.CC = ""
.BCC = ""
.Subject = "Oggetto ### - " & cSec & Format(Now, " dd-mmm-hh:mm:ss")
'Non piu' .Attachments.Add MakeJPG, 1, 0
'Cambiato .HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=450 height=400></html>"
.HTMLBody = "<html><p>" & strbody & RangePublish("Master", "A1:M" & cSec)
Debug.Print cSec, .Subject
' .Display '.Send (se vuoi spedire in automatico)
.send
End With
Application.Wait (Now + TimeValue("0:00:02"))
Set OutMail = Nothing
' <<<< Fine loop per eventuale invio multiplo
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangePublish(ByVal mySh As String, ByVal PRan As String) As Variant
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=101351
'
Dim TmpFile As String, myBDT As String, PubFile
TmpFile = Environ("Temp") & "\myBDT.htm" 'Lavora in Temp
'Crea file html:
With ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=TmpFile, _
Sheet:=mySh, _
Source:=PRan, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'
Set FSO = CreateObject("Scripting.FilesystemObject")
Set PubFile = FSO.OpenTextFile(TmpFile, 1, False)
RangePublish = PubFile.ReadAll
PubFile.Close
'
End Function
Si appoggia sulla Function RangePublish, inclusa nel codice indicato
In questa seconda versione ho anche evidenziato quale parte della macro andrebbe inserita in un loop se si vuole procedere con invii multipli. La stessa cosa vale, in linea di massima, per la Sub Mail_con_Immagine
Prova anche tu...
