Versione finale e funzionante.
spiegazione della macro, per punti:
1) questa macro serve ad inviare un solo foglio,
di un file composto da piu fogli,
il foglio inviato verra' allegato ad una email.
2) la macro utilizza microsoft outlook, (io sto usando outlook 2002 e funziona),
pertanto se non e' il tuo client di posta preferito
devi crearti in outlook un account funzionante,
tipo: uno che usi pochissimo o ne crei uno nuovo.
3) nella macro si puo' decidere cosa scrivere
sia nell'oggetto, che nel contenuto
in questo caso , viene scritto anche il
giorno e l' ora di quando e' stata spedita l'email.
4) gli indirizzi delle persone a cui vuoi spedire il foglio devono essere scritti
nello stesso foglio da spedire, ( in questo caso in Col BC da rig 9),
sul foglio che spedirai tali indirizzi vengono automaticamente cancellati.
5) in C: si deve creare una cartella d'appoggio "temp" C: /temp
6) la macro invia 1na sola email perche' racchiudera' tutti i destinatari in "CCn",
quindi se hai 100 indirizzi in Col BC, non verrano create 100 email ma solo 1na,
inoltre i riceventi non vedranno a chi e' stata mandata.
Spero che con le dovute modifiche,
tutti possano agevolmente usare tale macro.
un grazie mille a Avatar e Antony
per la pazienza che hanno dimostrato come sempre.
- Codice: Seleziona tutto
Sub invio_un_Solo_Foglio()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String
Dim BodyText As String
scelta = MsgBox(Prompt:=" Stai per Spedire SOLO questo foglio ", Buttons:=vbYesNo, _
Title:=" Mando E.mail ai soci ? ")
If scelta = 6 Then '6 = SI; 7=No
ActiveSheet.Unprotect
Inizio = Timer
Range("BB9:BC108").Select ' <<< ordino gli indirizzi e le do'il formato carattere "colibri"
Selection.Sort Key1:=Range("BB9"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("BC9:BC108").Select
With Selection.Font
.Name = "Calibri"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
Selection.Font.Underline = xlUnderlineStyleSingle
Selection.Font.Underline = xlUnderlineStyleNone
Selection.Font.ColorIndex = 1
Range("c65536").End(xlUp).Offset(1, 0).Select 'mi posiziona alla prima cella vuota di Col c
'(a)
UR = Range("BC" & Rows.Count).End(xlUp).Row '<<< prende gli indirizzi inCol BC
'(b)
Sheets("1-masa1-Fogl.Base").Copy '<<< il foglio da spedire
ChDir "C:\Temp" '<<< dove appoggia il file con 1 solo foglio
ActiveWorkbook.SaveAs Filename:="C:\Temp\email-masa1.xls" ' <<< e' il file tempor con 1 solo fogl da spedire
Range("BC9:BC" & UR).ClearContents '<<<< riga che cancella l'elenco delle email solo sul foglio che invii
ActiveWindow.Close SaveChanges:=True
Indir = ""
For RR = 9 To UR
Indir = Indir & Range("BC" & RR).Value & "; "
Next RR
destinat = "" & Indir & ""
BDT = "riga 1" & vbCrLf '<<< da qui si compila il contenuto dell'email
BDT = BDT & vbCrLf & "riga 2"
BDT = BDT & vbCrLf & "riga 3" & vbCrLf
BDT = BDT & vbCrLf & "riga 4" & vbCrLf
BDT = BDT & vbCrLf & "riga 5" & vbCrLf
BDT = BDT & vbCrLf & "www.lelugarine.eu" & vbCrLf
BDT = BDT & vbCrLf & "" & vbCrLf
BDT = BDT & Format(Now(), "dd mmmm yyyy Ore HH:mm") & vbCrLf ' <<< data ed ora di spedizione
'(c)
Set OutApp = CreateObject("Outlook.Application")
OutFile = "C:\Temp\email-masa1.xls" ' e' il file temporaneo che allega
EmailAddr = Range("BC" & RR).Value
Subj = "Prova E.mail --> oggetto" '<<< l' oggetto del messaggio
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = destinat
.Subject = Subj
.Attachments.Add OutFile
.Body = BDT
.Display 'or use .send
End With
'(d)
Set OutMail = Nothing
'(e)
Set OutApp = Nothing
Application.Wait (Now + TimeValue("0:00:03")) '<<< tempo che l'email rimane aperta sul video prima dell'invio
Application.SendKeys "%a" ' <<< serve a premere -invia- sull'email che ha creato in outlook
Application.Wait (Now + TimeValue("0:00:07")) 'serve per lasciar partire l'email prima del messag. di fine macro
Fine = Timer
MsgBox ("Tempo impiegato " & Int((Fine - Inizio) / 60) & " min " & (Fine - Inizio) Mod 60 & " Sec")
Kill "C:\Temp\email-masa1.xls" '<<< serve a cancellare il file che crea in C: temp
End If
Range("c65536").End(xlUp).Offset(1, 0).Select ' posizionati alla prima riga vuota
End Sub
S.O. win10, Excell 2019