grisan29
XLDnaute Accro
bonjour a tous et toutes
j'ai ce code qui fonctionne très pour enregistrer le devis ou facture en .xlsm et en .pdf
dans des dossiers séparé
je voudrais lui apporter une modification afin que le code entregistre les documents mensuellement
je m'explique serait t'il possible d'enregistrer en créant le mois en cours dans un dossier au nom de l'année en cours, en fait c'est un classeur a modules de classes, voici le code qui enregistre sous et qui foncttionne
voici le code public du module de répérage du nom de feuille
j'ai ce code qui le fait mais je n'arrive pas a l'adapter
merci d'avance
j'ai ce code qui fonctionne très pour enregistrer le devis ou facture en .xlsm et en .pdf
dans des dossiers séparé
je voudrais lui apporter une modification afin que le code entregistre les documents mensuellement
je m'explique serait t'il possible d'enregistrer en créant le mois en cours dans un dossier au nom de l'année en cours, en fait c'est un classeur a modules de classes, voici le code qui enregistre sous et qui foncttionne
Code:
Private Sub CB_EnregistreDansLaBase_Click()
'procédure enregistrement sous PDF
Dim NomFicXL As String, CheminXL As String
Dim NomFicPDF As String, CheminPDF As String
Dim DLig As Long
Dim shp As Shape
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Sheets(WS_FACTURE)
Sht.Range("I17") = Sht.Range("I17").Value
If Sht.Range("IS_DOC_SAVED_IN_BASE") Then
UpdateTitre Sht.Range("DOC_TYPE")
End If
Sht.Range("IS_DOC_SAVED_IN_BASE") = True
DLig = Sht.Range("C" & Rows.Count).End(xlUp).Row
Dim NomDeFichier As String
NomDeFichier = Sht.Range("DOC_TITRE").Value & " - " & Sht.Range("DOC_CLIENT").Value
NomFicXL = NomDeFichier & ".xlsm"
NomFicPDF = NomDeFichier & ".pdf"
' Pour vérification de la valeur
Select Case UCase(Sht.Range("DOC_TYPE").Value)
Case DOC_DEVIS: CheminXL = DIR_DEVIS
Case DOC_FACT: CheminXL = DIR_FACT
Case DOC_FACT_AQUI: CheminXL = DIR_FACT_AQUI
Case DOC_FACT_ACC: CheminXL = DIR_FACT_ACC
Case Else
MsgBox "Erreur pour trouver le chemin de " & Sht.Range("D1").Value
Exit Sub
End Select
CheminPDF = CheminXL & "PDF\"
CheminXL = CheminXL & "\"
' Sauvegarder le classeur actif dans le chemin et le nom determiné
' FileFormat:=xlExcel8,
ActiveWorkbook.SaveAs Filename:=DIR_WORKSPACE & CheminXL & NomFicXL, _
Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'SetButtonsVisible True
'**********************************************************************************
With Sht
.Activate
'code a tester et a supprimer si encore probleme
With .PageSetup
DLig = Range("suivant").Row
'MsgBox DerLig
.PrintArea = "C1:M" & DLig 'Sh.UsedRange.Rows.Count
'.PrintArea = ""
'la plage de cellules à imprimer pour chaque page
.PrintTitleRows = Sht.Range("C17:M18").Address
'.FitToPagesTall = 1
.FitToPagesWide = 1
.Orientation = xlPortrait
.PrintHeadings = False
' "pied de page au centre"
.CenterFooter = "&16&""Arial,Gras""SIRET : 123456789 - NAF : 0123p - RCS : 00000 - N° TVA : FR00123456789" & Chr(10) & _
"assurance décennale n°123456789 de chez untel"
End With
End With
'**********************************************************************************
' Exporter en PDF
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DIR_WORKSPACE & CheminPDF & NomFicPDF, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
SetButtonsVisible True
envoifacnue
MsgBox "Votre sauvegarde porte la référence : " & " " & NomFicXL & vbCrLf _
& "Le fichier PDF à été créé sous le nom : " & NomFicPDF
' Fermer le classeur actif
'ActiveWorkbook.Close
'Sauvegarde les modifications
AjouteDocDansLaBase
end sub
Code:
Public Const DIR_WORKSPACE As String = "C:\Facturation"
Public Const DIR_DEVIS As String = "\Devis"
Public Const DIR_FACT As String = "\Facture"
Public Const DIR_FACT_AQUI As String = "\Factureacquittee"
Public Const DIR_FACT_ACC As String = "\Factureacompte"
Code:
' Exporter en PDF
Public Sub Export_PDF()
Dim F As Worksheet
Dim Chemin As String
Dim Client As String
Dim Sh As Shape
Dim mois As String, annee As String
annee = "\" & Year(Date)
mois = MonthName(Month(Date)) & "\"
Application.DisplayAlerts = False
Set F = ThisWorkbook.Sheets(WS_FACTURE)
Chemin = "C:\Facturation\Facture seule\devispdf" & annee & mois
If Dir(Chemin, vbDirectory) = "" Then
MkDir Chemin
End If
Select Case F.Range("DOC_TYPE")
Case DOC_DEVIS
Chemin = "C:\Facturation\Facture seule\devispdf" & annee & mois
If Dir(Chemin, vbDirectory) = "" Then
MkDir Chemin
End If
Case DOC_FACT_ACC
Chemin = "C:\Facturation\Facture seule\facture acomptepdf" & annee & mois
If Dir(Chemin, vbDirectory) = "" Then
MkDir Chemin
End If
Case DOC_FACT_AQUI
Chemin = "C:\Facturation\Facture seule\facture acquitteepdf" & annee & mois
If Dir(Chemin, vbDirectory) = "" Then
MkDir Chemin
End If
Case DOC_FACT
Chemin = "C:\Facturation\Facture seule\facturepdf" & annee & mois
If Dir(Chemin, vbDirectory) = "" Then
MkDir Chemin
End If
Case Else
MsgBox "Impossibilité de déterminer le chemin" & vbCr & "Fin du programme"
End
End Select
Client = F.Range("DOC_TITRE") & " - " & F.Range("DOC_CLIENT")
Application.ScreenUpdating = False
'code qui enregistre en .pdf
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & Client, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
From:=1, To:=1, OpenAfterPublish:=False
MsgBox "Le fichier PDF à été créé sous le nom : " & " " & Client '& vbCrLf _
& "Le fichier PDF à été créé sous le nom : " & NomFicPDF
End Submerci d'avance
, le Forum 
