Condividi:        

Macro per associare allegati e indirizzi mail

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 26/12/20 15:06

Metto a disposizione di tutti il codice completo della macro che invia le mail con outlook, dopo aver controllato i doppioni e l'esistenza del pdf da allegare.

Codice: Seleziona tutto
Sub Invio_mail()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String
Dim BodyText As String
Set OutApp = CreateObject("Outlook.Application")

Sheets("Attiva Macro").Select
StartPath = "C:\Miacartella\"
DestPath = "C:\Miacartella_utilizzati\"
For I = 2 To Cells(Rows.Count, "B").End(xlUp).Row   'Loop su tuttel le righe con i nomi
    If Cells(I, "G") = 1 Then
        ' Nominat = Sheets("Foglio1").Cells(I, 2).Value '<<< La cella dove si trova il nome
        ' Cognominat = Sheets("Foglio1").Cells(I, 3).Value '<<< La cella dove si trova il cognome
        ' crea nome da cercare tra i pdf
        StartPath = "C:\Miacartella\"
        DestPath = "C:\Miacartella_utilizzati\"
        NomeFile = Dir(StartPath & Cells(I, "B") & " " & Cells(I, "C") & " -*.pdf")
        'OutFile = "C:\Miacartella\" & Nominat & " " & Cognominat & ".pdf" '<<< il modo in cui vorrei si chiamasse il file
 

        'compilazione di un testo standard di accompagnamento
        BDT = "Le invio il risultato del test."
        BDT = BDT & vbCrLf & "Cordiali saluti" & vbCrLf
        BDT = BDT & "kiuba"

        If Len(NomeFile) > 0 Then
            EmailAddr = Sheets("Attiva Macro").Cells(I, 4).Value  '<<< La cella dove si trova l'indirizzo mail
            Subj = "testo"
           
            '
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = EmailAddr
                .CC = ""
                .BCC = ""
                .Subject = Subj
                .Body = BDT
                .Attachments.Add "C:\Miacartella\" & NomeFile
                .send
            End With

            Set OutMail = Nothing
            '
            Application.Wait (Now + TimeValue("0:00:01"))
     
            '
            'Sposta_copiando
            '

            '
            Sheets("Inserimento dati").Select
            Range("B" & I & ":AB" & I).Select
            Selection.Copy
            Sheets("Foglio2").Select
            Range("B" & I & ":AB" & I).Select
            ActiveSheet.Paste
            Cells(I, "A").Value = NomeFile              'Registrazione in A del nome file inviato
            Sheets("Inserimento dati").Select
            Range("B" & I & ":AB" & I).Select
            Application.CutCopyMode = False
            Selection.ClearContents
            Sheets("Attiva Macro").Select
           
            ' Sposta file allegato
            Name StartPath & NomeFile As DestPath & NomeFile
        End If
    End If
Sheets("Attiva Macro").Select
Next I
'
' Riordina
'

