Ciao Anthony47, grazie per il tuo interessamento.
Oggi sono finalmente riuscito a rimettermi dietro a questo lavoro e ho fatto un bel passo avanti.
Ho seguito la discussione che mi hai postato ed ho riadattato il codice secondo le mie necessità. Il risultato funziona, però mi ritrovo l'immagine esportata in allegato e non nel corpo della mail... Servirebbe un comando tipo ".paste.Outfile" o qualcosa del genere. E' fattibile questa cosa? Mi sono messo a cercarla in rete e mi sono imbattuto con il "Metodo Publish" da te menzionato.
Ho recuperato del codice che, una volta riadattato, ha dato i suoi frutti!
Mi sono creato una funzione che esporta un range dati in HTML in questo modo:
- Codice: Seleziona tutto
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copia il range e crea una nuova cartella copiandoci i dati
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Posiziona il foglio in un file Html
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Legge i dati contenuti in RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Chiude TempWB
TempWB.Close savechanges:=False
'Cancella il file htm usato in questa funzione
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Infine l'ho richiamata per l'invio della mail:
- Codice: Seleziona tutto
Private Sub CommandButton4_Click()
Dim rng As Range
Set rng = Nothing
Set rng = Sheets("Scheda").Range("A1:G30").SpecialCells(xlCellTypeVisible)
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String
Set OutApp = CreateObject("Outlook.Application")
Nominat = Sheets("Scheda").Range("C5").Value
EmailAddr = Range("E5").Value
Subj = "Scheda di Sopralluogo - " & Nominat
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = EmailAddr
.CC = "xxxxxx@xxxx.it"
.BCC = ""
.Subject = Subj
'.BodyFormat = m.HTMLBody
'm.HTMLBody = RangetoHTML(rng)
.HTMLBody = RangetoHTML(rng)
.Display 'or use .send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Funziona egregiamente, però mi interesserebbe anche risolvere la questione dell'immagine nel corpo della mail.
Mi sai dare qualche dritta?
Grazie!
.theShort
