| | Post: 861 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
06/07/2022 16:26 | |
Ciao a tutti.
Ho questa macro che ho ereditato in ufficio
'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
funziona bene.
Ho notato una cosa:
La macro copia una parte del foglio excel e lo invia mail e qui va bene.
Il problema è se il foglio da inviare ha una formattazione condizionale viene inviato non proprio come l'origianale ma sflalsato.
E' possibile correggere che il foglio venga inviato con la stessa formattazione o al limite con gli stessi colori?
Penso che la parte che invia il formato sia questa:
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
un aiuto?
Grazie
max
____________________________
versione excel 365 ufficio
versione excel 2007 casa |
|
| | Post: 1.223 | Registrato il: 16/08/2015
| Città: CORDENONS | Età: 67 | Utente Veteran | Excel 2016-32bit Win11 | | OFFLINE |
|
06/07/2022 17:34 | |
Testata la tua macro, non da nessun problema con la Formattazione Condizionale nell'allegato all'email. Forse è il caso che tu alleghi un file privato di eventuali dati sensibili ma con tutta la struttura integra.
______________________________________________________________
C'è chi fa le COSE a CASO e chi fa CASO alle COSE (Ignoto) |
| | Post: 861 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
06/07/2022 17:47 | |
Ciao rollis,
la formattazione funziona, solo che è sballata rispetto al file originale. ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 862 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
06/07/2022 18:01 | |
Vedo di inserire un foglio ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 863 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
06/07/2022 18:11 | |
Nel file allegato
clicca invia mail
scegli gli utenti della colonna R nell'inputbox
nel file excel che compare la formattazione, il senso delle regole, non è uguale al file originale.
____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 6.882 | Registrato il: 14/11/2004
| Utente Master | Office 2019 | | OFFLINE |
|
06/07/2022 18:59 | |
Ciao senza scendere nei dettagli, credi sia possibile salvare il file con .Zip o .Rar compresso ed allegarlo, penso che in questo modo non subirà variazione di formattazione, quando verrà riportato allo stato originale.
Ciao By Sal (8-D
se ti piace la soluzione sostienici con una DONAZIONE a piacere. Grazie clicca qui |
| | Post: 864 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
06/07/2022 19:06 | |
Grazie dell'idea sal, ma putroppo in ufficio non posso fare quello che voglio.... ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 1.225 | Registrato il: 16/08/2015
| Città: CORDENONS | Età: 67 | Utente Veteran | Excel 2016-32bit Win11 | | OFFLINE |
|
07/07/2022 11:52 | |
Il tuo file è stato creato da una vecchia versione di Excel (ante 2K7) e se fai il Controllo Compatibilità troverai diverse segnalazione tra cui questa:
______________________________________________________________
C'è chi fa le COSE a CASO e chi fa CASO alle COSE (Ignoto) |
| | Post: 867 | Registrato il: 28/12/2009
| Città: CITTADELLA | Età: 62 | Utente Senior | excel 2007/365 | | OFFLINE | |
|
07/07/2022 12:49 | |
Il file allegato è in xls perchè qui nel forum si fa solo questo non xlsm.
Comunque anche per la versione xlsm qui a casa ho lo stesso problema.
Forse colpa della verione di excel 2007 che sto usando? ____________________________
versione excel 365 ufficio
versione excel 2007 casa |
| | Post: 1.227 | Registrato il: 16/08/2015
| Città: CORDENONS | Età: 67 | Utente Veteran | Excel 2016-32bit Win11 | | OFFLINE |
|
07/07/2022 15:47 | |
Come ti avevo già detto nel mio primo post non ho incontrato problemi perché io mi sono costruito un file prova direttamente dalla mia versione 2K16. Non è solo un problema di salvataggio indicando una versione diversa di Excel.
Come ti ho detto il file nasce sicuramente in versione diversa e si trascina avanti delle incompatibilità. Forse è anche stato creato non da una versione di Excel bensì magari da OpenOffice o LibreOffice (sempre vecchie versioni comunque).
Lo si nota dal pallette di colori quando, per esempio, selezioni una cella della barra menu per modificarne lo sfondo. Se il file è stato creato con una versione recente di Excel troverai (primo a destra) il verde come Colore 6 mentre nel tuo file troverai l'arancio come Colore 6 ed il verde diventa Colore 3 e questo si tramuta nei colori 'sfalsati' nel file che andrai ad allegare all'email dato che viene generato con una diversa versione di Excel.
______________________________________________________________
C'è chi fa le COSE a CASO e chi fa CASO alle COSE (Ignoto) |
|
|