'
    Sheets("Inserimento dati").Select
    Columns("P:P").Select
    ActiveWorkbook.Worksheets("Inserimento dati").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Inserimento dati").Sort.SortFields.Add2 Key:=Range("P2:P1000" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Inserimento dati").Sort
        .SetRange Range("B2:AB1000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Set OutApp = Nothing

End Sub


In particolare nel file excel ci sono 3 fogli: Inserimento dati, Attiva Macro e Foglio2.

Nel foglio Inserimento dati vengono copiati i dati, in particolare nelle colonne O, P e U ci sono nome, cognome e indirizzo mail.

Nel foglio attiva Macro c'è il pulsante per attivare la macro e nelle colonne B, C, D vengono ricopiati i dati nome, cognome e indirizzo mail, mentre nella colonna G viene fatto il controllo dei doppioni con la formula proposta da Anthony47.

Il foglio 2 inizialmente è vuoto, alla fine della macro contiene i dati degli utenti a cui è stata inviata la mail e nella colonna A compare il nome del file inviato.

I file PDF vengono predisposti in una cartella C:\Miacartella\ e spostati nella cartella C:\Miacartella_utilizzati.

Ho aggiunto anche il riordino finale in ordine alfabetico dei dati rimasti alla fine della macro nel foglio Inserimento dati.

Ora vorrei provare a riutilizzare a scuola buona parte di questo lavoro, però vorrei usare LibreOffice, posso usare lo stesso codice nella macro oppure serviranno dei cambiamenti? Se come immagino sarà necessario apportare dei cambiamenti, mi sapreste aiutare?

Grazie ancora

Edit:
Applicato tag "CODE"
Anthony
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Sponsor
 

Re: Macro per associare allegati e indirizzi mail

Postdi Anthony47 » 27/12/20 00:48

Secondo me hai fatto confusione tra i nomi fogli, perche' se "Nel foglio Inserimento dati vengono copiati i dati, in particolare nelle colonne O, P e U ci sono nome, cognome e indirizzo mail" allora nel ciclo For i /Next i sbagli a calcolare il valore finale, visto che in quel momento hai selezionato "Attiva Macro" e usi semplicemente To Cells(Rows.Count, "B").End(xlUp).Row (inve che Sheets("Inserimento dati").Cells(etc etc)
Anche il controllo duplicati non va fatto guardando il contenuto del foglio attiva Macro ma piuttosto sul foglio Inserimento dati
Con queste approssimazioni, se vuoi che la singola mail venga visionata, approvata, firmata e Inviata allora io procederei come segue:
-insrisci una userform contenente una Label, un pulsante INVIA e un secondo pulsante Non Inviare
-associa a questa userform questo codice:
Codice: Seleziona tutto
Dim iBDT As String, iTO As String     'IN TESTA AL MODULO

Private Sub CBNO_Click()
On Error Resume Next
OutMail.Delete
mSent = False
Me.Hide
On Error GoTo 0
End Sub


Private Sub CBYes_Click()
If Len(OutMail.Body) > (Len(iBDT) + 5) And Len(iBDT) > 10 And _
  Len(Mid(OutMail.Body, InStr(1, OutMail.Body & "Firmato:  ", "Firmato:", vbTextCompare))) > 15 Then
    OutMail.To = iTO
    OutMail.Send
    mSent = True
    iTO = ""
    Me.Hide
Else
    mSent = False
    MsgBox ("La mail non sembra sia stata firmata, impossibile inviarla")
End If
End Sub

Private Sub UserForm_Activate()
iTO = OutMail.To
OutMail.To = ""
Me.Label1.Caption = "Verifica il contenuto della mail e la corretteza del suo Allegato" & vbCrLf & _
"Poi FIRMA la mail e premi INVIA (se tutto ok) o premi NON INVIARE se il contenuto non e' corretto"
Me.CBYes.BackColor = RGB(200, 200, 200)
Me.CBNO.BackColor = RGB(200, 200, 200)
mSent = False
iBDT = OutMail.Body
End Sub



Modifica il codice della Sub Invio_mail come segue:
-in testa al Modulo vba che contiene il suo codice inserisci
Codice: Seleziona tutto
Public OutMail As Object
Dim OutApp As Object
Public mSent As Boolean


-modifica il codice in queste parti:
a) Dichiarazioni da eliminare
Codice: Seleziona tutto
Sub Invio_mail()
'Dim OutApp As Object                       '--- Spostata sopra
'Dim OutMail As Object                      '--- Spostata sopra
Dim EmailAddr As String
'etc etc


b) compilazione del messaggio:
Codice: Seleziona tutto
        'compilazione di un testo standard di accompagnamento
        BDT = "Att. " & Cells(i, "B") & " " & Cells(i, "C")             '+++
        BDT = BDT & vbCrLf & "Le invio il risultato del test."          'MMM
        BDT = BDT & vbCrLf & "Cordiali saluti" & vbCrLf
        BDT = BDT & "Firmato:" & vbCrLf                                 'MMM

Ho inserito nel corpo del messaggio Nome /Cognome del destinatario e predisposto per il controllo della firma

c) compilazione e gestione di OutMail:
Codice: Seleziona tutto
            If TypeName(OutApp) <> "Application" Then                   '+++
                Set OutApp = Nothing                                    '+++
                Set OutApp = CreateObject("Outlook.Application")        '+++
            End If                                                      '+++
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = EmailAddr
                .CC = ""
                .BCC = ""
                .Subject = Subj
                .Body = BDT
                .Attachments.Add StartPath & NomeFile
                .Display    '.send                                      'MMM
                UserForm1.Show                                          '+++
                On Error Resume Next                                    '+++
                OutMail.Delete                                          '+++
                On Error GoTo 0                                         '+++
                Application.Wait (Now + TimeValue("0:00:01"))           '+++
            End With

Ho sostituito .Send con .Display e successivamente attivo la userform; sara' la userform eventualmente a inviare la mail
Le righe marcate MMM sono modificate, quelle +++ sono aggiunte, quelle --- sono da eliminare

c) ho modificato la parte che sposta le informazioni tra i fogli, inglobandole in un IF
Codice: Seleziona tutto
            If mSent = True Then                    '+++ IF /END IF AGGIUNTO
                 Sheets("Inserimento dati").Select
                 Range("B" & i & ":AB" & i).Select
                 Selection.Copy
                 Sheets("Foglio2").Select
                 Range("B" & i & ":AB" & i).Select
                 ActiveSheet.Paste
                 Cells(i, "A").Value = NomeFile              'Registrazione in A del nome file inviato
                 Sheets("Inserimento dati").Select
                 Range("B" & i & ":AB" & i).Select
                 Application.CutCopyMode = False
                 Selection.ClearContents
                 Sheets("Attiva Macro").Select
                 ' Sposta file allegato
                 Name StartPath & NomeFile As DestPath & NomeFile
            Else
                'eventuale registrazione da fare sulle mail NON INVIATE         '+++
            End If                                  '+++ Fine dell IF /END IF aggiunto       
        End If

NON HO modificato le istruzioni che muovono le informazioni anche se sospetto che i nomi dei fogli siano confusi....

