Et oui, encore moi avec mes macros.
Pour ma future activité, je crée une facture sous Excel. J’ai créé une macro qui permet d’enregistrer la facture dans un dossier portant le nom du client, le fichier étant automatiquement nommé avec la date et le numéro de facture. Voilà le code.
Sub Enregistrement()
Dim Chemin1$, Chemin2$, Client$, Fichier$, Numfact$, Jour$
Chemin1 = "D:\Gestion\Factures\"
Chemin2 = "H:\Zerobug backup\Factures\"
Jour = Format(Day(Now()), "00") & Format(Month(Now()), "00") & Year(Now)
Client = Range("G4")
Numfact = Range("H12")
Fichier = Jour & "_" & Numfact & ".xls"
If Dir(Chemin1 & Client, 16) = "" Then MkDir Chemin1 & Client
ActiveWorkbook.SaveAs Chemin1 & Client & "\" & Fichier
If Dir(Chemin2 & Client, 16) = "" Then MkDir Chemin2 & Client
ActiveWorkbook.SaveAs Chemin2 & Client & "\" & Fichier
End Sub
Maintenant, je cherche à ce que ma feuille soit automatiquement générée en PDF avec le même nom et, si possible, qu’un mail soit automatiquement ouvert avec le fichier au format PDF en pièce jointe.
Si quelqu’un peut m’aider…
Pour le fichier au format pdf, tu peux installer une pseudo-imprimante (ex : pdfCreator)
Tu lances ton impression sur cette imprimantes et tu obtiens un fichier de sortie au format pdf
Pour le mail, tout dépend du client mail dont tu disposes.
Si tu sais le lancer en ligne de commande (pas seulement l’ouvrir, mais lui passer l’adresse, le texte et la pj), tu pourras l’activer via la commande system de VBA
Regarde [ici](http://www.vbfrance.com/codes/ENVOI-AUTOMATIQUE-MAIL-AVEC-PIECE-JOINTE-VBA-EXCEL_31545.aspx)
Ca fonctionne avec thunderbid, mais d'après le code le cas outlook a aussi été traité
Bon, ça progresse doucement, mais toujours pas au point.
Voilà la dernière version de ma macro :
Sub Enregistrement()
Dim Chemin1$, Chemin2$, Client$, Fichier$, Numfact$, Jour$, F$, N$
Chemin1 = "H:\Zerobug backup\Factures\"
Chemin2 = "D:\Gestion\Factures\"
Jour = Format(Now(), "ddmmyyyy")
Client = Range("H7")
Numfact = Range("I15")
Fichier = Jour & "_" & Numfact & ".xls"
If Dir(Chemin1 & Client, 16) = "" Then MkDir Chemin1 & Client
ActiveWorkbook.SaveAs Chemin1 & Client & "\" & Fichier
If Dir(Chemin2 & Client, 16) = "" Then MkDir Chemin2 & Client
ActiveWorkbook.SaveAs Chemin2 & Client & "\" & Fichier
N = Jour & "_" & Numfact
F = Application.GetSaveAsFilename(N, "fichier pdf,*.pdf")
Application.ActivePrinter = "Adobe PDF sur Ne03:"
SendKeys N & "{ENTER}", False
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
"Adobe PDF sur Ne03:"
End Sub
Donc, ça m’enregistre bien mon fichier XLS avec le bon nom et dans le bon dossier (nom et prénom du client qui fait référence à la cellule H7), ça me lance ensuite “l’impression” PDF via l’imprimante Acrobat, avec là aussi le bon nom. Mais je dois sélectionner le dossier de destination, et même en sélectionnant le bon dossier de destination, il l’enregistre dans C:\Mes Documents (qui fait référence au port de l’imprimante PDF). Vous me direz bien que le plus simple serait de modifier le port de l’imprimante, mais vu que chaque PDF est enregistré dans un dossier différent, ça ne me convient pas.
Je rappelle que j’utilise Acrobat 7.
Merci à l’âme charitable qui pourrait venir me donner un coup de main.
Comme expliqué dans l’aide d’excel (partie VBA)
la syntaxe est application.movefile chemin_complet_du_fichier_source, chemin_complet_du_fichier_destination
Bon, en posant la question sur divers forums, j’avance doucement.
Voilà où en est le code :
' VBA Menu Outils | Références COCHER Acrobat Distiller
' COCHER Microsoft CDO Exchange xxxx Library
Option Explicit
Sub Enregistrement()
Dim Chemin1 As String, Chemin2 As String
Dim Client As String
Dim Fichier As String
Dim Numfact As String
Dim Jour As String
Dim sNomFichier As String
Chemin1 = "D:\Gestion\Factures"
Chemin2 = "H:\Zerobug backup\Factures"
Jour = Format(Range("H13"), "ddmmyyyy")
Client = Range("H7")
Numfact = Range("I15")
If Len(Client) = 0 Then
MsgBox "Cellule Client vide", vbOKOnly
Exit Sub
End If
If Len(Numfact) = 0 Then
MsgBox "Cellule N° Facture incorrecte", vbOKOnly
Exit Sub
End If
Fichier = Jour & "_" & Numfact & ".xls"
If CreationDossiers(Chemin1 & "\" & Client) = False Then
MsgBox "Création dossier impossible" & vbCrLf & Chemin1 & Client, vbOKOnly
Exit Sub
Else
ActiveWorkbook.SaveAs Chemin1 & "\" & Client & "\" & Fichier
End If
If CreationDossiers(Chemin2 & "\" & Client) = False Then
MsgBox "Création dossier impossible" & vbCrLf & Chemin2 & Client, vbOKOnly
Exit Sub
Else
ActiveWorkbook.SaveAs Chemin2 & "\" & Client & "\" & Fichier
End If
sNomFichier = Jour & "_" & Numfact
GenererPDFDistiller Chemin1, sNomFichier
End Sub
Sub GenererPDFDistiller(ByVal Chemin As String, ByVal NomDuFichier As String)
Dim CdoMessage As CDO.Message
Dim PDFDist As PDFDistiller
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
sNomFichierPS = Chemin & "\" & NomDuFichier & ".ps"
sNomFichierPDF = Chemin & "\" & NomDuFichier & ".pdf"
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
ActiveSheet.PrintOut copies:=1, Preview:=False, _
ActivePrinter:="Acrobat Distiller", PrintToFile:=True, _
Collate:=True, PrToFileName:=sNomFichierPS
Set PDFDist = New PDFDistiller
PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
Set CdoMessage = New CDO.Message
With CdoMessage
.Subject = "Votre facture"
.From = "contact@zerobug.fr"
.To = Range("G10")
.TextBody = "Texte dans le corps de message"
.AddAttachment sNomFichierPDF
.Send
End With
Kill sNomFichierPS
Kill sNomFichierPDF
Kill Chemin & "\" & NomDuFichier & ".log"
Set PDFDist = Nothing
Set CdoMessage = Nothing
End Sub
Private Function CreationDossiers(ByVal Chemin As String) As Boolean
Dim i As Long
Dim sTmp As String
Dim Ar() As String
If InStr(1, Chemin, ":") = 0 Then
Ar = Split(CurDir & Chemin, "\")
Else
Ar = Split(Chemin, "\")
End If
sTmp = Ar(0)
For i = LBound(Ar) + 1 To UBound(Ar)
If Ar(i) <> "" Then
sTmp = sTmp & "\" & Ar(i)
On Error Resume Next
MkDir sTmp
On Error GoTo 0
End If
Next
If Dir(Chemin, vbDirectory) = "" Then
On Error Resume Next
RmDir Ar(0) & "\" & Ar(1)
On Error GoTo 0
Else
CreationDossiers = True
End If
End Function
Avec tout ça, il me génère bien .ps et .log dans le dossier Factures, mais il ne génère pas le .pdf !! D’où une erreur lors de la création du mail. Il ne manque pas une ligne pour transformer le PS en PDF ?
Merci pour ta macro qui m’a bien servi.
J’ai trouvé une solution pour ton problème j’utilise CutePDF Writer (freeware) pour générer le PostScript.
Comme je n’ai pas Exchange j’utilise Microsoft CDO for Windows 2000 library et je lui indique le SMTP
J’ai fais aussi une petite fonction qui recherche l’email dans une liste sous Excel.
Option Explicit
Sub Enregistrement()
Dim Chemin1 As String, Onglet As String
Dim Client As String
Dim Fichier As String
Dim Numfact As String
Dim Jour As String
Dim sNomFichier As String
Dim sEmailTo As String
Chemin1 = "C:\Patrice\Inpec\F-Inpec"
Onglet = ActiveSheet.Name
If InStr(Onglet, " ") > 0 Then
Client = Mid(Onglet, 1, InStr(Onglet, " ") - 1)
Numfact = Mid(Onglet, InStr(Onglet, " ") + 1, Len(Onglet))
Else
MsgBox "Onglet incorrect =" & Onglet, vbOKOnly
Exit Sub
End If
If Len(Client) = 0 Then
MsgBox "Cellule Client vide", vbOKOnly
Exit Sub
End If
If Len(Numfact) = 0 Then
MsgBox "Cellule N° Facture incorrecte", vbOKOnly
Exit Sub
End If
sNomFichier = Numfact & "_" & Client
GenererPDFDistiller Chemin1, sNomFichier
sEmailTo = recherche(Client, Range("'[Divers.xls]email'!A:A"), Range("'[Divers.xls]email'!B:B"))
If sEmailTo <> "" Then
EnvoieMail Chemin1, sNomFichier, sEmailTo
Else
MsgBox "Email du client " & Client & " non trouvé", vbOKOnly
Exit Sub
End If
End Sub
Sub EnvoieMail(ByVal Chemin As String, ByVal NomFichier As String, ByVal EmailTo As String)
'Pensez à cocher "Microsoft CDO for Windows 2000 library" dans le Menu Outils/Références
Dim CdoMessage As CDO.Message
Set CdoMessage = New CDO.Message
With CdoMessage
.Subject = "Votre facture " & NomFichier
.From = "patrice.edeline@inpec.fr"
.To = EmailTo
.TextBody = "Vous trouverez en pièce jointe votre facture " & NomFichier & ".pdf" & vbCrLf & "En vous souhaitant une bonne réception."
.AddAttachment Chemin & "\" & NomFichier & ".pdf"
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.aliceadsl.fr"
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Configuration.Fields.Update
.Send
End With
Set CdoMessage = Nothing
End Sub
Sub GenererPDFDistiller(ByVal Chemin As String, ByVal NomDuFichier As String)
'Pensez à cocher "Acrobat Distiller" dans le Menu Outils/Références...
Dim PDFDist As PDFDistiller
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
sNomFichierPS = Chemin & "\" & NomDuFichier & ".ps"
sNomFichierPDF = Chemin & "\" & NomDuFichier & ".pdf"
sNomFichierLOG = Chemin & "\" & NomDuFichier & ".log"
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
ActiveSheet.PrintOut copies:=1, Preview:=False, _
ActivePrinter:="CutePDF Writer", PrintToFile:=True, _
Collate:=True, PrToFileName:=sNomFichierPS
Set PDFDist = New PDFDistiller
PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
Kill sNomFichierPS
Kill sNomFichierLOG
Set PDFDist = Nothing
End Sub
Function recherche(ValeurAChercher As String, DansLaColonne As Range, ColonneARenvoyer As Range)
Dim c As Range
Set c = DansLaColonne.Find(ValeurAChercher, LookIn:=xlValues, LookAt:=xlWhole)
If c Is Nothing Then
recherche = ""
Else
recherche = ColonneARenvoyer(c.Row).Value
End If
End Function