macro per invio mail con thunderbird

Option Explicit


'https://answers.microsoft.com/it-it/msoffice/forum/msoffice_excel-mso_winother-mso_2010/inviare-mail-da-excel-con-thunderbird/7ca646e7-6fd8-40b4-9654-bdce12827727
'http://forums.mozillazine.org/viewtopic.php?t=399230&highlight=&sid=2c05f35f3050c34449d0c0deaf16621a
'http://kb.mozillazine.org/Command_line_arguments_-_Thunderbird
'http://email.about.com/od/mozillathunderbirdtips/qt/Send_an_Image_Inline_Without_Attaching_It_in_Thunderbird.htm
'http://kb.mozillazine.org/Creating_complex_mails_with_inline_images


Sub mail_thunder_file()

Call mail_thunder
With Application
.OnTime Now + TimeValue("00:00:15"), "delete_file_thunder"
End With

End Sub


'Public Function fSendThunderbird()
Sub mail_thunder()



'Dim xRg1, xRg2 As Range
    Dim xRg1, xRg2 As Variant
    Dim xCell1, xCell2  As Range
    'Dim xEmailAddr As String
    Dim emailAddr1, emailAddr2  As String
    Dim xTxt1, xTxt2 As String
    
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Ur As Long '<<< aggiunto
    Dim Avviso As String
    
    'Set Source = Nothing
    'On Error Resume Next


'---------------------------------------------------




    Dim strCommand As String ' Command line to prepare Thunderbird e-mail
    Dim strTo As String ' E-mail address
    Dim strCC As String 'E-mail address
    Dim strBcc As String 'E-mail address
    Dim strSubject As String ' Subject line
    Dim strBody As String ' E-mail body
    Dim strAttachment As String 'Allegati
   '-------------------------------------------------
    Dim wk1 As Workbook
    Dim miofile As String
    Dim mioperc As String
    'Dim twb As String
    Dim NomePDF As String
   '--------------------------------------------------
   
    Const cFormato As Integer = 1   '1: HTML    2:Plain Text

   '--------------------------------------------------
   ' Set wk1 = ThisWorkbook
   'il percorso
   ' mioperc = wk1.Path & "\"
  '  miofile = Range("Z6") & ".pdf"
  '  NomePDF = mioperc & miofile
    
   ' ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NomePDF _
  ' , Quality:=xlQualityStandard, IncludeDocProperties:=False, _
     '   IgnorePrintAreas:=False, OpenAfterPublish:=False
   '--------------------------------------------------
   
   
   
    If Range("A5") = "" Then
Avviso = MsgBox("non c'è niente da inviare via mail!", vbExclamation + vbOKOnly + vbDefaultButton2, "AVVISO")
 If Avviso = vbOK Then Exit Sub
 'End If
 End If
 
        
 Avviso = MsgBox("Gli indirizzi mail da selezionare sono nella colonna R", _
 vbInformation + vbOKOnly + vbDefaultButton2, "AVVISO!")
 'avviso = MsgBox("The email addresses to select are in column S", _
 'vbInformation + vbOKOnly + vbDefaultButton2, "INFORMATION!")
   
   
           
           
           
    'strTo = Range("Z2").Value
    'strCC = Range("Z4").Value
    'strBcc = "test4@test.com"
    
    
    '-----------------------------------------------------------------------------------------
   'destinatari / '.To
   
                           'On Error Resume Next
    'xTxt1 = ActiveWindow.RangeSelection.Address
    'xTxt1 = Foglio1.Range("R5").Address
    strTo = Foglio13.Range("R5").Address
    
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
                           
    Set xRg1 = Application.InputBox("scegli i nomi utenti destinatari in colonna R" & Chr(13) & _
    "clicca CTRL nell'inputbox per inserire più utenti", "nomi utenti mail", xTxt1, , , , , 8)
    
    If xRg1 Is Nothing Then
    ActiveSheet.Protect "987654"
    Exit Sub
    End If
    
    '-----------------------------------------------------------------------------------------
    'per conoscenza / '.CC
    
                           'On Error Resume Next
    'xTxt2 = ActiveWindow.RangeSelection.Address
    'xTxt2 = Foglio1.Range("R5").Address
    strCC = Foglio13.Range("R5").Address
    
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
    'Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna S", "nomi utenti mail", xTxt2, , , , , 8)
    
     Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna R " & Chr(13) & _
     "clicca CTRL nell'inputbox per inserire più utenti" & Chr(13) & _
     "clicca Annulla se non vuoi inviare", "nomi utenti mail", xTxt2, , , , , 8)
    
    'If xRg2 Is Nothing Then Exit Sub ' <<< tolto se non c'è niente
    'If xRg2 Is Nothing Then xRg2 = "" ' <<< se vuoto lascia vuoto
   '-----------------------------------------------------------------------------------------
              
           
     '-----------------------------------------------------------------------------------------
 'destinatari / '.To
 
    For Each xCell1 In xRg1
        If xCell1.Value Like "*@*" Then
           If strTo = "" Then
                strTo = xCell1.Value
            Else
               strTo = strTo & ";" & xCell1.Value
            End If
        End If
    Next
 '-----------------------------------------------------------------------------------------
 'per conoscenza / '.To
 