In pratica con queste modifiche:
-la mail viene preparata e visualizzata
-si apre una userform che invita a verificare la mail e a firmarla prima di procedere all'invio
-il codice della userform cerca di verificare se la mail sia stata completata con "L'AGGIUNTA" della firma in coda al testo gia' previsto (in realta' controlla solo che sia stato aggiunto qualcosa in coda; volendo puoi verificare che sia stata aggiunta una qualche precisa parte di testo)
-in alternativa la mail puo' venire cancellata tramite la userform
-solo se la mail e' stata inviata allora si esegue lo spostamento di un tot di informazioni da un foglio all'altro

Sono tasselli, probabilmente vanno adattati posizionati bene nel tuo codice

La userform di cui ho parlato puo' essere importata nel tuo progetto vba, completa del suo codice, scaricando questi due file
https://www.dropbox.com/s/yndxvi96pu854 ... 1.frm?dl=0
https://www.dropbox.com/s/fihsfa2tg42h8 ... 1.frx?dl=0

Poi farai, dall'editor delle macro, Menu /File /Importa file; selezioni il file UserForm1.frm appena importato e completi con apri.

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 27/12/20 01:43

Domani proverò a vedere tutto con attenzione, grazie per l'enorme quantità di tempo che mi hai dedicato.
I nomi dei fogli dovrebbero essere corretti. Nel foglio Attiva Macro copio i dati come impostazione del foglio, senza passare per la macro. Estrapolo così i tre dati che mi interessano in modo da poterli vedere bene( nel foglio Inserimento dati ci sono 26 colonne di dati..), quindi fare il controllo su uno qualsiasi dei due fogli dovrebbe essere indifferente.
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 30/12/20 11:58

Allego la macro completa, ho preferito semplificare rispetto a quanto proposto mettendo .Display al posto di .Send e poi creando un file excel con i dati completi dei referti inviati.

Codice: Seleziona tutto
 
Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1

Sub Invio_mail()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailAddr As String
Dim Subj As String
Dim BodyText As String
Set OutApp = CreateObject("Outlook.Application")
Dim Doppi As String

Dim mDest As String, mCopy As String, mBody As String, mAttach As String
Dim TBApp As String, TBCommand As String

 ThisComponent.Sheets.getByName("Foglio2").isVisible = TRUE
Sheets("Attiva Macro").Select
StartPath = "C:\Referti\"
DestPath = "C:\Referti_utilizzati\"
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row   'Loop su tuttel le righe con i nomi
    If Cells(i, "G") = 1 Then
        ' Nominat = Sheets("Foglio1").Cells(I, 2).Value '<<< La cella dove si trova il nome
        ' Cognominat = Sheets("Foglio1").Cells(I, 3).Value '<<< La cella dove si trova il cognome
        ' crea nome da cercare tra i pdf
        StartPath = "C:\Referti\"
        DestPath = "C:\Referti_utilizzati\"
        NomeFile = Dir(StartPath & Cells(i, "C") & " " & Cells(i, "B") & " -*")
        'OutFile = "C:\Nutrizione\" & Nominat & " " & Cognominat & ".pdf" '<<< il modo in cui vorrei si chiamasse il file
 

        'compilazione di un testo standard di accompagnamento
        BDT = "Buongiorno," & vbCrLf
        BDT = BDT & "xxxx."
        BDT = BDT & vbCrLf & "Cordiali saluti" & vbCrLf
        BDT = BDT & "xxxx"

        If Len(NomeFile) > 0 Then
            'blocco per invio con outlook,
            EmailAddr = Sheets("Attiva Macro").Cells(i, 4).Value  '<<< La cella dove si trova l'indirizzo mail
            Subj = "Invio referto tampone COVID"
           
            '
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = EmailAddr
                .CC = "xxxxx@xxxx.com"
                .BCC = ""
                .Subject = Subj
                .Body = BDT
                .Attachments.Add "C:\Referti\" & NomeFile
                .Display
                Application.Wait (Now + TimeValue("0:00:01"))
                '.send
            End With

            Set OutMail = Nothing
            '
           
            Application.Wait (Now + TimeValue("0:00:01"))
     
            'Sposta_copiando Macro
           
            '
            Sheets("Inserimento dati").Select
            Range("B" & i & ":AC" & i).Select
            Selection.Copy
            Sheets("Foglio2").Select
            Range("B" & i & ":AC" & i).Select
            ActiveSheet.Paste
            Cells(i, "A").Value = NomeFile              'Registrazione in A del nome file inviato
            Sheets("Inserimento dati").Select
            Range("B" & i & ":AC" & i).Select
            Application.CutCopyMode = False
            Selection.ClearContents
            Sheets("Attiva Macro").Select
           
            ' Sposta file allegato
            Name StartPath & NomeFile As DestPath & NomeFile
        End If
    End If
Sheets("Attiva Macro").Select
Next i
'' Riordina Macro
'
rem ----------------------------------------------------------------------
rem define variables
dim document   as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document   = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

rem ----------------------------------------------------------------------
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "Nr"
args1(0).Value = 1

