' 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