Topic: Macro excel per compilare campi email

[bg66]

Buonasera,
vorrei che quando si apre thunderbird oltre ad allegare il foglio di lavoro (cosa che già fà), mi compilasse anche i campi destinatario, oggetto e testo prendendoli da celle definite.
Pensavo di riuscirci inserendo queste istruzioni specifiche:

Codice: [Seleziona]

Dim BodyMsg As String 'mio inserimento
    Dim Indirizzo As String 'mio inserimento
    Dim Oggetto As String 'mio inserimento
   
   ....
   
    BodyMsg = Range("Foglio1!K6").Value 'mio inserimento
    Indirizzo = Range("Foglio1!K2").Value 'mio inserimento
    Oggetto = Range("Foglio1!K4").Value 'mio inserimento
   
Ma non ottengo nessun risultato.

La macro completa è la seguente:

Codice: [Seleziona]

Sub Invia_ActiveSheet()
'Working in 97-2010
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim I As Long
    Dim BodyMsg As String 'mio inserimento
    Dim Indirizzo As String 'mio inserimento
    Dim Oggetto As String 'mio inserimento
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    BodyMsg = Range("Foglio1!K6").Value 'mio inserimento
    Indirizzo = Range("Foglio1!K2").Value 'mio inserimento
    Oggetto = Range("Foglio1!K4").Value 'mio inserimento
   
    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
   
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2010, we exit the sub when your answer is
            'NO in the security dialog that you only see  when you copy
            'an sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

   'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            .SendMail "", _
                      ""
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub https://www.dropbox.com/s/tuso166ta9rbxic/prova_invioPDF%26Foglio.xlsm?dl=0

Grazie per l'aiuto
Uso Excel 2010

[miki64]

Non so chi saprà aiutarti: l'argomento da te richiesto purtroppo esula dalle tematiche di questo Forum.
Ti consiglio di rivolgerti a questo Forum, sono molto preparati: http://www.pc-facile.com/forum/viewforum.php?f=26
Se risolvi, per favore posta anche qui la soluzione, grazie.

[croma.to]

Potresti provare l'estensione MailMerge per effettuare le operazioni descritte senza utilizzare la macro excel

Spero sia utile

croma.to

[bg66]

Ciao,
lo script funzionante (by FRIEDRICH) è il seguente:

Codice: [Seleziona]

    Option Explicit

    Sub Invia_ActiveSheet2()
    'Working in 97-2010
       
        Dim FileExtStr, TempFilePath, TempFileName, InviaMail, MiaMail, Indirizzo, Oggetto, BodyMsg, Allegato As String
        Dim FileFormatNum As Long
        Dim Sourcewb, Destwb As Workbook
       
        BodyMsg = Range("Foglio1!K6").Value 'mio inserimento
        Indirizzo = Range("Foglio1!K2").Value 'mio inserimento
        Oggetto = Range("Foglio1!K4").Value 'mio inserimento
       
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
       
        Set Sourcewb = ActiveWorkbook
       
    'Copy the sheet to a new workbook
        ActiveSheet.Copy
        Set Destwb = ActiveWorkbook
       
    'Determine the Excel version and file extension/format
        With Destwb
            If Val(Application.Version) < 12 Then
    'You use Excel 97-2003
                FileExtStr = ".xls": FileFormatNum = -4143
            Else
    'You use Excel 2007-2010, we exit the sub when your answer is
    'NO in the security dialog that you only see  when you copy
    'an sheet from a xlsm file with macro's disabled.
                If Sourcewb.Name = .Name Then
                    With Application
                        .ScreenUpdating = True
                        .EnableEvents = True
                    End With
                    MsgBox "Your answer is NO in the security dialog"
                    Exit Sub
                Else
                    Select Case Sourcewb.FileFormat
                    Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                    Case 52:
                        If .HasVBProject Then
                            FileExtStr = ".xlsm": FileFormatNum = 52
                        Else
                            FileExtStr = ".xlsx": FileFormatNum = 51
                        End If
                    Case 56: FileExtStr = ".xls": FileFormatNum = 56
                    Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                    End Select
                End If
            End If
        End With
       
    'Save the new workbook/Mail it/Delete it
        TempFilePath = Environ$("temp") & "\"
        TempFileName = "Part of " & Sourcewb.Name & " " _
        & Format(Now, "dd-mmm-yy h-mm-ss")
       
        With Destwb
            .SaveAs TempFilePath & TempFileName & FileExtStr, _
            FileFormat:=FileFormatNum
            On Error Resume Next
           
            Allegato = TempFilePath & TempFileName & FileExtStr
           
            InviaMail = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"
                         
            MiaMail = " -compose " & "to=" & Indirizzo & "," & "subject=" & Oggetto & "," & "body=" & BodyMsg & "," & "attachment=" & Allegato
           
            Shell InviaMail & MiaMail, vbNormalFocus
           
            Application.Wait (Now + TimeValue("0:00:03"))
           
            SendKeys "^+{ENTER}", True 'Cartella posta in uscita
           
            On Error GoTo 0
            .Close SaveChanges:=False
        End With
       
    'Delete the file you have send
    ' Kill TempFilePath & TempFileName & FileExtStr
       
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End Sub
Per altre indicazioni e per leggere l'intero thread:
http://www.pc-facile.com/forum/viewtopic.php?f=26&t=108935