dispatcher.executeDispatch(document, ".uno:JumpToTable", "", 0, args1())

rem ----------------------------------------------------------------------
dim args2(0) as new com.sun.star.beans.PropertyValue
args2(0).Name = "ToPoint"
args2(0).Value = "$B$2:$AC$1000"
Application.Wait (Now + TimeValue("0:00:02"))
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args2())

rem ----------------------------------------------------------------------
dim args3(11) as new com.sun.star.beans.PropertyValue
args3(0).Name = "ByRows"
args3(0).Value = true
args3(1).Name = "HasHeader"
args3(1).Value = false
args3(2).Name = "CaseSensitive"
args3(2).Value = false
args3(3).Name = "NaturalSort"
args3(3).Value = false
args3(4).Name = "IncludeAttribs"
args3(4).Value = true
args3(5).Name = "UserDefIndex"
args3(5).Value = 0
args3(6).Name = "Col1"
args3(6).Value = 16
args3(7).Name = "Ascending1"
args3(7).Value = true
args3(8).Name = "Col2"
args3(8).Value = 15
args3(9).Name = "Ascending2"
args3(9).Value = true
args3(10).Name = "IncludeComments"
args3(10).Value = false
args3(11).Name = "IncludeImages"
args3(11).Value = true

dispatcher.executeDispatch(document, ".uno:DataSort", "", 0, args3())

'
rem ----------------------------------------------------------------------
rem define variables
dim document2   as object
dim dispatcher2 as object
rem ----------------------------------------------------------------------
rem get access to the document
document2   = ThisComponent.CurrentController.Frame
dispatcher2 = createUnoService("com.sun.star.frame.DispatchHelper")

rem ----------------------------------------------------------------------
'dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "Nr"
args1(0).Value = 3

dispatcher2.executeDispatch(document2, ".uno:JumpToTable", "", 0, args1())

rem ----------------------------------------------------------------------
'dim args2(0) as new com.sun.star.beans.PropertyValue
Application.Wait (Now + TimeValue("0:00:02"))
args2(0).Name = "ToPoint"
args2(0).Value = "$A$2:$AC$1000"

dispatcher2.executeDispatch(document2, ".uno:GoToCell", "", 0, args2())

rem ----------------------------------------------------------------------
'dim args3(11) as new com.sun.star.beans.PropertyValue
args3(0).Name = "ByRows"
args3(0).Value = true
args3(1).Name = "HasHeader"
args3(1).Value = false
args3(2).Name = "CaseSensitive"
args3(2).Value = false
args3(3).Name = "NaturalSort"
args3(3).Value = false
args3(4).Name = "IncludeAttribs"
args3(4).Value = true
args3(5).Name = "UserDefIndex"
args3(5).Value = 0
args3(6).Name = "Col1"
args3(6).Value = 16
args3(7).Name = "Ascending1"
args3(7).Value = true
args3(8).Name = "Col2"
args3(8).Value = 15
args3(9).Name = "Ascending2"
args3(9).Value = true
args3(10).Name = "IncludeComments"
args3(10).Value = false
args3(11).Name = "IncludeImages"
args3(11).Value = true

dispatcher2.executeDispatch(document2, ".uno:DataSort", "", 0, args3())

rem ----------------------------------------------------------------------
dim args4(0) as new com.sun.star.beans.PropertyValue
args4(0).Name = "Nr"
args4(0).Value = 1

dispatcher2.executeDispatch(document2, ".uno:JumpToTable", "", 0, args4())

'controlla doppioni
Sheets("Attiva Macro").Select
Doppi = Sheets("Attiva Macro").Cells(1, 9).Value
If Doppi <> "1" Then
    MsgBox ("Attenzione controllare la presenza di omonimie")
End If
MsgBox ("Controllare che la cartella contenente i file PDF dei risultati dei tamponi sia vuota")
Set OutApp = Nothing

' Riordina Macro
'

'
    'Sheets("Inserimento dati").Select
    'Columns("P:P").Select
   ' ActiveWorkbook.Worksheets("Inserimento dati").Sort.SortFields.Clear
    'ActiveWorkbook.Worksheets("Inserimento dati").Sort.SortFields.Add2 Key:=Range("P2:P1000" _
      '  ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   ' With ActiveWorkbook.Worksheets("Inserimento dati").Sort
        '.SetRange Range("B2:AB1000")
       ' .Header = xlNo
       ' .MatchCase = False
       ' .Orientation = xlTopToBottom
       ' .SortMethod = xlPinYin
       ' .Apply
    'End With
   
