Option Explicit
'Option Private Module
Sub Mail_outlook_2()
'foglio invia_mail
ActiveSheet.Unprotect "987654"
'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
Dim wk1 As Workbook
'Dim miofile As String
Dim mioperc As String
Dim filemail As String
Set Source = Nothing
On Error Resume Next
Application.DisplayAlerts = 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 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
'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 S" & 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 = Foglio11.Range("S5").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 S " & 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
'-----------------------------------------------------------------------------------------
'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("A2: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
ActiveWindow.DisplayGridlines = False
Application.CutCopyMode = False
End With
'-----------------------------------------------------------------------------------------
'Set wk1 = ThisWorkbook
'il percorso
'mioperc = wk1.Path & "\"
'miofile = Range("A2") & ".pdf"
'NomePDF = mioperc & miofile
filemail = "file_mail"
Set wk1 = ThisWorkbook
'il percorso
mioperc = wk1.Path & "\" & filemail
If Dir(mioperc, vbDirectory) = "" Then MkDir mioperc
'TempFilePath = Environ$("temp") & "\"
TempFilePath = mioperc
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
'TempFileName = "Selection of " & wb.Name
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 = "frank_ciccio@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
Application.DisplayAlerts = True
End Sub
Sub delete_file_outlook_xlsx_2()
On Error Resume Next
Dim wk1 As Workbook
'Dim miofile As String
Dim mioperc As String
Dim NomeXLSX As String
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim filemail As String
'Dim FileExtStr As String
'Dim FileFormatNum As Long
Set wk1 = ThisWorkbook
Set wb = ActiveWorkbook
'il percorso
'mioperc = wk1.Path & "\"
filemail = "file_mail"
'Set wk1 = ThisWorkbook
'il percorso
mioperc = wk1.Path & "\" & filemail
TempFilePath = mioperc
'TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx"
'TempFileName = "Selection of " & wb.Name & ".xlsx"
TempFileName = "Selection of " & wb.Name & " *.*" '<<< tutti i file
'NomeXLSX = mioperc & miofile
NomeXLSX = TempFilePath & TempFileName
Kill NomeXLSX
End Sub