Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel adapter le nom d'un fichier à l'enregistrement par la macro

adapter le nom d'un fichier à l'enregistrement par la macro

9 réponses
Avatar
Greg
Bonsoir à tous,

Je sais que je vous sollicite beaucoup en ce moment, mais je suis sur un
projet complexe mettant en jeu plusieurs fichiers et il est difficile
d'avancer sur l'un sans faire avancer l'autre... toutes mes excuses...

Dans le code tout en bas, la macro crée un fichier PDF contenant toutes les
feuilles d'un classeur . Je voudrais que le nom de fichier qui s'enregistre
s'adapte en fonction de la situation. Il pourrait tout aussi bien
s'appelait "FICHE x" ou "NOM-DU-REPERTOIRE x", du moment que "x" soit le
nombre entier immédiatement supérieur au dernier fichier créé. Si dans le
dossier, il y a déjà "FICHE 1" et FICHE 2", le prochain à s'enregistrer
serait forcément "FICHE 3".

Actuellement, chaque nouveau fichier écrase le précédent dans le même
répertoire, en prenant le nom de fichier existant dans le code. Et comme
j'ai un nombre de fiches conséquent à créer de la sorte dans le même
répertoire, à moins de changer le nom de fichier dans le code, ou de
renommer entre deux chaque fichier créé, je suis coincé...

J'ai trouvé des éléments sur le site de JB, mais j'avoue que mes compétences
se limitent à quelques bricolages, et là je suis dépassé pour être autonome.
Voilà ce que j'ai trouvé qui pourrait m'intéresser :

Rep_courant=Curdir() donne le nom du répertoire courant
Name "x.xls" As "y.xls" renomme le fichier
FileCopy "c:\fichier.xls", "c:\fichierSauv.xls" copie le fichier spécifié

Pourriez-vous m'aider à finaliser ce projet? En remerciant par avance les
volontaires...

Greg

Voici le code:

' ----------------------------------------------------

Const Délai = 2.5

Sub test()
Dim Répertoire As String
Dim NomFichier As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name
NomFichier = "FICHE 1"
Répertoire = "C:\MonChemin\Mes Fichiers PDF\"
Sheets.Select
Créer_Un_Fichier_PDF Répertoire, NomFichier, True
Sheets(NomFeuille).Select
End Sub


Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
SpdFname As String, Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SpdFname & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub



Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function
Signaler un problème avec ce contenu

9 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Gloops
Greg a écrit, le 12/12/2010 18:53 :
Bonsoir à tous,

Je sais que je vous sollicite beaucoup en ce moment, mais je suis sur u n
projet complexe mettant en jeu plusieurs fichiers et il est difficile
d'avancer sur l'un sans faire avancer l'autre... toutes mes excuses...

Dans le code tout en bas, la macro crée un fichier PDF contenant tout es
les feuilles d'un classeur . Je voudrais que le nom de fichier qui
s'enregistre s'adapte en fonction de la situation. Il pourrait tout
aussi bien s'appelait "FICHE x" ou "NOM-DU-REPERTOIRE x", du moment que
"x" soit le nombre entier immédiatement supérieur au dernier fichie r
créé. Si dans le dossier, il y a déjà "FICHE 1" et FICHE 2", le prochain
à s'enregistrer serait forcément "FICHE 3".

Actuellement, chaque nouveau fichier écrase le précédent dans le même
répertoire, en prenant le nom de fichier existant dans le code. Et co mme
j'ai un nombre de fiches conséquent à créer de la sorte dans le m ême
répertoire, à moins de changer le nom de fichier dans le code, ou d e
renommer entre deux chaque fichier créé, je suis coincé...

J'ai trouvé des éléments sur le site de JB, mais j'avoue que mes
compétences se limitent à quelques bricolages, et là je suis dé passé
pour être autonome. Voilà ce que j'ai trouvé qui pourrait m'inté resser :

Rep_courant=Curdir() donne le nom du répertoire courant
Name "x.xls" As "y.xls" renomme le fichier
FileCopy "c:fichier.xls", "c:fichierSauv.xls" copie le fichier spéc ifié