' sposta in nuovo foglio
'
    Sheets("Foglio2").Select
    Range("A1:AC1000").Select
    Application.CutCopyMode = False
    Selection.Cut
    Sheets.Add After:=Foglio2
    Range("A1:AC1000").Select
    ActiveSheet.Paste
   
   
    NewFName = "C:\Referti_utilizzati\Referti_inviati\" & ActiveSheet.Name & ".xls"
   
    ' Creo file per salvare i dati elaborati
   
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=NewFName
    ActiveWorkbook.Close
    ' oscuro nuovo foglio
     ThisComponent.Sheets.getByName(ActiveSheet.Name).isVisible = FALSE
    'Copia prima riga
    Application.Wait (Now + TimeValue("0:00:01"))
    Sheets("Inserimento dati").Select
    Range("B1:AC1").Select
    Selection.Copy
    Sheets("Foglio2").Select
    Range("B1:AC1").Select
    ActiveSheet.Paste
    ThisComponent.Sheets.getByName("Foglio2").isVisible = FALSE
    Sheets("Attiva Macro").Select
End Sub

 


Succede però una cosa che non capisco, ovvero Outlook apre tutte le mail correttamente, ma una volta premuto invia su ogni scheda viene inviata solo la prima mail. Sembra che ogni singolo invio sia andato a buon fine, ma in realtà invia solo la prima.

Mentre se uso .Send le invia tutte correttamente.
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Re: Macro per associare allegati e indirizzi mail

Postdi Anthony47 » 30/12/20 14:54

Succede però una cosa che non capisco, ovvero Outlook apre tutte le mail correttamente, ma una volta premuto invia su ogni scheda viene inviata solo la prima mail. Sembra che ogni singolo invio sia andato a buon fine, ma in realtà invia solo la prima.

Quando hai N mail visualizzate devi inviarle una per una.

Potrebbe essere pericoloso che la macro completi il suo lavoro come se tutte le mail vengano poi inviate, mentre per logica se qualcuno controlla la corretteza degli invii qualche mail potrebbe essere non inviata, rendendo cosi' errate le registrazioni gia' affettuate.

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 30/12/20 16:36

Nelle prove che sto eseguendo invio le mail una per una, eppure solo la prima viene inviata realmente, le altre sembra che siano state inviate, ma in realtà non lo sono.

Se eseguo la macro con Outlook già aperto nel computer tutto funziona perfettamente.

Come posso fare per fermare la macro quando ha generato la prima mail in attesa dell'invio della prima mail, poi farla ripartire fino al momento dell'invio della seconda e così via fino all'ultimo invio?
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Re: Macro per associare allegati e indirizzi mail

Postdi Anthony47 » 30/12/20 18:52

Nelle prove che sto eseguendo invio le mail una per una, eppure solo la prima viene inviata realmente, le altre sembra che siano state inviate, ma in realtà non lo sono.
E dove sono? Sono ancora visualizzate, o sono nella coda delle mail in uscita di Outlook? In questo secondo caso potrebbe dipendere dalle impostazioni di Invio di Outlook.


Come posso fare per fermare la macro quando ha generato la prima mail in attesa dell'invio della prima mail [..]?
Avevo fatto una proposta qui: viewtopic.php?f=26&t=111738&p=656478#p656429

Il tutto e' costituito da una userform e dalla modifica al codice per l'invio della mail affinche' interagisca con la userform.
La userform e il suo codice corrispondono ai file in formato FRM ed FRX scaricabili tramite i link pubblicati nel messaggio.

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 30/12/20 21:06

Anthony47 ha scritto:
Nelle prove che sto eseguendo invio le mail una per una, eppure solo la prima viene inviata realmente, le altre sembra che siano state inviate, ma in realtà non lo sono.
E dove sono? Sono ancora visualizzate, o sono nella coda delle mail in uscita di Outlook? In questo secondo caso potrebbe dipendere dalle impostazioni di Invio di Outlook.


é quello che mi chiedo anch'io.. e dove sono?? Non sono visualizzate, una volta premuto invio la finestra si chiude, e non sono nella coda d'uscita. Sembra che la finestra di inoltro della mail sia aperta, mentre outlook è chiuso, con il risultato che l'invio fa solo chiudere la finestra. Se invece outlook è già aperto indipendetemente dalla macro tutto funziona.

Anthony47 ha scritto:
Come posso fare per fermare la macro quando ha generato la prima mail in attesa dell'invio della prima mail [..]?
Avevo fatto una proposta qui: viewtopic.php?f=26&t=111738&p=656478#p656429

Il tutto e' costituito da una userform e dalla modifica al codice per l'invio della mail affinche' interagisca con la userform.
La userform e il suo codice corrispondono ai file in formato FRM ed FRX scaricabili tramite i link pubblicati nel messaggio.

Ciao


Speravo ci fosse un metodo più rapido per ottenere il medesimo risultato, ad esempio con un comando del tipo aspetta fino a quando non viene premuto invio. Naturalmente hai ragione tu.. ma io sono un po' duro di comprendonio.. e fino a quando non sbaglio faccio fatica a capire :roll:
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 30/12/20 21:44

Anthony47 ha scritto:Con queste approssimazioni, se vuoi che la singola mail venga visionata, approvata, firmata e Inviata allora io procederei come segue:
-insrisci una userform contenente una Label, un pulsante INVIA e un secondo pulsante Non Inviare
-associa a questa userform questo codice:
Codice: Seleziona tutto
Dim iBDT As String, iTO As String     'IN TESTA AL MODULO

