Valutazione 4.87/ 5 (100.00%) 5838 voti

Condividi:        

Inviare immagine con mail di outlook

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Inviare immagine con mail di outlook

Postdi Ricky0185 » 26/03/20 13:23

Buongiorno a tutti, visto il tempo a disposizione sono andato a sfrugugliare nella dir ove memorizzo le macro rubacchiate in giro per il web. Siccome non sono mai riuscito ad inviare immagini nel corpo delle email ho pescato questa che allego
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)
    strbody = "Testo dell’email" & "<br><br>" & _
        " Testo dell’email." & "<br>" & _
        " Testo dell’email." & "<br><br>" & _
        "Cordiali saluti<br>"             
    MakeJPG = CopyRangeToJPG("Foglio1", "A1:O36") ‘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 = "Mail Destinatario"
        .CC = ""
        .BCC = ""
        .Subject = "Scrivere Oggetto"
        .Attachments.Add MakeJPG, 1, 0
        .HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=450 height=400></html>"
        .Display '.Send (se vuoi spedire in automatico)
    End With
    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) As String
    Dim PictureRange As Range
    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
            Exit Function
        End If       
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
        End With        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With   
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
    Set PictureRange = Nothing
End Function

Basta inserire nella macro l'indirizzo del destinatario e l'area del foglio dove è posizionata l'immagine e farla girare. Non ricordo da dove la presi poiché non è farina del mio sacco ed ecco l’aiuto che chiedo: non mi funziona, cioè tutto regolare il funzionamento della macro fino all’apparire a schermo dell’anteprima dell’email, ma poi cliccando su invia le email non arrivano a destinazione (o non partono….non so).
Vorrei risolvere questo problema prima di cercare di automatizzarla per inviare più email ad indirizzi posizionati nella colonna B con corpo dell'email posizionato nella colonna M stessa riga. La vedo dura invece differenziare le immagini per ogni email.
Ringrazio dell'interessamento e porgo cordiali saluti
Ricky
XP + Office2003
Ricky0185
Utente Junior
 
Post: 20
Iscritto il: 10/12/19 20:38

Sponsor
 

Re: Inviare immagine con mail di outlook

Postdi Anthony47 » 27/03/20 19:26

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...
Avatar utente
Anthony47
Moderatore
 
Post: 16797
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Inviare immagine con mail di outlook

Postdi Ricky0185 » 27/03/20 21:44

Messaggio "Tentativo fallito", ma non ho ancora guardato la tua macro, solo riprovato con la mia e funziona. Debbo guardarci bene sopratutto perchè hai menzionato "invio multiplo" che è quello che mi interessa. L'invio multiplo so farlo con indirizzi in una colonna e oggetto e corpo email in altre colonne, sempre sulla stessa riga dell'indirizzo. Ma dovrò riuscirci con l'immagine allegata, che al momento sono tutte in una dir.
Ringraziandoti del tempo che mi hai dedicato ti saluto.
Ricky

PS Li mortacci la tua soluzione sui numeri telefonici. Ci stavo riuscendo anch'io, ma con un unica formula su colonna d'appoggio (infinità di Stringa Estrai, Lunghezza, Sinistra etc.etc. e mi sono però arenato con i prefissi italiani con più di 2 cifre
Ti ricordo XP+Office2003
Ricky0185
Utente Junior
 
Post: 20
Iscritto il: 10/12/19 20:38

Re: Inviare immagine con mail di outlook

Postdi Anthony47 » 28/03/20 11:39

Ho inserito, nella discussione sulla gestione dei numeri telefonici, viewtopic.php?f=26&t=111190, l'informazione su come adattare qualche formula per la versione XL2003
Avatar utente
Anthony47
Moderatore
 
Post: 16797
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Inviare immagine con mail di outlook

Postdi Ricky0185 » 28/03/20 13:23

Eccolo il perchè non riuscivo a farla funzionare. Quindi finito al 90% uno dei passatempi, l'altro 10% con le stringhe estrai, dopo pranzo però ritorno a quello di questo 3d che con la tua macro non mi funziona. Ti saprò dire dove s'impappina.
Ti saluto
Ricky0185
Utente Junior
 
Post: 20
Iscritto il: 10/12/19 20:38


Torna a Applicazioni Office Windows


Topic correlati a "Inviare immagine con mail di outlook":


Chi c’è in linea

Visitano il forum: Nessuno e 16 ospiti