Pourriez-vous m'aider à finaliser ce projet? En remerciant par avance
les volontaires...

Greg




Bonjour,

Pardonne-moi de ne pas avoir tout lu, mais pour ce qui est d'incrémente r
les noms de fichiers avec une numérotation, le principe est assez simpl e.

Tu as un intitulé de départ, un compteur, et un nombre de chiffres po ur
l'indice ; et puis une extension bien entendu.

Sauf cas particulier le plus simple est encore de démarrer le décompt e à
chaque fois au départ et d'incrémenter jusqu'à ne pas trouver le
fichier, auquel cas on a trouvé le nom à adopter.

Au fil du clavier, sans test (pas Excel sur place) :

Function NomIncremente(Chemin As String, NbChiffres As Integer, _
Extension As String)
Dim I As Integer
While Dir(Chemin + Format(I, Rept("0", NbChiffres) + Extension) <> ""
I = I + 1
Wend
NomIncremente = Chemin + Format(I, Rept("0", NbChiffres) + Extension
End Function

Dans l'argument Chemin on peut passer le chemin suivi du nom, avec des
barres inverses où il faut.

Pour répéter une chaîne, c'est bien Rept ?

Alors attention, l'argument Extension est supposé commencer par un poin t.
Avatar
Gloops
Gloops a écrit, le 12/12/2010 19:56 :
Greg a écrit, le 12/12/2010 18:53 :
Bonsoir à tous,

Je sais que je vous sollicite beaucoup en ce moment, mais je suis sur un
projet complexe mettant en jeu plusieurs fichiers et il est difficile
d'avancer sur l'un sans faire avancer l'autre... toutes mes excuses...

Dans le code tout en bas, la macro crée un fichier PDF contenant tou tes
les feuilles d'un classeur . Je voudrais que le nom de fichier qui
s'enregistre s'adapte en fonction de la situation. Il pourrait tout
aussi bien s'appelait "FICHE x" ou "NOM-DU-REPERTOIRE x", du moment qu e
"x" soit le nombre entier immédiatement supérieur au dernier fichi er
créé. Si dans le dossier, il y a déjà "FICHE 1" et FICHE 2", l e prochain
à s'enregistrer serait forcément "FICHE 3".

Actuellement, chaque nouveau fichier écrase le précédent dans le même
répertoire, en prenant le nom de fichier existant dans le code. Et c omme
j'ai un nombre de fiches conséquent à créer de la sorte dans le même
répertoire, à moins de changer le nom de fichier dans le code, ou de
renommer entre deux chaque fichier créé, je suis coincé...

J'ai trouvé des éléments sur le site de JB, mais j'avoue que mes
compétences se limitent à quelques bricolages, et là je suis dé passé
pour être autonome. Voilà ce que j'ai trouvé qui pourrait m'inté resser :

Rep_courant=Curdir() donne le nom du répertoire courant
Name "x.xls" As "y.xls" renomme le fichier
FileCopy "c:fichier.xls", "c:fichierSauv.xls" copie le fichier spé cifié

Pourriez-vous m'aider à finaliser ce projet? En remerciant par avanc e
les volontaires...

Greg




Bonjour,

Pardonne-moi de ne pas avoir tout lu, mais pour ce qui est d'incrémen ter
les noms de fichiers avec une numérotation, le principe est assez sim ple.

Tu as un intitulé de départ, un compteur, et un nombre de chiffres pour
l'indice ; et puis une extension bien entendu.

Sauf cas particulier le plus simple est encore de démarrer le décom pte à
chaque fois au départ et d'incrémenter jusqu'à ne pas trouver le
fichier, auquel cas on a trouvé le nom à adopter.

Au fil du clavier, sans test (pas Excel sur place) :

Function NomIncremente(Chemin As String, NbChiffres As Integer, _
Extension As String)
Dim I As Integer
While Dir(Chemin + Format(I, Rept("0", NbChiffres) + Extension) <> ""
I = I + 1
Wend



Le défaut quand on n'a pas de quoi tester, c'est que si on fait une
faute de syntaxe, on n'a rien pour s'en rendre compte.

Par exemple là, après la parenthèse qui ferme Rept, il en faut auss i une
pour fermer Format

NomIncremente = Chemin + Format(I, Rept("0", NbChiffres) + Extension



donc ça donne :

NomIncremente = Chemin + Format(I, Rept("0", NbChiffres)) + Extension


End Function

Dans l'argument Chemin on peut passer le chemin suivi du nom, avec des
barres inverses où il faut.

Pour répéter une chaîne, c'est bien Rept ?

Alors attention, l'argument Extension est supposé commencer par un po int.


Avatar
h2so4
Greg expressed precisely :
Bonsoir à tous,

Je sais que je vous sollicite beaucoup en ce moment, mais je suis sur un
projet complexe mettant en jeu plusieurs fichiers et il est difficile
d'avancer sur l'un sans faire avancer l'autre... toutes mes excuses...

Dans le code tout en bas, la macro crée un fichier PDF contenant toutes les
feuilles d'un classeur . Je voudrais que le nom de fichier qui s'enregistre
s'adapte en fonction de la situation. Il pourrait tout aussi bien s'appelait
"FICHE x" ou "NOM-DU-REPERTOIRE x", du moment que "x" soit le nombre entier
immédiatement supérieur au dernier fichier créé. Si dans le dossier, il y a
déjà "FICHE 1" et FICHE 2", le prochain à s'enregistrer serait forcément
"FICHE 3".

Actuellement, chaque nouveau fichier écrase le précédent dans le même
répertoire, en prenant le nom de fichier existant dans le code. Et comme j'ai
un nombre de fiches conséquent à créer de la sorte dans le même répertoire, à
moins de changer le nom de fichier dans le code, ou de renommer entre deux
chaque fichier créé, je suis coincé...

J'ai trouvé des éléments sur le site de JB, mais j'avoue que mes compétences
se limitent à quelques bricolages, et là je suis dépassé pour être autonome.
Voilà ce que j'ai trouvé qui pourrait m'intéresser :

Rep_courant=Curdir() donne le nom du répertoire courant
Name "x.xls" As "y.xls" renomme le fichier
FileCopy "c:fichier.xls", "c:fichierSauv.xls" copie le fichier spécifié

Pourriez-vous m'aider à finaliser ce projet? En remerciant par avance les
volontaires...

Greg

Voici le code:

' ----------------------------------------------------

Const Délai = 2.5

Sub test()
Dim Répertoire As String
Dim NomFichier As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name


NomFichier = "FICHE"
Répertoire = "C:MonCheminMes Fichiers PDF"
Sheets.Select



' recherche le premier nom de fichier disponible dans le répertoire

Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Répertoire)

Do
' numéro de fichier commence à 1 pour "FICHE 1"
ctr = 1
ok = True
For Each f In dossier_racine.Files
ctr = ctr + 1
If UCase(NomFichier & " " & ctr) = UCase(f.Name) Then ok = False
Next
Loop Until ok

NomFichier = NomFichier & " " & ctr

Créer_Un_Fichier_PDF Répertoire, NomFichier, True
Sheets(NomFeuille).Select
End Sub


Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
SpdFname As String, Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SpdFname & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub



Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function



--
h2so4
ca PAN
pique DORA
.
Avatar
Greg
Bonjour et merci pour cette réponse,

Je suis particulièrement débutant dans le domaine de la programmation, voir
inculte... SI j'ai bien compris, le code à intégrer (avec le correctif du
deuxième message) est :

Function NomIncremente(Chemin As String, NbChiffres As Integer, Extension As
String)
Dim I As Integer
While Dir(Chemin + Format(I, Rept("0", NbChiffres) + Extension)) <> ""
I = I + 1
Wend


Seulement, je ne vois pas du tout comment l'intégrer au code d'origine...
Désolé... (J'ai bien fait quelques essais, mais ça doit être du grand
n'importe quoi)

Greg

code d'origine:

' ----------------------------------------------------

Const Délai = 2.5

Sub test()
Dim Répertoire As String
Dim NomFichier As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name
NomFichier = "FICHE 1"
Répertoire = "C:MonCheminMes Fichiers PDF"
Sheets.Select
Créer_Un_Fichier_PDF Répertoire, NomFichier, True
Sheets(NomFeuille).Select
End Sub


Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
SpdFname As String, Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SpdFname & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub



Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function
Avatar
Jacky
Bonjour,

En ajoutant le date et l'heure au nom de fichier serait une solution simple
'-------------
NouveauNom = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & Format(Now, "dd-mm-yy HH_mm_ss") &
".xls"
ThisWorkbook.SaveCopyAs NouveauNom
'----------------
Le nom du fichier aura le nom du classeur en cours suivi de la date et heure de sauvegarde
NomDuClasseur12-12-10 20_ 40 _25
--

--
Salutations
JJ


"Greg" a écrit dans le message de news: 4d050c13$0$8117$
Bonsoir à tous,

Je sais que je vous sollicite beaucoup en ce moment, mais je suis sur un projet complexe mettant en jeu
plusieurs fichiers et il est difficile d'avancer sur l'un sans faire avancer l'autre... toutes mes
excuses...

Dans le code tout en bas, la macro crée un fichier PDF contenant toutes les feuilles d'un classeur . Je
voudrais que le nom de fichier qui s'enregistre s'adapte en fonction de la situation. Il pourrait tout
aussi bien s'appelait "FICHE x" ou "NOM-DU-REPERTOIRE x", du moment que "x" soit le nombre entier
immédiatement supérieur au dernier fichier créé. Si dans le dossier, il y a déjà "FICHE 1" et FICHE 2", le
prochain à s'enregistrer serait forcément "FICHE 3".

Actuellement, chaque nouveau fichier écrase le précédent dans le même répertoire, en prenant le nom de
fichier existant dans le code. Et comme j'ai un nombre de fiches conséquent à créer de la sorte dans le même
répertoire, à moins de changer le nom de fichier dans le code, ou de renommer entre deux chaque fichier
créé, je suis coincé...

J'ai trouvé des éléments sur le site de JB, mais j'avoue que mes compétences se limitent à quelques
bricolages, et là je suis dépassé pour être autonome. Voilà ce que j'ai trouvé qui pourrait m'intéresser :

Rep_courant=Curdir() donne le nom du répertoire courant
Name "x.xls" As "y.xls" renomme le fichier
FileCopy "c:fichier.xls", "c:fichierSauv.xls" copie le fichier spécifié

Pourriez-vous m'aider à finaliser ce projet? En remerciant par avance les volontaires...

Greg

Voici le code:

' ----------------------------------------------------

Const Délai = 2.5

Sub test()
Dim Répertoire As String
Dim NomFichier As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name
NomFichier = "FICHE 1"
Répertoire = "C:MonCheminMes Fichiers PDF"
Sheets.Select
Créer_Un_Fichier_PDF Répertoire, NomFichier, True
Sheets(NomFeuille).Select
End Sub


Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
SpdFname As String, Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SpdFname & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub



Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function


Avatar
Gloops
Greg a écrit, le 12/12/2010 20:23 :
Bonjour et merci pour cette réponse,

Je suis particulièrement débutant dans le domaine de la programmati on, voir
inculte... SI j'ai bien compris, le code à intégrer (avec le correc tif du
deuxième message) est :

Function NomIncremente(Chemin As String, NbChiffres As Integer,
Extension As
String)
Dim I As Integer
While Dir(Chemin + Format(I, Rept("0", NbChiffres) + Extension)) <> ""
I = I + 1
Wend


Seulement, je ne vois pas du tout comment l'intégrer au code d'origin e...
Désolé... (J'ai bien fait quelques essais, mais ça doit être du grand
n'importe quoi)





Ah, mauvaise nouvelle.

Je proposerais bien de commencer par tester la fonction séparément,
avant de l'intégrer au code. ça fait d'ailleurs partie des avantages
d'une fonction.

(Je vais partir du principe que ActiveWorkbook.Path me donne le
répertoire où se trouve le classeur actif, sans barre inverse à la fin.
Je ne me rappelle plus très bien, si ce n'est pas ça il faudra adapte r.)

Dans la fenêtre d'exécution :

strChemin = ActiveWorkbook.Path + "nomfichier"
inbChiffres = 4
strExtension = ".pdf"

? NomIncremente(strChemin, inbChiffres, strExtension)


et dire ce que ça donne.
Attention, pour pouvoir appeler la fonction depuis la fenêtre
d'exécution, il faut qu'elle soit publique.
La première ligne commencera donc par

Public Function NomIncremente(
Avatar
Greg
Génial!!! Merci beaucoup!

Je vais être gourmand et ce sera ma dernière demande sur ce fil : Est-il
compliqué de rajouter un bout de code pour que 10 fichiers PDF soient
produits (plutôt que un actuellement), avec une réactualisation des données
(par F9) entre chaque enregistrement.

Merci pour ce dernier morceau qui finalisera ce projet!

Et encore un grand merci, je commençais à désespérer......

Greg

"h2so4" a écrit dans le message de groupe de discussion :
Ua9No.32958$
Greg expressed precisely :
Bonsoir à tous,

Je sais que je vous sollicite beaucoup en ce moment, mais je suis sur un
projet complexe mettant en jeu plusieurs fichiers et il est difficile
d'avancer sur l'un sans faire avancer l'autre... toutes mes excuses...

Dans le code tout en bas, la macro crée un fichier PDF contenant toutes
les feuilles d'un classeur . Je voudrais que le nom de fichier qui
s'enregistre s'adapte en fonction de la situation. Il pourrait tout
aussi bien s'appelait "FICHE x" ou "NOM-DU-REPERTOIRE x", du moment que
"x" soit le nombre entier immédiatement supérieur au dernier fichier
créé. Si dans le dossier, il y a déjà "FICHE 1" et FICHE 2", le prochain
à s'enregistrer serait forcément "FICHE 3".

Actuellement, chaque nouveau fichier écrase le précédent dans le même
répertoire, en prenant le nom de fichier existant dans le code. Et comme
j'ai un nombre de fiches conséquent à créer de la sorte dans le même
répertoire, à moins de changer le nom de fichier dans le code, ou de
renommer entre deux chaque fichier créé, je suis coincé...

J'ai trouvé des éléments sur le site de JB, mais j'avoue que mes
compétences se limitent à quelques bricolages, et là je suis dépassé pour
être autonome. Voilà ce que j'ai trouvé qui pourrait m'intéresser :

Rep_courant=Curdir() donne le nom du répertoire courant
Name "x.xls" As "y.xls" renomme le fichier
FileCopy "c:fichier.xls", "c:fichierSauv.xls" copie le fichier spécifié

Pourriez-vous m'aider à finaliser ce projet? En remerciant par avance les
volontaires...

Greg

Voici le code:

' ----------------------------------------------------

Const Délai = 2.5

Sub test()
Dim Répertoire As String
Dim NomFichier As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name


NomFichier = "FICHE"
Répertoire = "C:MonCheminMes Fichiers PDF"
Sheets.Select



' recherche le premier nom de fichier disponible dans le répertoire

Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Répertoire)

Do
' numéro de fichier commence à 1 pour "FICHE 1"
ctr = 1
ok = True
For Each f In dossier_racine.Files
ctr = ctr + 1
If UCase(NomFichier & " " & ctr) = UCase(f.Name) Then ok = False
Next
Loop Until ok

NomFichier = NomFichier & " " & ctr

Créer_Un_Fichier_PDF Répertoire, NomFichier, True
Sheets(NomFeuille).Select
End Sub


Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
SpdFname As String, Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SpdFname & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub



Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function



--
h2so4
ca PAN
pique DORA
.


Avatar
h2so4
Greg used his keyboard to write :
Génial!!! Merci beaucoup!

Je vais être gourmand et ce sera ma dernière demande sur ce fil : Est-il
compliqué de rajouter un bout de code pour que 10 fichiers PDF soient
produits (plutôt que un actuellement), avec une réactualisation des données
(par F9) entre chaque enregistrement.

Merci pour ce dernier morceau qui finalisera ce projet!

Et encore un grand merci, je commençais à désespérer......


' ----------------------------------------------------

Const Délai = 2.5

Sub test()
Dim Répertoire As String
Dim NomFichier As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name


NomFichier = "FICHE"
Répertoire = "C:MonCheminMes Fichiers PDF"
Sheets.Select






'------------------

for i=1 to 10 ' on répète dix fois la production du pdf

calculate ' on pousse sur F9
'-------------------
' recherche le premier nom de fichier disponible dans le répertoire

Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Répertoire)

Do
' numéro de fichier commence à 1 pour "FICHE 1"
ctr = 1
ok = True
For Each f In dossier_racine.Files
ctr = ctr + 1
If UCase(NomFichier & " " & ctr) = UCase(f.Name) Then ok = False
Next
Loop Until ok

NomFichier = NomFichier & " " & ctr

Créer_Un_Fichier_PDF Répertoire, NomFichier, True
Sheets(NomFeuille).Select






next i
'----------------- fin du bloc à répéter
End Sub


Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
SpdFname As String, Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SpdFname & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub



Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function



-- h2so4
ca PAN
pique DORA
.







--
h2so4
ca PAN
pique DORA
.
Avatar
h2so4
h2so4 has brought this to us :

quelques corrections supplémentaires (je n'ai pas la possibilité de
tester



' ----------------------------------------------------

Const Délai = 2.5

Sub test()
Dim Répertoire As String
Dim NomFichier As String
Dim NomFeuille As String
NomFeuille = ActiveSheet.Name


NomFichier = "FICHE"
Répertoire = "C:MonCheminMes Fichiers PDF"
Sheets.Select



' recherche le premier nom de fichier disponible dans le répertoire

Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Répertoire)






'------------------

for i=1 to 10 ' on répète dix fois la production du pdf

calculate ' on pousse sur F9
ctr = 1
'-------------------


Do

ok = True
For Each f In dossier_racine.Files







'-------------------
If UCase(NomFichier & " " & ctr) = UCase(f.Name) Then
ctr=ctr+1
ok = False
end if
'--------------------
Next
Loop Until ok

NomFichier = NomFichier & " " & ctr

Créer_Un_Fichier_PDF Répertoire, NomFichier, True
Sheets(NomFeuille).Select








'-----------------
next i

'-----------------
End Sub


Sub Créer_Un_Fichier_PDF(SpdFpath As String, _
SpdFname As String, Creation As Boolean)

Dim pdfjob As Object, NbJobs As Integer, Sh As Object
Dim Default_Printer As String

killtask ("PDFCreator.exe") 'Procédure écrite plus bas...

Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cstart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = SpdFpath
.cOption("AutosaveFilename") = SpdFname & ".pdf"
.cOption("AutosaveFormat") = 0
.cClearCache
End With
Application.ScreenUpdating = False
Default_Printer = Application.ActivePrinter
'Imprimer les feuilles sélectionnées
With ActiveWindow
For Each Sh In .SelectedSheets
If TypeName(Sh) = "Chart" Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Else
If Not IsEmpty(Sh.UsedRange) Then
'Sh.PageSetup.Orientation = xlLandscape
Sh.PrintOut copies:=1, ActivePrinter:="PDFCreator"
Attente Délai
Sh.DisplayPageBreaks = False
End If
End If
Next
End With

'Wait until all print jobs have entered the print queue
NbJobs = pdfjob.cCountOfPrintjobs
If NbJobs > 0 Then
Creation = True
Do Until pdfjob.cCountOfPrintjobs = NbJobs
DoEvents
Loop
'Combine all PDFs into a single file and stop the printer
With pdfjob
.ccombineall
.cPrinterStop = False
End With

'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
End If
pdfjob.cClose
Application.ScreenUpdating = True
Application.ActivePrinter = Default_Printer
Set pdfjob = Nothing
End Sub



Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
Function Attente(x As Double)
Dim T As Double
T = Timer + x
Do While Timer <= T
DoEvents
Loop
End Function



-- h2so4
ca PAN
pique DORA
.









--
h2so4
ca PAN
pique DORA
.