Private Sub CBNO_Click()
On Error Resume Next
OutMail.Delete
mSent = False
Me.Hide
On Error GoTo 0
End Sub


Private Sub CBYes_Click()
If Len(OutMail.Body) > (Len(iBDT) + 5) And Len(iBDT) > 10 And _
  Len(Mid(OutMail.Body, InStr(1, OutMail.Body & "Firmato:  ", "Firmato:", vbTextCompare))) > 15 Then
    OutMail.To = iTO
    OutMail.Send
    mSent = True
    iTO = ""
    Me.Hide
Else
    mSent = False
    MsgBox ("La mail non sembra sia stata firmata, impossibile inviarla")
End If
End Sub

Private Sub UserForm_Activate()
iTO = OutMail.To
OutMail.To = ""
Me.Label1.Caption = "Verifica il contenuto della mail e la corretteza del suo Allegato" & vbCrLf & _
"Poi FIRMA la mail e premi INVIA (se tutto ok) o premi NON INVIARE se il contenuto non e' corretto"
Me.CBYes.BackColor = RGB(200, 200, 200)
Me.CBNO.BackColor = RGB(200, 200, 200)
mSent = False
iBDT = OutMail.Body
End Sub



Non mi è chiaro come associare alla useform il codice. Ho provato a metterlo in testa al modulo della macro Invio_mail() ma mi dice che manca un End_Sub. Probabilmente non l'ho incollato nel posto giusto..
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Re: Macro per associare allegati e indirizzi mail

Postdi Anthony47 » 31/12/20 01:15

La userform ha il suo modulo vba; dalla visualizzazione della userform premi F7 e ci arrivi direttamente.

Pero' se scarichi i due file di cui ho pubblicato il link e poi, dal vba, fai Menu /File /Importa file, scegli il file UserForm1.frm appena importato e completi con apri avrai la userform gia' pronta per essere richiamata dalla macro (UserForm1.Show)

Ho pensato a una userform invece di un piu' semplice msgbox perche' sulla userform puoi aggiungere poi altre informazioni, ad esempio "mail 1 di XXX" e magari una progressbar per dare l'idea di a che punto l'utente e' arrivato. Ma se hai difficolta' opta per il msgbox a risposta vbYesNo e gestisci nella macro principale sia la domanda che la risposta.

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 31/12/20 09:24

Utilizzando la useform mi dà il seguente errore:

Errore di compilazione:
Attributo non valido in sub o function

e il debug mette in evidenza la parola public in

Public OutMail As Object

Se invece della useform inserisco, subito sotto a .Display, una semplice messagebox:

MsgBox ("Preparare un'altra mail?")

prepara la prima mail e poi, dopo aver premuto ok nella messagebox apparsa, mi dà il seguente errore:

Errore di run time '462':
Il computer server remoto non esiste o non è disponibile

E il debug mette in evidenza la riga:

Set OutMail = OutApp.CreateItem(0)
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Re: Macro per associare allegati e indirizzi mail

Postdi Anthony47 » 31/12/20 10:49

Eh pero' devi seguire le istruzioni che ti do (viewtopic.php?f=26&t=111738&p=656484#p656429)

In particolare:
Anthony un paio di giorni fa ha scritto:Modifica il codice della Sub Invio_mail come segue:
-in testa al Modulo vba che contiene il suo codice inserisci
Codice: Seleziona tutto
    Public OutMail As Object
    Dim OutApp As Object
    Public mSent As Boolean


-modifica il codice in queste parti:
a) Dichiarazioni da eliminare
Codice: Seleziona tutto
    Sub Invio_mail()
    'Dim OutApp As Object                       '--- Spostata sopra
    'Dim OutMail As Object                      '--- Spostata sopra
    Dim EmailAddr As String
    'etc etc


Queste istruzioni ti servono per mettere le dichiarazioni nel posto giusto (considerato come vengono poi usate)

E subito dopo avevo riportato modifiche al ciclo di invio email, in particolare
c) compilazione e gestione di OutMail:
Codice: Seleziona tutto
                If TypeName(OutApp) <> "Application" Then                   '+++
                    Set OutApp = Nothing                                    '+++
                    Set OutApp = CreateObject("Outlook.Application")        '+++
                End If                                                      '+++
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = EmailAddr
                    .CC = ""
                    .BCC = ""
                    .Subject = Subj
                    .Body = BDT
                    .Attachments.Add StartPath & NomeFile
                    .Display    '.send                                      'MMM
                    UserForm1.Show                                          '+++
                    On Error Resume Next                                    '+++
                    OutMail.Delete                                          '+++
                    On Error GoTo 0                                         '+++
                    Application.Wait (Now + TimeValue("0:00:01"))           '+++
                End With

Ho sostituito .Send con .Display e successivamente attivo la userform; sara' la userform eventualmente a inviare la mail
Le righe marcate MMM sono modificate, quelle +++ sono aggiunte, quelle --- sono da eliminare

In testa a questo secondo blocco di modifiche c'e' quanto serve a bypassare l'errore di run time '462':

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 31/12/20 16:41

