| | Post: 866 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 10:58 | |
Ciao,
nel file allegato ci sono 2 macro per invio mail
la prima per outlook funziona.
La seconda per thunderbirds ho provato a modificarla con dati di quella di outlook.
Non funziona correttamente.
Non si inseriscono gli utenti corettamente sia in TO che CC
Non si inserisce l'allegato
Non si inseisce in soggetto e body i nomi delle celle assegnate.
Un aiuto?
Grazie ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
|
| | Post: 866 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 11:51 | |
Ora sono riuscito a modificare quasi tutto.
Non funziona correttamente l'inserimento utenti in To e CC
L'allegato si inserisce
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
questa parte l'ho disabilitata
'-----------------------------------------------------------------------------------------
'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
'-----------------------------------------------------------------------------------------
qui in thunder dà errore ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 868 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 13:23 | |
Ora funziona quasi tutto.
Non riesco a correggere l'inserimanto dei nomi in To e CC.
Vedi nella foto allegata come mi esce.
Allego file ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 1.226 | Registrato il: 16/08/2015
| Città: CORDENONS | Età: 67 | Utente Veteran | Excel 2016-32bit Win11 | | OFFLINE |
|
07/07/2022 15:11 | |
Ecco, proprio questo volevo evidenziare, nella macro ci sono queste due righe: strTo = Foglio13.Range("R5").Address
e
strCC = Foglio13.Range("R5").Address che altro non fanno che recuperare un indirizzo (.address) di cella che è poi quello che finisce negli indirizzi email evidenziati nella foto.
Io userei .Value ma visto che la macro mi sembra un po' "ingarbugliata" non ci metto la mano sul fuoco; 'è tutta da rifare' come avrebbe detto uno che andava con le due ruote ... ma se alla fine comunque invia l'email ... [Modificato da rollis13 07/07/2022 15:12]
______________________________________________________________
C'è chi fa le COSE a CASO e chi fa CASO alle COSE (Ignoto) |
| | Post: 869 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 15:52 | |
Infatti la parte in rosso che si inserisce SRS5 dovrebbe essere riferita alla cella
Foglio13.Range("R5").Address
forse bisogna correggere nei 2 inputbox per la selezione. ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 870 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 16:16 | |
Una mia curiosità.
Qualcuno ha provato la versione outlook?
Io non posso provarla, qui a casa.
La versione outlook dà lo stesso problema nell'inserimento nomi in To e CC come nella foto inserita nel file zip in post#?
[Modificato da maxma62 07/07/2022 16:17] ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 871 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 20:42 | |
Sono riuscito a correggere l'inserimento dei nomi in TO e CC.
La parte modificata è questa:
'-----------------------------------------------------------------------------------------
'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"
____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 1.229 | Registrato il: 16/08/2015
| Città: CORDENONS | Età: 67 | Utente Veteran | Excel 2016-32bit Win11 | | OFFLINE |
|
07/07/2022 22:56 | |
Sì, la versione per Outlook prepara correttamente l'email.
______________________________________________________________
C'è chi fa le COSE a CASO e chi fa CASO alle COSE (Ignoto) |
| | Post: 872 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 23:14 | |
Grazie rollis.
Un' occhiata al post#7
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"
____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 1.231 | Registrato il: 16/08/2015
| Città: CORDENONS | Età: 67 | Utente Veteran | Excel 2016-32bit Win11 | | OFFLINE |
|
07/07/2022 23:38 | |
Mi dispiace ma nel mio post #4 ti ho già espresso il mio pensiero.
Continua a fare il Debug osservando di volta in volta il contenuto delle variabili e vedi se riesci a risolvere.
______________________________________________________________
C'è chi fa le COSE a CASO e chi fa CASO alle COSE (Ignoto) |
|
|