I just started in VBA.
I create a vba code to send emails via Outlook. However, the code works when opening the mail, the logo appears and disappears in a second and instead there is a red cross. I do not understand where the problem comes from. Here's my code:
Private Sub EnvoyerMail()
Dim Mail As Variant
Dim Ligne As Integer
Dim Nom_Fichier As String
Dim DernLigne As Long
Dim SigString As String
Dim Signature As String
Dim strBody As String
Set Mail = CreateObject("Outlook.Application")
DernLigne = Range("A1048576").End(xlUp).Row
For Ligne = 2 To 3 'DernLigne ' A changer selon la taille du fichier
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signatures\"
f = Dir(SigString & "*.htm")
If f <> "" Then
Signature = GetBoiler(SigString & f)
Signature = Replace(Signature, "src=""", "src=""" & SigString)
Else
Signature = ""
End If
On Error Resume Next
With Mail.CreateItem(olMailItem)
'.HTMLBody = Signature
strBody = _
"<Body>Bonjour,<br /><br /></Body>" & _
"<Body>Veuillez trouver ci-joint le rapport énergétique du mois dernier pour votre site.<br /><br /> Nous vous enverrons de manière régulière des rapports.<br />Notre objectif est de maintenir en continu un équilibre entre économies d’énergie et confort.<br /><br /></Body>" & _
"<Body>Remarque: Ce rapport est créé de façon automatique, si vous remarquez une erreur, n’hésitez pas à nous faire un retour.<br /><br /></Body>"
Nom_Fichier = Range("A" & Ligne) 'Chercher la pièce jointe
.Display
.Save
.Subject = Range("B" & Ligne)
.To = Range("C" & Ligne)
.CC = Range("D" & Ligne)
'.BCC = Range("" & Ligne)
.HTMLBody = strBody & Signature
.Attachments.Add Nom_Fichier
.Display
.Send
End With
Next Ligne
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function GetSignature(fPath As String) As String
Dim fso As Object
Dim TSet As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
GetSignature = TSet.readall
TSet.Close
End Function
This may stumble upon the code to be changed.
Option Explicit
Private Sub EnvoyerMail_Signature_Then_EditedSignature_Demo()
' Excel code and loop not needed for this demo
Dim Mail As Object
Dim SigString As String
Dim Signature As String
Dim strBody As String
Dim F As String
Set Mail = CreateObject("Outlook.Application")
SigString = Environ("appdata") & "\Microsoft\Signatures\"
' Change only Mysig.htm to the name of your signature
' F = dir(SigString & "Mysig.htm")
' With the * wildcard it is too vague if more than one signature
F = dir(SigString & "*.htm")
If F <> "" Then
' signature of unknown composition
Signature = GetBoiler(SigString & F)
' edited signature of unknown composition
Signature = Replace(Signature, "src=""", "src=""" & SigString)
Else
Signature = ""
End If
' Default signature
With Mail.CreateItem(olMailItem)
.Display
MsgBox "Mail #1 - Default signature" & vbCr & vbCr & "Default signature displays and becomes part of .HTMLBody"
strBody = _
"<Body>Bonjour,<br /><br /></Body>" & _
"<Body>Veuillez trouver ci-joint le rapport ?nerg?tique du mois dernier pour votre site.<br /><br /> Nous vous enverrons de mani?re r?guli?re des rapports.<br />Notre objectif est de maintenir en continu un ?quilibre entre ?conomies d??nergie et confort.<br /><br /></Body>" & _
"<Body>Remarque: Ce rapport est cr?? de fa?on automatique, si vous remarquez une erreur, n?h?sitez pas ? nous faire un retour.<br /><br /></Body>"
' Ignore edited F = dir(SigString ...
' Overwrite body, which is currently the default signature, with strBody and current .HTMLBody
.HTMLBody = strBody & .HTMLBody
MsgBox "Mail #1 - Default signature" & vbCr & vbCr & _
"Entire body, including default signature, overwritten by strBody and current .HTMLBody"
End With
' Edited F = dir(SigString ...
With Mail.CreateItem(olMailItem)
.Display
MsgBox "Mail #2 - Edited F = dir(SigString ..." & vbCr & vbCr & "Default signature displays and becomes part of .HTMLBody"
strBody = _
"<Body>Bonjour,<br /><br /></Body>" & _
"<Body>Veuillez trouver ci-joint le rapport ?nerg?tique du mois dernier pour votre site.<br /><br /> Nous vous enverrons de mani?re r?guli?re des rapports.<br />Notre objectif est de maintenir en continu un ?quilibre entre ?conomies d??nergie et confort.<br /><br /></Body>" & _
"<Body>Remarque: Ce rapport est cr?? de fa?on automatique, si vous remarquez une erreur, n?h?sitez pas ? nous faire un retour.<br /><br /></Body>"
' Overwrite body, which is currently the signature, with strBody and edited F = dir(SigString ...
.HTMLBody = strBody & Signature
MsgBox "Mail #2 - Edited F = dir(SigString ..." & vbCr & vbCr & _
"Entire body, including default signature, overwritten by strBody and edited version of signature found by" & vbCr & vbCr & _
" F = dir(SigString ..." & vbCr & vbCr & _
"dir(SigString ... is not necessarily the same as the default signature if there is more than one signature."
End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
Function GetSignature(fPath As String) As String
Dim FSO As Object
Dim TSet As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSet = FSO.GetFile(fPath).OpenAsTextStream(1, -2)
GetSignature = TSet.ReadAll
TSet.Close
End Function
Related
I have the bellow code to send automatic mails when some elements of my database are about to end ( 2 months before the ending dates), however I want the mails to be send once a week is there possible ?
How can I do that ?
Thanks for your suggestions
Dim Desti As String, Objet As String, Corps As String, olApp As Object
Sub AlertesDatesFormations() ' Formations externes
Dim Sh As Worksheet, Chaine As String, Lig As Integer, Alerte
Set olApp = CreateObject("Outlook.application")
Lig = 15 ' car les dates de validité se trouvent en ligne 15
For Each Sh In ActiveWorkbook.Sheets
If Sh.Range("A10") = "Formation externe " Then 'Formation concernée
Col = 2 ' car la premiére date de validité en en colonne B
While Sh.Cells(Lig - 5, Col) <> "" ' on regarde toutes les formations dans la colonne A10 (15-5=10)
If Sh.Cells(Lig, Col) <> "" And Sh.Cells(Lig, Col) < Date + 60 Then ' si formation et date
' on enrichit la chaine avec nom-date-formation
Chaine = Chaine & Sh.Name & vbTab & " Date: " & Sh.Cells(Lig, Col) & " " & Sh.Cells(Lig - 1, Col) & vbCrLf
End If
Col = Col + 1
Wend
If Chaine <> "" Then Chaine = Chaine & vbCrLf
End If
Next Sh
If Chaine <> "" Then
'MsgBox(Chaine, , "Alertes sur les dates de validit?formations.")
' Alerte = MsgBox(Chaine, , "Alertes sur les dates de validitéformations.")
MsgBox Chaine, , "Alertes sur les dates de validité formations."
Desti = "annabelle.delecour#nexans.com"
Objet = "Alertes sur les dates de validité des Formations Externes "
Corps = "Bonjour, ce message est un mail automatique, il vous informe sur la fin de valdité des formations externes, Merci "
EnvoiMail Desti, Objet, Corps
End If
End Sub
Sub EnvoiMail(Desti As String, Objet As String, Corps As String)
Dim M As Object
Set M = olApp.CreateItem(olMailItem)
With M
.Subject = Objet
.Body = Corps
.Recipients.Add Desti
.cc = "pascal.deguines#nexans.com;nicolas.debeyer#nexans.com"
.send
End With
End Sub
You have a concept problem. A macro doesn't run programatically and run only if the excel is open.
The problem to solve is easy, create an automatic task in windows, this task only have to do is open your excel file, in your excel file in vba in the workbookopen event call your macro and then close your file.
STEPS
1.Modify your Excel // VBA thiswoorbook event open call your macro sendmail
2.Create an automatic task weekly in windows this task only have to open your excel file
I use a code to generate pdf and to merge with others pdfs. But the pdfs I merge are upside down. The original pdfs are right side up. All codes and functions are here in the order of process.
Code saving originals in a file and create one with all merged using pdfforge.
Edit : I reduce my code here, first I get the different pdfs, second I launch functions to merge its.
recuperer_PJ strChemin3, "Ticket", "Ticket_FO_Documents", "(((Ticket.[Ticket_FO_Numéro ticket])='" & Me![Ticket_FO_Numéro ticket] & "'))"
recuperer_PJ strChemin3, "Ticket", "Ticket_FO_Justificatif_Delegation", "(((Ticket.[Ticket_FO_Numéro ticket])='" & Me![Ticket_FO_Numéro ticket] & "'))"
recuperer_PJ strChemin3, "Ticket", "[Ticket_FO_Pièces jointes]", "(((Ticket.[Ticket_FO_Numéro ticket])='" & Me![Ticket_FO_Numéro ticket] & "'))"
recuperer_PJ strChemin3, "Ticket", "Ticket_MO_Documents", "(((Ticket.[Ticket_FO_Numéro ticket])='" & Me![Ticket_FO_Numéro ticket] & "'))"
recuperer_PJ strChemin3, "Ticket", "Ticket_BO_Documents", "(((Ticket.[Ticket_FO_Numéro ticket])='" & Me![Ticket_FO_Numéro ticket] & "'))"
recuperer_PJ strChemin3, "Ticket", "Ordre_Justificatif_Validation", "(((Ticket.[Ticket_FO_Numéro ticket])='" & Me![Ticket_FO_Numéro ticket] & "'))"
recuperer_PJ strChemin3, "Ticket", "Ticket_BO_Documents_Conformité", "(((Ticket.[Ticket_FO_Numéro ticket])='" & Me![Ticket_FO_Numéro ticket] & "'))"
'Fusion des PJ
PilotageMacro1 strChemin3, strChemin2 & "\" & Me![Ticket_FO_Numéro ticket] & " - " & Me!Titre & ".pdf"
FileMove strChemin2 & "\" & Me![Ticket_FO_Numéro ticket] & " - " & Me!Titre & ".pdf", strChemin3 & "\" & Me![Ticket_FO_Numéro ticket] & " - " & Me!Titre & " initial complet.pdf"
function to save and launch the "mergage"
Public Sub recuperer_PJ(ByVal strNomDestination As String, ByVal strTable As String, ByVal strChamp As String, ByVal strWhere As String)
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim strSQL As String
' Se positionner sur l'enregistrement souhaité
strSQL = "SELECT * FROM " & strTable & " WHERE" & strWhere & ";"
Set rst1 = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
' Obtenir le "sous-recordset" des pièces jointes
Set rst2 = rst1(strChamp).Value
' Lister les pièces jointes
While Not rst2.EOF
test = 0
dossier = strNomDestination & "\"
Do While Not test = 1
txt = Dir(dossier & rst2.Fields("FileName"))
If txt = "" Then
test = 1
Else
dossier = dossier & "_"
End If
Loop
dossier = dossier & rst2.Fields("FileName")
rst2.Fields(0).SaveToFile dossier
rst2.MoveNext
Wend
' On ferme les 2 Recordsets
rst2.Close
Set rst2 = Nothing
rst1.Close
Set rst1 = Nothing
End Sub
functions to merge
Public Sub PilotageMacro1(ByVal dossierFusion As String, ByVal dossierSortie As String)
Dim Xl As Excel.Application
Dim wbk As Excel.Workbook
' Démarrer Excel et le rendre visible
Set Xl = New Excel.Application
Xl.Visible = False
' Ouvrir le classeur qui contient les macros
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT [Lien PDF] FROM Paramêtres")
Lien_PDF = rs.Fields(0)
Set wbk = Xl.Workbooks.Open(Lien_PDF & ".xlsm")
'Set wbk = xl.Workbooks.Open(Lien_Dossier_Tickets & "\A_ne_pas_supprimer_G2T.xlsm")
' Exécuter une macro
Xl.Run "SelDossierFusion", dossierFusion, dossierSortie
' Fermer le classeur sans l'enregistrer
wbk.Close False
Set wbk = Nothing
' Quitter Excel
Xl.Quit
Set Xl = Nothing
End Sub
Option Explicit
Dim Cpt As Long
Dim Tableau() As Variant
Const TypeFichier As String = "*.pdf"
Private Sub Fusion(ByVal dossierSortie As String)
Dim Pdf As Object
Set Pdf = CreateObject("pdfforge.pdf.pdf")
Pdf.MergePDFFiles_2 Tableau, dossierSortie, True
Set Pdf = Nothing
End Sub
Private Sub ListeFichiers(ByVal sChemin As String, ByVal Recursif As Boolean)
Dim FSO As Object
Dim Dossier As Object
Dim SousDossier As Object
Dim Fichier As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Dossier = FSO.GetFolder(sChemin)
For Each Fichier In Dossier.Files
If UCase(Fichier.Name) Like UCase(TypeFichier) Then
ReDim Preserve Tableau(Cpt)
Tableau(Cpt) = Fichier.Path
Cpt = Cpt + 1
Application.StatusBar = Cpt
End If
Next Fichier
If Recursif Then
For Each SousDossier In Dossier.SubFolders
ListeFichiers SousDossier.Path, True
Next SousDossier
End If
Set Dossier = Nothing
Set FSO = Nothing
End Sub
Sub SelDossierFusion(ByVal dossierFusion As String, ByVal dossierSortie As String)
Dim sChemin As String
Dim FSO As Object
Dim Dossier As Object
sChemin = dossierFusion
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Dossier = FSO.GetFolder(sChemin)
' ListeFichiers récursive ou non True/False
ListeFichiers Dossier, True
Fusion (dossierSortie)
Set FSO = Nothing
End Sub
I am trying to delete empty rows in every sheet using this code in Excel 2010:
Private Sub CommandButton1_Click()
Dim I As Integer
'For all sheets...
For I = 1 To Sheets.Count
'select corresponding sheet
Sheets(I).Select
Sheets(I).Activate
'write delete code
For fila = 1 To 10
If Cells(fila, 4).Value = "" Then
Rows(fila).Delete
End If
Next fila
'Go to next sheet
Next
End Sub
This code only deletes rows on my first active sheet.
Always remember to loop backward when deleting objects (in your case rows), so use For i = 10 to 1 Step -1.
Also, try to avoid using Select and Activate, instead you could directly reference the Worksheet or Range. In this case use directly the ws defined as Worksheet, to see if If ws.Cells(fila, 4).Value = ""
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim I As Integer, fila As Long
Dim ws As Worksheet
' loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
' loop backwards when deleting objects
For fila = 10 To 1 Step -1
If ws.Cells(fila, 4).Value = "" Then ws.Rows(fila).Delete
Next fila
Next ws
End Sub
Maybe this solution will help you :
It will clean all worksheets in your workbook and delete empty rows.
In the end, msg box will tell you the percentage of rows that were deleted for each sheet.
Best regards,
Sub Clean()
Dim Sht As Worksheet, DCell As Range, Calc As Long, Rien As String, Avant As Double, plage As Range
On Error Resume Next
Calc = Application.Calculation ' ---- mémorisation de l'état de
recalcul
'------------------------------------------------------------
MsgBox "Pour le classeur actif : " _
& Chr(10) & ActiveWorkbook.FullName _
& Chr(10) & "dans chaque feuille de calcul" _
& Chr(10) & "recherche la zone contenant des données," _
& Chr(10) & "réinitialise la dernière cellule utilisée" _
& Chr(10) & "et optimise la taille du fichier Excel", _
vbInformation, _
"d'après LL par GeeDee#m6net.fr"
'-------------------------------------------------------------
MsgBox "Taille initiale de ce classeur en octets" _
& Chr(10) & FileLen(ActiveWorkbook.FullName), _
vbInformation, ActiveWorkbook.FullName
'------------------------------------------------------------
With Application
.Calculation = xlCalculationManual
.StatusBar = "Nettoyage en cours..."
.EnableCancelKey = xlErrorHandler
.ScreenUpdating = True
End With
'-------------------- le traitement
For Each Sht In Worksheets
Avant = Sht.UsedRange.Cells.Count
Application.StatusBar = Sht.Name & "-" & Sht.UsedRange.Address
'-------------------Traitement de la zone trouvée
If Sht.UsedRange.Address <> "$A$1" Or Not IsEmpty(Sht.[A1]) Then
Set DCell = Sht.Cells.Find("*", , , , xlByRows, xlPrevious)(2)
'----------------Suppression des lignes inutilisées
If Not DCell Is Nothing Then
Sht.Range(DCell, Sht.Cells([A:A].Count, 1)).EntireRow.Delete
Set DCell = Nothing
Set DCell = Sht.Cells.Find("*", , , , xlByColumns, xlPrevious)(, 2)
'----------------Suppression des colonnes inutilisées
If Not DCell Is Nothing Then Sht.Range(DCell, Sht.[IV1]).EntireColumn.Delete
End If
Rien = Sht.UsedRange.Address
End If
ActiveWorkbook.Save
'---------------------Message pour la feuille traitée
MsgBox "Nom de la feuille de calcul :" _
& Chr(10) & Sht.Name _
& Chr(10) & Format(Sht.UsedRange.Cells.Count / Avant, "0.00%") & " de la taille initiale", _
vbInformation, ActiveWorkbook.FullName
Next Sht
'--------------------Message fin de traitement
MsgBox "Taille optimisée de ce classeur en octets " & Chr(10) & FileLen(ActiveWorkbook.FullName), _
vbInformation, _
ActiveWorkbook.FullNameActive
'--------------------
Application.StatusBar = False
Application.Calculation = Calc
End Sub
I'd like to include the value of each not empty cell in the message to send, but I don't know which is the good syntax to use?
Private Sub CommandButton6_Click()
Dim MailAd As String
Dim Msg As String
Dim Subj As String
Dim URLto As String
Dim Nom As String
Nom = "User name"
Dim Pole As String
Pole = " POLE"
Dim Texte As String
Texte = " Thanks for the informations you send to me "
'Sélectionne la cellule correspondant à l'adresse mail de la ligne :
If ComboBox1.ListIndex <> -1 Then Cells(ComboBox1.ListIndex + 2, 8).Select
'Le mail est adressé sur la base de la cellule active :
MailAd = TextBox7
Range("A2:J32").Select
Selection.Copy
Dim StrBody As String
StrBody = Sheets("FICHIER ADRESSES").Range("A2").Value
'Copie = TextBox.2 'bien mentionner le n° de la texbox
Subj = "Message à l'attention de " 'Objet du message automatique mais on peut faire réféence à une TextBox
Msg = Msg & "Bonjour " & TextBox2.Text & ",%0D%0A %0D%0A" 'Corps du message
'Msg = Msg & "Bonjour " & Selection.Insert & ",%0D%0A %0D%0A"
Msg = Msg & Texte & StrBody & ",%0D%0A %0D%0A" & Nom & Pole & "%0D%0A %0D%0A" 'Corps du message
URLto = "mailto:" & MailAd & "?subject=" & Subj & "&body=" & Msg & "&Cc=" '& copie
ActiveWorkbook.FollowHyperlink Address:=URLto
End Sub
Presuming you are talking about the range A2:J32 and want the values to show in your "msg" string: (this is untested)
Private Sub CommandButton6_Click()
Dim MailAd As String
Dim Msg As String
Dim Subj As String
Dim URLto As String
Dim Nom As String
Nom = "User name"
Dim Pole As String
Pole = " POLE"
Dim Texte As String
Texte = " Thanks for the informations you send to me "
'Sélectionne la cellule correspondant à l'adresse mail de la ligne :
If ComboBox1.ListIndex <> -1 Then Cells(ComboBox1.ListIndex + 2, 8).Select
'Le mail est adressé sur la base de la cellule active :
MailAd = TextBox7
Range("A2:J32").Select
Dim rngCell as Range, sNonEmpty as string
For each rngCell in Range("A2:J32")
if rngcell.value <> "" then snonempty = _
iif(snonempty="",rngcell.value,snonempty & ", " & rngcell.value)
Next
Selection.Copy
Dim StrBody As String
StrBody = Sheets("FICHIER ADRESSES").Range("A2").Value
'Copie = TextBox.2 'bien mentionner le n° de la texbox
Subj = "Message à l'attention de " 'Objet du message automatique mais on peut faire réféence à une TextBox
Msg = Msg & "Bonjour " & TextBox2.Text & ",%0D%0A %0D%0A" 'Corps du message
'Msg = Msg & "Bonjour " & Selection.Insert & ",%0D%0A %0D%0A"
Msg = Msg & Texte & StrBody & ",%0D%0A %0D%0A" & Nom & Pole & "%0D%0A %0D%0A" & VBNEWLINE & _
"YOUR VALUES: " & sNonEmpty 'Corps du message
URLto = "mailto:" & MailAd & "?subject=" & Subj & "&body=" & Msg & "&Cc=" '& copie
ActiveWorkbook.FollowHyperlink Address:=URLto
End Sub
I am trying to send emails to a list of recipients in an Excel spreadsheet, with a different attachment for each of the emails.
I created a macro that generates the different emails, but when I added attachments, only the first email of the list is created with the correct attachment.
When the loop comes back to the second email it gives me an error message saying that the attachment was not found (I assume this is for the second message).
I checked and the file names and paths are correct according to the rules I set in the code. It doesn't create a draft of the second email, but simply tells me the file was not found.
How can I generate all of the emails with their proper attachments?
The code is as follows:
Sub clientemails()
Dim pfolio As String
Dim destino As String
Dim mo As String
Dim text As String
Dim subject As String
Dim CC As String
Dim signature As String
Dim officer As String
Dim yr As String
Dim date1 As String
Dim position As String
Dim analysis As String
Dim activities As String
Dim nl As Integer
Dim i As Integer
Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.mailitem
Set OutlookApp = New Outlook.Application
nl = Cells(5, 1).End(xlDown).Row
i = 5
yr = Cells(1, 6).Value
date1 = Format(Cells(1, 4).Value, "mm.dd.yy")
While nl + 1 > i
pfolio = Cells(i, 2).Value
destino = Cells(i, 3).Value
officer = Cells(i, 10).Value
CC = Cells(i, 11).Value
Set MItem = OutlookApp.CreateItem(olmailitem)
If Cells(i, 9) = "P" Then
mo = Cells(1, 3)
subject = "Posição e Análise " & pfolio
text = "<p><font face=arial size=3>Bom Dia,</p>" _
& "<p>Segue em anexo a posição e análise da carteira " & pfolio & " referente ao mês de " & mo & ". Caso tenha quaisquer dúvidas, favor entrar em contato conosco.</p>" _
& "Atenciosamente,"
ElseIf Cells(i, 9) = "E" Then
month = Cells(2, 3)
subject = pfolio & " Statement and Analysis"
text = "<p><font face=arial size=3>Hello,</p>" _
& "<p>Please find attached the portfolio statement and analysis for the " & pfolio & " portfolio for the month of " & mo & ". Should you have any questions, please don't hesitate to contact us.</p>" _
& "Sincerely,"
End If
If Cells(i, 4) = "X" Then
position = "F:\Files\General Folders\3 Clients\" & officer & "\" & pfolio & "\Position\" & yr & "\" & pfolio & " Portfolio Statement Summary " & date1 & ".pdf"
With MItem
.Attachments.Add position
End With
End If
If Cells(i, 5) = "X" Then
analysis = "F:\Files\General Folders\3 Clients\" & officer & "\" & pfolio & "\Portfolio Analysis\" & yr & "\" & pfolio & " Portfolio Analysis " & date1 & ".pdf"
With MItem
.Attachments.Add analysis
End With
End If
If Cells(i, 6) = "X" Then
activities = "F:\Files\General Folders\3 Clients\" & officer & "\" & pfolio & "\Portfolio Activities\" & yr & "\" & pfolio & " Portfolio Activities " & date1 & ".pdf"
With MItem
.Attachments.Add activities
End With
End If
With MItem
.Display
End With
signature = MItem.HTMLBody
With MItem
.subject = subject
.To = destino
.CC = CC
.HTMLBody = text & signature
.Save
End With
i = i + 1
Wend
End Sub
I understand you are supposed to save your mail item before adding attachments. So you might need
MItem.SaveAs('some path name', olTXT)
before you add each attachment.
EDIT: Or perhaps it's best to simply use
MItem.Save
I recently make an library in order to send email with macros VBA. I use Microsoft CDO technology to do it, so it doesn't depend on client messagerie like Outlook or Thunderbird. It's only depend on SMTP server.
Enjoy.
'---------------------------------------------------------------------------
' Constantes and global variables
'---------------------------------------------------------------------------
Const CONFIG_ACTIVE_SEND_EMAIL = True
Const CONFIG_SMTP_SERVER As String = "smtp.host"
Const CONFIG_SMTP_PORT As String = "25"
Const CONFIG_SMTP_AUTHENTICATE = "0"
Const CONFIG_SMTP_USERNAME = "20100"
Const CONFIG_SMTP_PASSWORD = "seeyousoon"
Const CONFIG_SMTP_SSL = "false"
Dim SEND_TRACE_ACTIVATE As Boolean
Dim SEND_TRACE_EMAIL As String
Global LOG_ACTIVATE As Boolean
Global LOG_FILEPATH As String
'---------------------------------------------------------------------------
' Pour envoyer un email avec un serveur SMTP avec la technologie CDO.Message
'---------------------------------------------------------------------------
' #param String expediteur : l'expediteur de l'email
' #param String destinataires : le ou les destinataires de l'email (ex: "email1#aot.org; email2#aot.org")
' #param String sujet : le sujet de l'email
' #param String body : le contenu du message de l'email (ex: "Hello" & vbNewLine & "See you soon")
' #param Optional String carbon_copy : Addresse(s) pour Carbon-Copy (envoyer un email à plusieurs personnes)
' #param Optional String blind_carbon_copy : Idem que carbon copy sauf que dans l'en-tête la liste des personnes en copie est cachée.
' #param Optional Variant fichiers_joints : String ou Array(String) de chemin de fichiers à joindre dans l'email (max:8mo en tout)
' #param Optional Boolean opt_sendTraceActivate : pour activer la récuperation de la trace d'envoi (par défaut envoi à l'expediteur de l'email). Active forcement l'option opt_logActivate = true.
' #param Optional String opt_sendTraceEmail : pour changer l'email de reception de la trace d'envoi (par défaut envoi à l'expediteur de l'email)
' #param Optional Boolean opt_logActivate : pour activer le log
' #param Optional String opt_logFilePath : pour changer le chemin du fichier log (par defaut = Application.ActiveWorkbook.Path & "log.txt")
'---------------------------------------------------------------------------
Sub sendEmail( _
expediteur As String, _
destinataires As String, _
sujet As String, _
body As String, _
Optional carbon_copy As String = "", _
Optional blind_carbon_copy As String = "", _
Optional fichiers_joints As Variant, _
Optional opt_sendTraceActivate As Boolean = False, _
Optional opt_sendTraceEmail As String = "", _
Optional opt_logActivate As Boolean = False, _
Optional opt_logFilePath As String = "")
'-- Gestion option sendTrace
If opt_sendTraceActivate = True Then
opt_logActivate = True
SEND_TRACE_ACTIVATE = True
SEND_TRACE_EMAIL = expediteur
If Not opt_sendTraceEmail = "" Then
SEND_TRACE_EMAIL = opt_sendTraceEmail
End If
End If
'-- Gestion option log
If opt_logActivate = True Then
LOG_ACTIVATE = True
LOG_FILEPATH = Application.ActiveWorkbook.Path & "\log_email.txt"
If Not opt_logFilePath = "" Then
LOG_FILEPATH = opt_logFilePath
End If
LogFileDelete
End If
'-- Gestion option carbon_copy et blind_carbon_copy pour affichage dans le debug
Dim carbon_copy_str As String
Dim blind_carbon_copy_str As String
If carbon_copy = "" Then
carbon_copy_str = "#vide#"
End If
If blind_carbon_copy = "" Then
blind_carbon_copy_str = "#vide#"
End If
'-- Log du traitement (ne fonctionne que si l'option opt_logActivate est à true
date_now = Now()
LogInformation " "
If CONFIG_ACTIVE_SEND_EMAIL = True Then
LogInformation "---[ DEBUT DU TRAITEMENT]---"
Else
LogInformation "---[ DEBUT DU TRAITEMENT (mode simulation) ]---"
End If
LogInformation " _________________________________"
LogInformation " "
LogInformation " PADI-Excel email (v0.0.1) "
LogInformation " _________________________________"
LogInformation " "
LogInformation " * Informations *"
LogInformation " -> Macro du classeur = " & ThisWorkbook.Name
LogInformation " -> Utilisateur = " & Application.UserName
LogInformation " -> Debut traitement = " & Format(date_now, "yyyy-mm-dd hh:mm:ss")
LogInformation " -> SMTP Server = " & CONFIG_SMTP_SERVER
LogInformation " -> SMTP Port = " & CONFIG_SMTP_PORT
LogInformation " -> SMTP Username = " & CONFIG_SMTP_USERNAME
LogInformation " -> SMTP SSL = " & CONFIG_SMTP_SSL
LogInformation " -> Option sendTrace = " & SEND_TRACE_ACTIVATE
LogInformation " -> Email sendTrace = " & SEND_TRACE_EMAIL
LogInformation " "
LogInformation " * Propriétés email *"
LogInformation " -> Expediteur = " & expediteur
LogInformation " -> Destinataires = " & destinataires
LogInformation " -> Subject eMail = " & sujet
LogInformation " -> Carbon copy = " & carbon_copy_str
LogInformation " -> Blind CC = " & blind_carbon_copy_str
LogInformation " "
LogInformation " -> Body eMail:"
LogInformation "{{-------------------------------}}"
LogInformation body
LogInformation "{{-------------------------------}}"
LogInformation " "
'-- Création de l'objet CDO (pour créer en envoyer l'email + headers email)
Dim objCDO As Object
Set objCDO = CreateObject("CDO.Message")
'-- Configuration du serveur SMTP
With objCDO.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = CONFIG_SMTP_SERVER
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CONFIG_SMTP_PORT
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = CONFIG_SMTP_AUTHENTICATE
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = CONFIG_SMTP_SSL
End With
'-- Configuration authentification SMTP (si nécessaire)
If CONFIG_SMTP_AUTHENTICATE = "1" Then
With objCDO.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = CONFIG_SMTP_USERNAME
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = CONFIG_SMTP_PASSWORD
End With
End If
'-- Mise à jour de la configuration CDO
objCDO.Configuration.Fields.Update
'-- Création du mail à envoyer
With objCDO
.From = expediteur
.To = destinataires
.Subject = sujet
.TextBody = body
.Cc = carbon_copy
.Bcc = blind_carbon_copy
End With
'-- Création du mail à envoyer : ajout de 1 ou plusieurs fichiers joint (si renseigné)
LogInformation " -> fichiers joints:"
LogInformation "{{-------------------------------}}"
If Not IsMissing(fichiers_joints) Then
If IsArray(fichiers_joints) Then
For i = LBound(fichiers_joints) To UBound(fichiers_joints)
objCDO.AddAttachment fichiers_joints ' "C:\temp\Bon de commande.pdf"
Next i
Else
LogInformation " 1 fichiers joints :"
LogInformation " -> " & fichiers_joints
objCDO.AddAttachment fichiers_joints ' "C:\temp\Bon de commande.pdf"
End If
Else
LogInformation "#aucun#"
End If
LogInformation "{{-------------------------------}}"
'-- Envoi de l'email
If CONFIG_ACTIVE_SEND_EMAIL = True Then
objCDO.Send
End If
LogInformation " "
LogInformation " -> email envoyé à " & Format(date_now, "yyyy-mm-dd hh:mm:ss")
LogInformation " "
LogInformation "---[ FIN DU TRAITEMENT]---"
LogInformation " "
End Sub
'----------------------------------------------------
' Ajoute un message dans le fichier log déclaré dans la variable LOG_FILEPATH
' uniquement si le log est activé avec la variable LOG_ACTIVATE
'----------------------------------------------------
' #param String logMessage : le message à ajouter dans le fichier log
'----------------------------------------------------
Sub LogInformation(logMessage As String)
If LOG_ACTIVATE = True Then
Dim FileNum As Integer
FileNum = FreeFile ' next file number
Open LOG_FILEPATH For Append As #FileNum ' creates the file if it doesn't exist
Print #FileNum, logMessage ' write information at the end of the text file
Close #FileNum ' close the file
End If
End Sub
'----------------------------------------------------
' Pour supprimer le fichier log en début de traitement
'----------------------------------------------------
Sub LogFileDelete()
On Error Resume Next ' ignore possible errors
Kill LOG_FILEPATH ' delete the file if it exists and it is possible
On Error GoTo 0 ' break on errors
End Sub
'----------------------------------------------------
' Fonction pour tester si un repertoire (ex: c:\test\foo\) existe
'----------------------------------------------------
' #param String folderPath : le répertoire à tester
' #return Boolean (true, le répertoire existe et false sinon)
'----------------------------------------------------
Function is_folder_exist(folderPath As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
If Right(folderPath, 1) <> "\" Then
folderPath = folderPath & "\"
End If
If FSO.FolderExists(folderPath) = False Then
is_folder_exist = False
Else
is_folder_exist = True
End If
End Function
'----------------------------------------------------
' Fonction pour tester si un fichier (ex: c:\test\foo\sample.txt) existe
'----------------------------------------------------
' #param String filePath : le fichier à tester
' #return Boolean (true, le répertoire existe et false sinon)
'----------------------------------------------------
Function is_file_exist(filePath As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FileExists(filePath) = False Then
is_file_exist = False
Else
is_file_exist = True
End If
End Function
Example of use it :
sendEmail _
"from_email#acme.com", _
"to_email#acme.com", _
"Subjet", _
"Hello," & vbCrLf & "rfxc", _
opt_logActivate:=True, _
fichiers_joints:="c:\test1.pdf"