Codice: Seleziona tutto
Sub Invio_mail()
Public OutMail As Object
Dim OutApp As Object
Public mSent As Boolean

Dim EmailAddr As String
Dim Subj As String
Dim BodyText As String
Set OutApp = CreateObject("Outlook.Application")
Dim Doppi As String

Dim mDest As String, mCopy As String, mBody As String, mAttach As String
Dim TBApp As String, TBCommand As String


Sheets("Attiva Macro").Select
StartPath = "C:\Nutrizione\"
DestPath = "C:\Nutrizione_utilizzati\"
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row   'Loop su tuttel le righe con i nomi
    If Cells(i, "G") = 1 Then
        ' Nominat = Sheets("Foglio1").Cells(I, 2).Value '<<< La cella dove si trova il nome
        ' Cognominat = Sheets("Foglio1").Cells(I, 3).Value '<<< La cella dove si trova il cognome
        ' crea nome da cercare tra i pdf
        StartPath = "C:\Nutrizione\"
        DestPath = "C:\Nutrizione_utilizzati\"
        NomeFile = Dir(StartPath & Cells(i, "B") & " " & Cells(i, "C") & " -*.pdf")
        'OutFile = "C:\Nutrizione\" & Nominat & " " & Cognominat & ".pdf" '<<< il modo in cui vorrei si chiamasse il file
 

        'compilazione di un testo standard di accompagnamento
        BDT = "Le invio il risultato del test."
        BDT = BDT & vbCrLf & "Cordiali saluti" & vbCrLf
        BDT = BDT & "kiuba" & vbCrLf
        BDT = BDT & "Firmato:" & vbCrLf

        If Len(NomeFile) > 0 Then
            'blocco per invio con outlook, sbloccare fino a Set OutMail=Nothing oltre all'ultima riga Set OauApp=nothing e una delle prime righe Set OutApp = CreateObject("Outlook.Application")
            EmailAddr = Sheets("Attiva Macro").Cells(i, 4).Value  '<<< La cella dove si trova l'indirizzo mail
            Subj = "Invio risultati test COVID"
           
            '
            If TypeName(OutApp) <> "Application" Then                   '+++
                Set OutApp = Nothing                                    '+++
                Set OutApp = CreateObject("Outlook.Application")        '+++
            End If
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = EmailAddr
                .CC = ""
                .BCC = ""
                .Subject = Subj
                .Body = BDT
                .Attachments.Add "C:\Nutrizione\" & NomeFile
                .Display    '.Send
                UserForm1.Show                                          '+++
                On Error Resume Next                                    '+++
                OutMail.Delete                                          '+++
                On Error GoTo 0                                         '+++
                Application.Wait (Now + TimeValue("0:00:01"))
            End With

            Set OutMail = Nothing
            '
            'blocco per invio con TBird fino a 'SendKeys "^...., True
            'EmailAddr = Sheets("Attiva Macro").Cells(I, 4).Value
            'mDest = "to= " & EmailAddr & ","                                   '<<<
            'mCopy = "cc='carlo.furlanetto@didattica.liceogrigoletti.edu.it',"                                   '<<< Eventuale cc, oppure mCopy=""
            'Subj = "subject= 'Invio risultati Covid',"                               '<<<
            'mBody = "body= 'Buongiorno'" & vbCrLf & "in allegato il risultato del referto." & vbCrLf & "Cordiali saluti.," & Format(Now, "hh:mm:ss")           '<<< Il testo del msg
            'mAttach = ",attachment='C:\Nutrizione\" & NomeFile & "'"                    '<<< Eventuale attachment, oppure mAttach=""
            'TBApp = "C:\Program Files (x86)\Mozilla Thunderbird\thunderbird.exe"  '<<< Il TUO percorso completo
            '
            'TBCommand = TBApp & " -compose " & mDest & mCopy & Subj & mBody & mAttach
            'mypid = Shell(TBCommand, vbNormalFocus)
            'Application.Wait (Now + TimeValue("0:00:01"))
            ''SendKeys "^{ENTER}", True 'non funziona su libreoffice
            Application.Wait (Now + TimeValue("0:00:01"))
     
            ' Sposta_range Macro
            '
            'Sposta_copiando Macro
            '

            If mSent = True Then
                Sheets("Inserimento dati").Select
                Range("B" & i & ":AB" & i).Select
                Selection.Copy
                Sheets("Foglio2").Select
                Range("B" & i & ":AB" & i).Select
                ActiveSheet.Paste
                Cells(i, "A").Value = NomeFile              'Registrazione in A del nome file inviato
                Sheets("Inserimento dati").Select
                Range("B" & i & ":AB" & i).Select
                Application.CutCopyMode = False
                Selection.ClearContents
                Sheets("Attiva Macro").Select
           
                ' Sposta file allegato
                Name StartPath & NomeFile As DestPath & NomeFile
            End If
               
        End If
    End If
Sheets("Attiva Macro").Select
Next i
'
' Riordina Macro
'

