You are here:---Rispondi a: Come allegare un file generico ad una email mediante VBA ?
Rispondi a: Come allegare un file generico ad una email mediante VBA ?2018-03-30T13:23:05+02:00

Home Forum Domande su Excel VBA e MACRO Come allegare un file generico ad una email mediante VBA ? Rispondi a: Come allegare un file generico ad una email mediante VBA ?

AvatarAngelo Barachetti
Partecipante
    Post totali: 2

    Ciao Sal

    Grazie per la risposta

    Non posso però creare un elenco di file e delle loro directory perché non sono sempre gli stessi file, come per le normali e-mail

    In realtà se possibile vorrei che si aprisse ( dietro a una richiesta di un msgbox ) una finestra come quella che si utilizza in Outlook per ricercare manualmente e allegare un file alla e-mail, una volta selezionato il file riprendo l’esecuzione del codice.

    Allego la macro, ho evidenziato dove vorrei inserire il passaggio, in quella parte di codice per ora sono righe incomplete senza i vari controlli, solo per capire di cosa sto parlando.

    Il recupero del file é nel tag

    Un saluto, Angelo

     

     

    Private Declare PtrSafe Function InternetCheckConnection Lib “wininet.dll” Alias “InternetCheckConnectionA” _

    (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Boolean

     

    Function IS_Empty(vRange As Range) As Boolean

    IS_Empty = (vRange.Count – Application.CountBlank(vRange) = 0)

    End Function

     

     

    Sub InvioMailConOrdine() ‘crea una copia del file matrice senza vba e la invia in ditta all’ufficio acquisti

    Dim fso

    Dim OutApp As Object

    Dim OutMail As Object

    Dim Btn As Integer

    Dim bConn As Boolean

     

    Dim Commessa As String

    Dim NomeCantiere As String

    Dim CopiaNomeFile As String

    Dim Folder As String

    Dim percorso As String

    Dim Percorso1 As String

    Dim percorso2 As String

    Dim Percorso3 As String

    Dim percorso4 As String

    Dim Percorso5 As String

    Dim allegato As String

    Dim testo1 As String

    Dim testo2 As String

    Dim testo3 As String

    Dim testo4 As String

    Dim strbody As String

     

    Dim rng1 As Range

    Dim rng2 As Range

    Dim rng3 As Range

    Dim rng4 As Range

    Dim wk1 As Workbook

    Dim wk2 As Workbook

    Dim sh1 As Worksheet

    Dim sh2 As Worksheet

    ‘inizio con una serie di controlli preliminari

    ‘controllo se é la matrice originale ed esco se lo é

    If [Q5] = “MATRICE  NON  MODIFICABILE” Then

    Call PlaySoundDog ‘invece del classico avviso di windows avvio un file waw di un cane che abbaia

    MsgBox ”         QUESTA  E’  LA  MATRICE  NON  MODIFICABILE !” & vbLf & ” ” & vbLf & _

    ”                La  funzione  non  é  disponibile  adesso”, vbOKOnly, “Powered By Angelo”

    Exit Sub

    End If

    ‘controllo se alcune colonne normalmente nascoste sono aperte ed esco se lo sono

    If Sheets(1).[Q5] = “A” Then

    Call PlaySoundDog ‘invece del classico avviso di windows avvio un file waw di un cane che abbaia

    MsgBox ”                                   MATRICE  APERTA !” & vbLf & ” ” & vbLf & _

    “NON  E’  POSSIBILE  CREARE  ADESSO  UNA  NUOVA  RICHIESTA !”, vbOKOnly, “Powered By Angelo”

    Exit Sub

    End If

    ‘controllo lo stato della matrice  ed esco se sto facendo modifiche

    If Sheets(1).[Q5] = “MATRICE  SBLOCCATA  E  MODIFICABILE” Then

    Call PlaySoundDog ‘invece del classico avviso di windows avvio un file waw di un cane che abbaia

    MsgBox ”           MATRICE  SBLOCCATA  E  NON  ANCORA  SALVATA !” & vbLf & ” ” & vbLf & _

    “NON  E’  POSSIBILE  CREARE  ADESSO  UNA  NUOVA  RICHIESTA !”, vbOKOnly, “Powered By Angelo”

    Exit Sub

    End If

    ‘controllo alcune celle per verificare se  é stato compilato l’ordine  ed esco se non é ancora compilato

    If IS_Empty(Range(“B7:P26″)) Then

    Call PlaySoundDog ‘invece del classico avviso di windows avvio un file waw di un cane che abbaia

    MsgBox ”     NON  HAI  ANCORA  COMPILATO  LA  RICHIESTA !” & vbLf & ” ” & vbLf & _

    ”                Non  posso  inviare  un  ordine  vuoto”, vbOKOnly, “Powered By Angelo”

    Exit Sub

    End If

    ‘controllo se é stata scritta la data di consegna del materiale ed eventualmente apro un userform per inserirla

    If Sheets(1).[M4] = “” Then

    ‘scrivo sulle label del form i riferimenti di cosa inserire

    UserForm2.Label1 = “NON  HAI  INSERITO  LA  DATA  DI  CONSEGNA  DEL  MATERIALE !”

    UserForm2.Label2 = “Inseriscila  qui  sotto  e  carica  i  dati”

    UserForm2.Label3 = “”

    ‘scrivo sulla label4 “invisibile” un riferimento per sapere cosa sto elaborando essendo unico il form di correzione per errori diversi

    UserForm2.Label4 = “DataDiConsegna”

    UserForm2.CommandButton1.Caption = “CARICA  LA  DATA  NELLA  RICHIESTA  MATERIALE”

    UserForm2.TextBox1 = “”

    UserForm2.Top = 200

    UserForm2.Left = 300

    UserForm2.Show ‘ apro il form di correzione

    DoEvents

    End If

    Btn = MsgBox(”   VUOI  INVIARE  ADESSO  IL  NUOVO  ORDINE  MATERIALE ?” & vbLf & ” ” & vbLf & _

    ”                           Premi  OK  per  inviare  l’ordine” & vbLf & ” ” & vbLf & _

    ”      Premi  ANNULLA  oppure  X  per  tornare  alla  richiesta”, vbQuestion + vbOKCancel, “Powered By Angelo”)

    Select Case Btn

    Case vbCancel

    Exit Sub

    Case vbOK

    ‘ inizio la procedura di creazione di una copia ddi questo file su una base xlsx (tolgo il vba) per l’invio

    Commessa = Range(“M3”).Value

    NomeCantiere = Range(“F3”).Value

    CopiaNomeFile = Mid(ThisWorkbook.Name, 1, Len(ThisWorkbook.Name) – 5)

    ‘blocco l’aggiornamento dello schermo

    Application.ScreenUpdating = False

    ‘verifico se esiste il percorso  dove salvare la nuova richiesta materiali

    percorso = Dir(“C:\Miaditta\Cantieri aperti\” & NomeCantiere & “\Ordini materiale\Ordini inviati”, vbDirectory)

    If percorso = “” Then

    MsgBox ” NON  TROVO  LA  CARTELLA  DI  DESTINAZIONE  DOVE  VERRA'” & vbLf & _

    ”     SALVATO  IL  FILE  DELLA  NUOVA  RICHIESTA  MATERIALE” & vbLf & ” ” & vbLf & _

    ”       Verifica  se  é  stata  spostata  o  cancellata  o  rinominata !” & vbLf & ” ” & vbLf & _

    ”               La  cartella  (Copie di ordini inviati)  deve  stare” & vbLf & _

    ”                                nel  percorso  sottoelencato” & vbLf & ” ” & vbLf & _

    percorso, vbCritical, “Powered By Angelo”

    Exit Sub

    End If

    ‘verifico se esiste il file che userò come base per compilare la richiesta da mandare in ufficio acquisti

    Percorso1 = Dir(“C:\Miaditta\FileDatiPerOrdiniMateriale\Richiesta materiale (MATRICE ORDINE).xlsx”)

    If Percorso1 = “” Then

    MsgBox ”     NON  TROVO  IL  FILE  MATRICE  CHE  VERRA’  UTILIZZATO” & vbLf & _

    ”          PER  COMPILARE  L’ORDINE  DA  INVIARE  IN  DITTA” & vbLf & ” ” & vbLf & _

    ”       Verifica  se  é  stato  spostato  o  cancellato  o  rinominato !” & vbLf & ” ” & vbLf & _

    ”         Il  file  (Richiesta materiali(MATRICE ORDINE))” & vbLf & _

    ”                      deve  stare  nel  percorso  sottoelencato” & vbLf & ” ” & vbLf & _

    Percorso1, vbCritical, “Powered By Angelo”

    Exit Sub

    End If

    ‘ apro il file matrice per creare il file senza vba che verrà compilato prima di essere spedito

    percorso2 = “C:\STBG.exe\FileDatiPerOrdiniMateriale\Richiesta materiale (MATRICE ORDINE).xlsx”

    Workbooks.Open FileName:=percorso2

    ‘tolgo la protezione al foglio 1

    ActiveWorkbook.Sheets(1).Unprotect “1973”

    ‘ sblocco le celle che verranno compilate per la nuova richiesta materiale

    ActiveWorkbook.Sheets(1).[A5:P25,A30:P50,A55:P75].Locked = False

    ‘ salvo con nome una copia per mantenere intatta la matrice ma prima verifico se esiste già un file con lo stesso nome

    Percorso5 = “C:\STBG.exe\Cantieri aperti.exe\” & NomeCantiere & “\Ordini materiale\Ordini inviati\” & CopiaNomeFile & “.xlsx”

    ‘ se esisteva già il file

    If Dir(“C:\STBG.exe\Cantieri aperti.exe\” & NomeCantiere & “\Ordini materiale\Ordini inviati\” & CopiaNomeFile & “.xlsx”) <> “” Then

    ‘ prima elimino il file che esisteva

    Kill (Percorso5)

    ‘ poi salvo una nuova copia del file pronto per essere compilato chiudendo la matrice ordine

    ActiveWorkbook.SaveAs FileName:=”C:\STBG.exe\Cantieri aperti.exe\” & NomeCantiere & “\Ordini materiale\Ordini inviati\” & CopiaNomeFile & “.xlsx”

    Else

    ‘ se non esisteva salvo una copia del file pronto per essere compilato chiudendo la matrice ordine

    ActiveWorkbook.SaveAs FileName:=”C:\STBG.exe\Cantieri aperti.exe\” & NomeCantiere & “\Ordini materiale\Ordini inviati\” & CopiaNomeFile & “.xlsx”

    End If

    ‘ memorizzo il nome del file per successivo utilizzo

    Percorso3 = ActiveWorkbook.Name

    ‘ memorizzo il nome completo (percorso e nome) del file per successivo utilizzo

    percorso4 = ActiveWorkbook.FullName ‘Percorso completo del file

    ‘tolgo alcune scritte dal foglio

    ActiveSheet.Shapes.Range(Array(“Rectangle 4”)).Delete

    ActiveSheet.Shapes.Range(Array(“Rectangle 5”)).Delete

    ActiveSheet.Shapes.Range(Array(“Rectangle 6″)).Delete

    ‘gestione errori

    On Error GoTo RigErr

    ‘metto i riferimenti ai files

    Set wk1 = ThisWorkbook

    Set wk2 = Workbooks(Percorso3) ‘(” & CopiaNomeFile & “Ordine” & “.xlsx”)’C:\STBG.exe\Cantieri aperti.exe\” & NomeCantiere & “\Ordini materiale\Copie di ordini inviati\” & CopiaNomeFile & “Ordine” & “.xlsx”)

    ‘metto i riferimenti ai fogli

    Set sh1 = wk1.Worksheets(“Foglio1”)

    Set sh2 = wk2.Worksheets(“Ordine”)

    With sh1

    ‘copio i dati da un file all’altro compilando le celle relative al cantiere

    .Range(“F3:I3”).Copy Destination:=sh2.Range(“F2:I2”)

    .Range(“F4:I4”).Copy Destination:=sh2.Range(“F3:I3”)

    .Range(“F5:I5”).Copy Destination:=sh2.Range(“F4:I4”)

    .Range(“M3:P3”).Copy Destination:=sh2.Range(“M2:P2”)

    .Range(“M4:P4”).Copy Destination:=sh2.Range(“M3:P3”)

    .Range(“M5:P5”).Copy Destination:=sh2.Range(“M4:P4”)

    ‘copio i dati da un file all’altro compilando le celle relative al materiale ordinato

    .Range(“B7:P26”).Copy Destination:=sh2.Range(“B6”)

    .Range(“B32:P51”).Copy Destination:=sh2.Range(“B31”)

    .Range(“B57:P76”).Copy Destination:=sh2.Range(“B56”)

    End With

    ‘imposto l’area di stampa

    Fg1 = 1

    If IS_Empty(sh2.Range(“B56:P75”)) Then

    Fg3 = 0

    Else

    Fg3 = 1

    End If

    If IS_Empty(sh2.Range(“B31:P50”)) Then

    Fg2 = 0

    Else

    Fg2 = 1

    End If

    FgT = Fg1 + Fg2 + Fg3

    If FgT = 1 Then

    Set AreaDiStampa = sh2.Range(“$A$1:$P$25”)

    sh2.Range(“N1”) = “Foglio 1 di 1”

    ‘sh2.Range(“N26”) = “”

    ‘sh2.Range(“N51”) = “”

    sh2.Range(“A26:P75”).Delete Shift:=xlUp

    sh2.Shapes.Range(Array(“Picture 8”)).Delete

    sh2.Shapes.Range(Array(“Picture 9”)).Delete

    End If

    If FgT = 2 Then

    Set AreaDiStampa = sh2.Range(“$A$1:$P$50”)

    sh2.Range(“N1”) = “Foglio 1 di 2”

    sh2.Range(“N26”) = “Foglio 2 di 2”

    ‘sh2.Range(“N51”) = “”

    sh2.Range(“A51:P75”).Delete Shift:=xlUp

    sh2.Shapes.Range(Array(“Picture 9”)).Delete

    End If

    If FgT = 3 Then

    Set AreaDiStampa = sh2.Range(“$A$1:$P$75”)

    sh2.Range(“N1”) = “Foglio 1 di 3”

    sh2.Range(“N26”) = “Foglio 2 di 3”

    sh2.Range(“N51”) = “Foglio 3 di 3”

    End If

    ‘blocco la cella “data di consegna”

    wk2.Sheets(1).Range(“M3:P3”).Locked = True

    ‘riporto in posizione la selezione

    wk2.Sheets(1).Range(“B6”).Select

    Application.GoTo reference:=ActiveCell, Scroll:=True

    With ActiveWindow

    .SmallScroll Up:=5, ToLeft:=1

    End With

    ‘metto la protezione sul foglio (rimossa funzione)

    ‘wk2.Sheets(1).Protect “1973”, DrawingObjects:=True, Contents:=True, Scenarios:=True

    ‘chiudo il foglio pronto per l’invio

    wk2.Close SaveChanges:=True

    ‘———————————————————————————————————————————–

    ‘qui chiedo se ci sono altri file da allegare

    ‘MsgBox “Hai altri file da allegare alla e-mail?”

     

    ‘If vbOK Then

    ‘in questo punto creerò una prima istruzione per allegare altri documenti

    ‘file1 = Dir(“C:\MioPc\Miofile\Allegato1.xlsx”) ‘questa directory deve compilarsi automaticamente dopo aver scelto il file da allegare

    ‘in questo punto creerò una seconda istruzione per allegare altri documenti

    ‘file2 = Dir(“C:\MioPc\Miofile\Allegato2.xlsx”) ‘questa directory deve compilarsi automaticamente dopo aver scelto il file da allegare

    ‘in questo punto creerò una terza istruzione per allegare altri documenti

    ‘file3 = Dir(“C:\MioPc\Miofile\Allegato3.xlsx”) ‘questa directory deve compilarsi automaticamente dopo aver scelto il file da allegare

    ‘End If

     

    ‘———————————————————————————————————————————–

    ‘riga sempre eseguita

    RigaChiusura:

    ‘Set a Nothing delle variabili oggetto

    Set sh2 = Nothing

    Set sh1 = Nothing

    Set wk1 = Nothing

    Set wk2 = Nothing

    FgT = 1

    Application.DisplayAlerts = False

    Set OutApp = CreateObject(“Outlook.Application”)

    Set OutMail = OutApp.CreateItem(0)

    strbody = “Ciao Sig.Rossi” & vbNewLine & vbNewLine & _

    “In allegato un ordine per il cantiere ” & NomeCantiere & ” ” & vbNewLine & vbNewLine & _

    “Grazie”

    ‘”This is line 3″ & vbNewLine & _

    ‘”This is line 4″

    On Error Resume Next

    With OutMail

    .To = “sig.rossi@miaditta.it”

    .CC = “”

    .BCC = “”

    .Subject = “Ordine materiale comm. ” & Commessa

    .Body = strbody ‘”Ciao”

    .Attachments.Add (percorso4)

    ‘———————————————————————————————————

    ‘.Attachments.Add (file1)’se ho altri documenti li voglio mettere qui

    ‘.Attachments.Add (file2)’se ho altri documenti li voglio mettere qui

    ‘.Attachments.Add (file3)’se ho altri documenti li voglio mettere qui

    ‘———————————————————————————————————

    .Send

    End With

    DoEvents

    ‘OutMail = OutApp.CreateItem(0).Send

     

    Set OutMail = Nothing

    Set OutApp = Nothing

    Application.DisplayAlerts = True

    ‘verifico se é presente una connessione internet

    Const sUrl As String = “google.it”

    bConn = InternetCheckConnection(“h t t p://” & sUrl, &H1, &H0) ‘tolgo gli spazi in “h t t p”

    If bConn Then

    ‘chiudo con un messaggio di conferma dell’avvenuto invio dell’ordine

    MsgBox ”     RICHIESTA  MATERIALI  INVIATA  CORRETTAMENTE” & vbLf & ” ” & vbLf & _

    ”                     Arrivederci  al  prossimo  ordine !!”, vbInformation + vbOKOnly, “Powered By Angelo”

    ActiveWorkbook.Save ‘ Close SaveChanges:=True

    Application.Quit

    Exit Sub

    Else

    MsgBox ”      LA  CONNESSIONE  INTERNET  AL  MOMENTO  E’ ASSENTE !!” & vbLf & ” ” & vbLf & _

    ”     La  mail  di  richiesta  materiale  verrà  parcheggiata  in  Outlook ,” & vbLf & _

    ”      al  ripristino  della  connessione  sarà  inviata  automaticamente”, vbCritical, “Powered By Angelo”

    ActiveWorkbook.Save ‘Close SaveChanges:=True

    Application.Quit

    Exit Sub

    End If

    End Select

     

    RigErr:

    MsgBox Err.Number & vbNewLine & Err.Description

    wk2.Close SaveChanges:=False

    Kill (percorso4)

    Set sh2 = Nothing

    Set sh1 = Nothing

    Set wk1 = Nothing

    Set wk2 = Nothing

    MsgBox ”    ATTENZIONE  !!!      SI  E’  VERIFICATO  UN  ERRORE  IMPREVISTO” & vbLf & _

    ”       DURANTE  CREAZIONE  DEL  FILE  DA  ALLEGARE  ALLA  MAIL” & vbLf & ” ” & vbLf & _

    “Riperete  la  procedura  di  invio  ordine  facendo  un  ultimo  tentativo,” & vbLf & _

    ”  se  il  problema  si  ripresenta,  inviare  l’ordine  in  modo  manuale” & vbLf & ” ” & vbLf & _

    Err.Number & vbNewLine & Err.Description, vbCritical, “Powered By Angelo”

    Exit Sub

    End Sub

     

     

     

     

    Utilizzando il sito, accetti l'utilizzo dei cookie da parte nostra. maggiori informazioni

    Questo sito utilizza i cookie per fornire la migliore esperienza di navigazione possibile. Continuando a utilizzare questo sito senza modificare le impostazioni dei cookie o cliccando su "Accetta" permetti il loro utilizzo.

    Chiudi