| | Post: 880 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
  16/07/2022 11:05 | |
Ciao a tutti.
Questa macro è per inviare mail con thunderbirds.
Questa macro invia anche allegati in formato xlsx.
Funziona abbastanza bene.
Ha un problema:
non riesco alla fine dopo l'invio di eliminare il file inviato con
Kill TempFilePath & TempFileName & FileExtStr
la macro:
Sub mail_thunder_xlsx()
'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
'-----------------------------------------------------------------------------------------
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 R", _
'vbInformation + vbOKOnly + vbDefaultButton2, "INFORMATION!")
'-----------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------
'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
'-----------------------------------------------------------------------------------------
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'-----------------------------------------------------------------------------------------
'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
'-----------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------
'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
'-----------------------------------------------------------------------------------------
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 & "'"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Call Shell(strCommand, vbNormalFocus)
Kill TempFilePath & TempFileName & FileExtStr
End Sub
grazie ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
|
| | Post: 880 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 16/07/2022 17:11 | |
Provato con , ma non va
Dim DeleteFile As String
DeleteFile = TempFilePath & TempFileName & FileExtStr
If Len(Dir$(DeleteFile)) > 0 Then
SetAttr DeleteFile, vbNormal
Kill DeleteFile
End If
il file
TempFilePath & TempFileName & FileExtStr
dopo l'invio deve sparire
'Public Function fSendThunderbird()
Sub mail_thunder_xlsx()
'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
'-----------------------------------------------------------------------------------------
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 = 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
'-----------------------------------------------------------------------------------------
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'-----------------------------------------------------------------------------------------
'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
'-----------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------
'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
'-----------------------------------------------------------------------------------------
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 & "'"
Dim DeleteFile As String
DeleteFile = TempFilePath & TempFileName & FileExtStr
If Len(Dir$(DeleteFile)) > 0 Then
SetAttr DeleteFile, vbNormal
Kill DeleteFile
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Call Shell(strCommand, vbNormalFocus)
End Sub
____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 3.322 | Registrato il: 06/04/2013
| Utente Master | 2010 | | OFFLINE |
|
| 17/07/2022 10:14 | |
ciao
metti un full stop alla riga 251 e nella finestra immediata digita:
?deletefile
dando invio.....cosa viene fuori?
saluti
[Modificato da dodo47 17/07/2022 10:45] Domenico
Win 10 - Excel 2016 |
| | Post: 881 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 17/07/2022 10:48 | |
Ciao dodo,
non ho capito come fare
If Len(Dir$(DeleteFile)) > 0 Then '<<<<<<<<<<<<<<<<<< [Modificato da maxma62 17/07/2022 10:48] ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 3.323 | Registrato il: 06/04/2013
| Utente Master | 2010 | | OFFLINE |
|
| 17/07/2022 12:04 | |
ciao
vedi se è più chiaro: quando la tua macro si ferma allo stop che devi aggiungere, fai quanto evidenziato.
saluti
 [Modificato da dodo47 17/07/2022 12:05] Domenico
Win 10 - Excel 2016 |
| | Post: 882 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 17/07/2022 12:58 | |
Esce un percorso
 [Modificato da maxma62 17/07/2022 13:10] ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 3.324 | Registrato il: 06/04/2013
| Utente Master | 2010 | | OFFLINE |
|
| 17/07/2022 17:18 | |
cioè tu cerchi di eliminare un file che si chiama:
"Selection of prova_INVIO con togli formattazione.xlsm 17-lug-22 12-52-54.xlsx"
che si trova nel percorso:
"c:\users\massimo\appdata\local\temp\"
????
ed esiste questo file?
saluti
Domenico
Win 10 - Excel 2016 |
| | Post: 883 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 17/07/2022 17:30 | |
Si esiste, controllato in Temp.
Penso che il problema sia la parte finale del nome del file, la parte
"Selection of prova_INVIO con togli formattazione.xlsm 17-lug-22 12-52-54.xlsx"
la parte dei minuti/secondi ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 3.325 | Registrato il: 06/04/2013
| Utente Master | 2010 | | OFFLINE |
|
| 17/07/2022 18:27 | |
Non ne vedrei il motivo, numeri e trattini sono accettati nel nomi file.
Tra l'altro se la "Kill" non trova il file, segnala un errore.
Non saprei, se puoi prova a postare il file senza dati sensibili.
saluti
Domenico
Win 10 - Excel 2016 |
| | Post: 884 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
| 17/07/2022 18:58 | |
No quello che voglio dire è che ogni volta il nome del file è diverso nella parte dei minuti/secondi ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 3.326 | Registrato il: 06/04/2013
| Utente Master | 2010 | | OFFLINE |
|
| 18/07/2022 09:05 | |
e allora non ho capito cosa vuoi.
E' chiaro che il nome del file sia ogni volta diverso in quanto tu usi Now() per costruirne la stringa.
Quando lo salvi:
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
il file si chiamerà con l'ora-minuti-secondi del momento in cui lo salvi. Ma poi questi dati non vengono ricalcolati e pertanto il file da cancellare deve esistere e la kill dovrebbe funzionare.
Comunque senza un esempio che riproduce il problema, perdiamo solo tempo.
saluti
[Modificato da dodo47 18/07/2022 09:05] Domenico
Win 10 - Excel 2016 |
| | Post: 1.314 | Registrato il: 15/06/2003
| Città: SAN BONIFACIO | Età: 52 | Utente Veteran | 2003 - 2010 | | OFFLINE |
|
| 22/07/2022 07:44 | |
Ciao, potresti pensare di cambiare approccio, pulisci la cartella visto che è una temp di sistema senza preoccuparti del singolo file, Andando nell'editor del visual basic Vai su Strumenti >>> Riferimenti e qui devi abilitare il Microsoft scripting runtime mettendo la spunta.
A questo punto basta una piccola sub per pulire la cartella
Sub DeleteFiles()
Dim MyFSO As New FileSystemObject
MyFSO.DeleteFile "C:\temp\*"
End Sub
Se vi fossero problemi per cancellare tutti i file perchè in temp potrebbero esserci file aperti dal sistema ti proporrei di cambiare cartella visto che puoi scegliere, ti crei una cartella "temp" in C: e usi la macro qui sopra senza modificarla. Quindi cambia
TempFilePath = Environ$("temp") & "\"
con
TempFilePath = "C:\temp\"
In futuro se puoi evita gli spazi nei nomi dei file alcuni automatismi devono essere scritti in modo diverso se ci sono gli spazi nel nome del file.
Spero di esserti stato di aiuto
Eris M.
[Modificato da Bryan Fury 22/07/2022 07:51] |
| | Post: 3.327 | Registrato il: 06/04/2013
| Utente Master | 2010 | | OFFLINE |
|
| 22/07/2022 09:37 | |
ciao
ho riletto con attenzione il tuo codice e, a mio avviso, il problema risiede nel fatto che la Kill pretende che il file sia chiuso, pertanto prova, prima di eliminarlo, a chiuderlo.
saluti
[Modificato da dodo47 22/07/2022 09:37] Domenico
Win 10 - Excel 2016 |
|
|
|
|