'
    Sheets("Inserimento dati").Select
    Columns("P:P").Select
    ActiveWorkbook.Worksheets("Inserimento dati").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Inserimento dati").Sort.SortFields.Add2 Key:=Range("P2:P1000" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Inserimento dati").Sort
        .SetRange Range("B2:AB1000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Gio = Sheets("Attiva Macro").Cells(2, 9).Value
    Mes = Sheets("Attiva Macro").Cells(3, 9).Value
    An = Sheets("Attiva Macro").Cells(4, 9).Value
    Ora = Sheets("Attiva Macro").Cells(5, 9).Value
    Min = Sheets("Attiva Macro").Cells(6, 9).Value
' sposta in nuovo foglio
'
    Sheets("Foglio2").Select
    Range("A2:AB1000").Select
    Application.CutCopyMode = False
    Selection.Cut
    Sheets.Add After:=Foglio2
    Range("A1:AB1000").Select
    ActiveSheet.Paste
    NewFName = "C:\Nutrizione_utilizzati\Referti inviati\" & ActiveSheet.Name & ".xls"
   
    ' Creo file per salvare i dati elaborati
   
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=NewFName
    ActiveWorkbook.Close
    ActiveSheet.Visible = False
   
   
' crea immagine e salva in cartella


' Creo file per salvare i dati elaborati
'Workbooks.Add ' creo il nuovo file'
'NewFN1 = ActiveWorkbook.Name
'NewFN1 = "Referti_inviati" & Gio & "_" & Mes & "_" & An & "_" & Ora & "_" & Min

'With Application.FileDialog(msoFileDialogFilePicker)
    '.InitialFileName = "C:\Nutrizione_utilizzati\Referti inviati\"
    '.AllowMultiSelect = False
    '.Filters.Clear
    '.Filters.Add "Text", "*.txt; *.csv", 1   '<<< Filtro per estensione da cercare
    '.Show
    'If .SelectedItems.Count = 0 Then
         'MsgBox ("Nessuna voce selezionata, procedura annullata")
         'Exit Sub
    'End If
    'MioFileName = .SelectedItems(1)     'Directory e Nome del file selezionato
'End With

' comunica doppioni
Sheets("Attiva Macro").Select
Doppi = Sheets("Attiva Macro").Cells(1, 9).Value
If Doppi <> "1" Then
    MsgBox ("Attenzione controllare la presenza di omonimie")
End If
MsgBox ("Controllare che la cartella contenente i file PDF dei risultati dei tamponi sia vuota")
Set OutApp = Nothing

End Sub



Mi sembra di aver fatto tutto come indicato, eppure continua a indicarmi public come non ammesso in Sub o function. L'errore 462 non emerge in questo caso, ma nel caso in cui provo ad inserire una messagebox. Scusami ma non riesco a capire dove sbaglio.
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Re: Macro per associare allegati e indirizzi mail

Postdi Anthony47 » 31/12/20 18:06

Credo che dovresti documentarti sulla cosiddetta "area di visibilita' delle variabili", e distinguere tra variabili visibili nella sola Procedura, nel Modulo, nel Progetto; trovi qui delle definizioni di partenza:
https://docs.microsoft.com/en-us/office ... visibility
https://docs.microsoft.com/en-us/office ... -variables

Questa comprensione ti aiutera' a capire quel che scrivo ed evitare che tu continui ad "approssimare"...

Ad esempio sara' piu' chiaro perche' queste istruzioni devono essere posizionate in testa al Modulo vba che contiene il codice della Sub Invio_mail, prima di qualsiasi Sub:
Codice: Seleziona tutto
    Public OutMail As Object
    Dim OutApp As Object
    Public mSent As Boolean
E contemporaneamente NON DEVONO piu' essere inserite nella Sub Invio_mail
Codice: Seleziona tutto
    Sub Invio_mail()
    'Dim OutApp As Object                       '--- Spostata sopra
    'Dim OutMail As Object                      '--- Spostata sopra
    Dim EmailAddr As String
    'etc etc


L'errore di run time '462' compare quando interrompi la sequenza di Sub Invio_mail, sia con il MsgBox che con la UserForm; le istruzioni che bypassano il problema sono queste:
Codice: Seleziona tutto
                If TypeName(OutApp) <> "Application" Then                   '+++
                    Set OutApp = Nothing                                    '+++
                    Set OutApp = CreateObject("Outlook.Application")        '+++
                End If 


Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro per associare allegati e indirizzi mail

Postdi kiuba » 31/12/20 18:35

Ti ringrazio, sto imparando molto, ma non conosco ancora moltissimo..

Ti auguro una buona fine d'anno.

Se sapete scrutare nei semi del tempo,
e dire quale grano germoglierà e quale no..

William Shakespeare, Macbeth
Avatar utente
kiuba
Utente Junior
 
Post: 54
Iscritto il: 30/11/20 21:24

Precedente

Torna a Applicazioni Office Windows


Topic correlati a "Macro per associare allegati e indirizzi mail":


Chi c’è in linea

Visitano il forum: Marius44 e 37 ospiti