macro per invio mail

'The following subroutine sends a newly created workbook with just the visible cells
'in the Range("A1:K50").The cells will be PasteSpecial as values in the workbook you send.

'It is saving the workbook before mailing it with a date/time stamp.
'After the file is sent the workbook will be deleted from your hard disk.

'Important: Read also the information below the two examples

Sub Mail_Range()

ActiveSheet.Unprotect "987654"

'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm

'updateby Extendoffice
    
    'Dim emailRng As Range, cl As Range
    'Dim sTo As String
    'Dim emailAddr  As String
    
    
    '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
    
    
 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 S", _
 vbInformation + vbOKOnly + vbDefaultButton2, "AVVISO!")
 'avviso = MsgBox("The email addresses to select are in column S", _
 'vbInformation + vbOKOnly + vbDefaultButton2, "INFORMATION!")


    
   '-----------------------------------------------------------------------------------------
   'destinatari / '.To
   
                           'On Error Resume Next
    'xTxt1 = ActiveWindow.RangeSelection.Address
    xTxt1 = Foglio11.Range("S5").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 S", "nomi utenti mail", xTxt1, , , , , 8)
    
    If xRg1 Is Nothing Then Exit Sub
    '-----------------------------------------------------------------------------------------
    'per conoscenza / '.CC
    
                           'On Error Resume Next
    'xTxt2 = ActiveWindow.RangeSelection.Address
    xTxt2 = Foglio11.Range("S5").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 S " & 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
   '-----------------------------------------------------------------------------------------
   
    
      
    '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
    Set Source = Range("A1:Q" & 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
        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
    
   
 '-----------------------------------------------------------------------------------------

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
 '-----------------------------------------------------------------------------------------
 'destinatari / '.To
 
    For Each xCell1 In xRg1
        If xCell1.Value Like "*@*" Then
            If emailAddr1 = "" Then
                emailAddr1 = xCell1.Value
            Else
                emailAddr1 = emailAddr1 & ";" & xCell1.Value
            End If
        End If
    Next
 '-----------------------------------------------------------------------------------------
 'per conoscenza / '.To
 
 If xRg2 <> "" Then
  
     For Each xCell2 In xRg2
        If xCell2.Value Like "*@*" Then
            If emailAddr2 = "" Then
                emailAddr2 = xCell2.Value
            Else
                emailAddr2 = emailAddr2 & ";" & xCell2.Value
            End If
        End If
    Next
    
    End If
 '-----------------------------------------------------------------------------------------
  
    'emailAddr = InputBox("Enter email address.", "Which Email Address ?")
    'emailAddr = InputBox("Inserisci indirizzo email", " Quale indirizzo email?") '<<< ins. manuale
    
 '-------------------------------------------------------------------------------------------
   'With Dest
   
       ' .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
       
    'On Error Resume Next
'-------------------------------------------------------------------------------------------
    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
 '-------------------------------------------------------------------------------------------
        
        
        With OutMail
                    
            '.to = "gigioemax@abcdefg.com" '<<< destinatari
            .To = emailAddr1
            .CC = emailAddr2
            .BCC = ""
            '.Subject = "This is the Subject line"
            .Subject = "ACTION - " & ActiveSheet.Range("A2")
            .Body = "ACTION - " & ActiveSheet.Range("A2")
            '.Body = "Hi there"
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            '.Send   '<<< invia subito
            .Display '<<<  mostra outlook
            
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    
    'ActiveSheet.Protect "987654"
    ActiveSheet.Protect Password:="987654", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=False, AllowInsertingHyperlinks:=False, AllowFiltering:=True

End Sub

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