' If xRg2 <> "" Then
  
   '  For Each xCell2 In xRg2
      '  If xCell2.Value Like "*@*" Then
        '    If strCC = "" Then
          '      strCC = xCell2.Value
         '   Else
          '      strCC = strCC & ";" & xCell2.Value
        '    End If
      '  End If
   ' Next
    
  '  End If
 '-----------------------------------------------------------------------------------------
           
    '-----------------------------------------------------------------------------------------
   
    
      
    'Set Source = Range("A1:Q54").SpecialCells(xlCellTypeVisible) '<<< tutte righe del range
    
    Ur = Cells(Rows.Count, 3).End(xlUp).Row '<<< solo righe non vuote del range
    
    ActiveSheet.Unprotect "987654"
    
    Set Source = Range("A2:P" & Ur).SpecialCells(xlCellTypeVisible)
    
    On Error GoTo 0

    If Source Is Nothing Then
    
        'MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        MsgBox "La sorgente non è un intervallo o il foglio è protetto, correggilo e riprova.", vbOKOnly
        
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        ActiveWindow.DisplayGridlines = False
        Application.CutCopyMode = False
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    
   
 '-----------------------------------------------------------------------------------------
           
    '-------------------------------------------------------------------------------------------
    With Dest
        
        .Worksheets(1).Cells.Locked = True
        .Worksheets(1).Protect password:="password"
        .Worksheets(1).EnableSelection = xlUnlockedCells
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        
     On Error Resume Next
     
     End With
 '-------------------------------------------------------------------------------------------
                     
    
                         
    strAttachment = Dest.FullName
    
    strSubject = "ACTION di < " & Foglio13.Range("A2").Value & " >  "
    
    strBody = "ACTION < " & Foglio13.Range("D2").Value & " > "
                                 
    strCommand = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"
  
    strCommand = strCommand & " -compose to='" & strTo & "'," _
        & "cc='" & strCC & "'," _
        & "bcc='" & strBcc & "'," _
        & "subject='" & strSubject & "'," _
        & "format='" & cFormato & "'," _
        & "body='" & strBody & "'," _
        & "attachment='" & strAttachment & "'"

'Kill NomePDF
    
   Kill TempFilePath & TempFileName & FileExtStr
   
    
    Call Shell(strCommand, vbNormalFocus)
 
End Sub


 '  Sub delete_file_thunder()
   
'On Error Resume Next

 '   Dim wk1 As Workbook
 '   Dim miofile As String
 '   Dim mioperc As String
 '   Dim NomePDF As String

   '--------------------------------------------------
  '  Set wk1 = ThisWorkbook
   'il percorso
  '  mioperc = wk1.Path & "\"
  '  miofile = Range("Z6") & ".xlsx"
  '  NomePDF = mioperc & miofile
   '--------------------------------------------------
    
'Kill NomePDF

 ' End Sub

'-----------------------------------------------------------------------------------------
 'per conoscenza / '.To
 
' If xRg2 <> "" Then
  
   '  For Each xCell2 In xRg2
      '  If xCell2.Value Like "*@*" Then
        '    If strCC = "" Then
          '      strCC = xCell2.Value
         '   Else
          '      strCC = strCC & ";" & xCell2.Value
        '    End If
      '  End If
   ' Next
    
  '  End If
 '-----------------------------------------------------------------------------------------

strTo = Foglio13.Range("R5").Address
e
strCC = Foglio13.Range("R5").Address

'-----------------------------------------------------------------------------------------
   'destinatari / '.To
   
    On Error Resume Next
    xTxt1 = ActiveWindow.RangeSelection.Address
    xTxt1 = Foglio13.Range("R5").Address
    
                           'strTo = Foglio11.Range("R5") '.Address
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
                           
    Set xRg1 = Application.InputBox("scegli i nomi utenti destinatari in colonna R" & Chr(13) & _
    "clicca CTRL nell'inputbox per inserire più utenti", "nomi utenti mail", xTxt1, , , , , 8)
    
    If xRg1 Is Nothing Then
    ActiveSheet.Protect "987654"
    Exit Sub
    End If
          
 '-----------------------------------------------------------------------------------------
 'per conoscenza / '.CC
    
    On Error Resume Next
    xTxt2 = ActiveWindow.RangeSelection.Address
    xTxt2 = Foglio13.Range("R5").Address
    
                           'strCC = Foglio11.Range("R5") '.Address
                           'Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
                           'Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna S", "nomi utenti mail", xTxt2, , , , , 8)
    
     Set xRg2 = Application.InputBox("scegli i nomi utenti per conoscenza in colonna R " & Chr(13) & _
     "clicca CTRL nell'inputbox per inserire più utenti" & Chr(13) & _
     "clicca Annulla se non vuoi inviare", "nomi utenti mail", xTxt2, , , , , 8)
    
    'If xRg2 Is Nothing Then Exit Sub ' <<< tolto se non c'è niente
    
'-----------------------------------------------------------------------------------------

Un problema che non riesco a risolvere ora è che se nel inpubox sia per TO che CC
dove si scrive è vuoto e clicco OK dà errore e compare:

La formula contiene un errore..........

è possibile che non compaia questo messaggio ma uno tipo:

"devi inserire un nome della colonna R o cliccare annulla"