Word vba imprimer tout un répertoire de fichier *.doc tous les documents d'un dossier
Soyez le premier à donner votre avis sur cette source.
Snippet vu 17 638 fois - Téléchargée 30 fois
Contenu du snippet
Bon voilà le problème :
imprimer un dossier rempli de document word *.doc.
La solution c'est une source sous la forme d'un document word avec un tas de macros dedans qui permettent de le faire en gros :
un module appeler Newmacros et un form appeller userform1
sur le form deux combobox et un bouton valider
il ya aussi un petit truc pour éviter le que message "les marges d'impressions ...etc"
voilà je joins la source du document doc en office 97
bon Codage à tous !
imprimer un dossier rempli de document word *.doc.
La solution c'est une source sous la forme d'un document word avec un tas de macros dedans qui permettent de le faire en gros :
un module appeler Newmacros et un form appeller userform1
sur le form deux combobox et un bouton valider
il ya aussi un petit truc pour éviter le que message "les marges d'impressions ...etc"
voilà je joins la source du document doc en office 97
bon Codage à tous !
Source / Exemple :
'code dans le module
Private Declare Function EnumPrintersA Lib "Winspool.drv" _
(ByVal flags As Long, ByVal Name As String, ByVal Level As Long, _
pPrinterEnum As Long, ByVal cdBuf As Long, _
pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenA Lib "Kernel32" _
(ByVal lpString As Any) As Long
Private Declare Function lstrcpyA Lib "Kernel32" _
(ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'variables discussion avec le form
Public printer As String
Public nbre As String
Public exitall As Boolean
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub IMPRIME_TOUT()
'
' Macro1 Macro
' Macro enregistrée le 19/07/2004 par supervisor
'
Dim rep As String
Dim enuma As Integer
enuma = 0
exitall = False
'On demande à l'utilisateur l'emplacement du dossier
Dossier = GetDirectory
'petites vérif sur le dossier
If Len(Dossier) > 3 Then
Dossier = Dossier & "\"
End If
If Dossier = "" Then
MsgBox "Pas de dossier sélectionné"
Exit Sub
End If
'on demande à l'usager l'imprimante et le nbre de feuilles à imprimer
UserForm1.Show
'petites vérif si tout est bien saisi sinon on se tire
If exitall = True Then Exit Sub
'obtient le premier fichier ou répertoire qui est dans "c:\"
rep = Dir(Dossier)
'MsgBox rep
'boucle tant que le répertoire n'a pas été entièrement parcouru
Do While (rep <> "")
'teste si c'est un fichier ou un répertoire
If (GetAttr(Dossier & rep) And vbDirectory) = vbDirectory Then '
' on pourrait faire un truc si c un dossier
'sinon c un fichier et on vérifie si c un doc
ElseIf (Right$(rep, 4) = ".doc") Then
'on envoi à l'impression
imprime Dossier, rep
'on compte combien d'impression l'on fait
enuma = enuma + 1
End If
'Else: MsgBox Dossier & rep
'passe à l'élément suivant
rep = Dir
Loop
'Si il y a rien d'imprimer on le dit
If enuma = 0 Then
MsgBox "RIEN A IMPRIMER DANS" & rep
Exit Sub
End If
MsgBox enuma & " fichiers trouvés et imprimés" & " 0_o/ c fini"
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
Dim Dossier As String
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Choisissez un dossier de destination pour les sauvegardes."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
'Dossier = GetDirectory & ""
Dossier = GetDirectory
Else
GetDirectory = ""
End If
End Function
Sub imprime(chemin, docu)
'
' Macro2 Macro
' Macro enregistrée le 19/07/2004 par supervisor
'
ChangeFileOpenDirectory (chemin)
'MsgBox chemin & docu
Documents.Open FileName:=docu, ConfirmConversions:= _
False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto
'petite note sur print out avec display alert false et background false
'ainsi on n'a pas de message spéciaux types les marges d'impression etc...
Application.ActivePrinter = printer
With Application
.DisplayAlerts = wdAlertsNone
.PrintOut FileName:=docu, Range:=wdPrintAllDocument, Item:= _
wdPrintDocumentContent, Copies:=nbre, Pages:="", PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=True, Background:=False, PrintToFile:= _
False
.DisplayAlerts = wdAlertsAll
End With
ActiveWindow.Close
End Sub
'fin du code dans le module
'code dans le form
Private Declare Function EnumPrintersA Lib "Winspool.drv" _
(ByVal flags As Long, ByVal Name As String, ByVal Level As Long, _
pPrinterEnum As Long, ByVal cdBuf As Long, _
pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenA Lib "Kernel32" _
(ByVal lpString As Any) As Long
Private Declare Function lstrcpyA Lib "Kernel32" _
(ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Function Imprimantes()
Dim PrinterEnum() As Long, Impr() As String
Dim z As String
Dim Needed As Long, Returned As Long, i As Integer
EnumPrintersA 2, vbNullString, 5, 0, 0, Needed, 0
If Needed = 0 Then Exit Function
ReDim PrinterEnum(Needed / 4)
EnumPrintersA 2, vbNullString, 5, PrinterEnum(0), _
Needed, Needed, Returned
ReDim Impr(1 To Returned)
For i = 1 To Returned
Impr(i) = Space$(lstrlenA(PrinterEnum(i * 5 - 5)))
lstrcpyA Impr(i), PrinterEnum(i * 5 - 5)
'z = Impr(i).DeviceName
'z = z & "u"
'MsgBox z
'UserForm1.ComboBox2.AddItem (z.DeviceName)
Next i
Imprimantes = Impr
End Function
Private Sub GetPrinters()
Dim cbo As ComboBox
Dim sPname As String
Dim C As Byte
Dim i As Byte
'Dim prt As printers
Set cbo = Me.cboPrinters
C = cbo.ListCount
'Clean the cbo
If C > 0 Then
For i = 0 To C
cbo.RemoveItem (i)
Next i
End If
i = 0: C = 0
For Each prt In Imprimantes
'sPname = C & ";" & prt.DeviceName
cbo.AddItem (prt)
'This line is just to get the default printer to display it as the first option
Next prt
Me.cboPrinters = i
Set prt = Nothing
End Sub
Private Sub CommandButton1_Click()
NewMacros.printer = cboPrinters.Text
If (cboPrinters.Text = "0") Then
UserForm_Terminate
End If
NewMacros.nbre = ComboBox2.Text
UserForm1.Hide
End Sub
Private Sub UserForm_Initialize()
Dim Impr
GetPrinters
ComboBox2.AddItem ("1")
ComboBox2.AddItem ("2")
ComboBox2.AddItem ("3")
ComboBox2.AddItem ("4")
ComboBox2.AddItem ("5")
ComboBox2.AddItem ("6")
ComboBox2.AddItem ("7")
End Sub
Private Sub UserForm_Terminate()
MsgBox "Pas d'imprimante sélectionné"
NewMacros.exitall = True
End Sub
A voir également
- Shbrowseforfolder vba
- Vba shbrowseforfolder - Meilleures réponses
- VBA - Macro sauvegarde à tord un fichier toto.docx en format 2003 sous word 2007 ✓ - Forum - Visual Basic 6
- Imprimer/word/vba/tableau ✓ - Forum - Visual Basic 6
- Lancement d'une marco appartenant à un autre fichier (Word VBA) ✓ - Forum - Visual Basic
- Vba ajouter une ligne dans un fichier texte - Forum - Visual Basic
- Vba vérifier l'existence d'un fichier ✓ - Forum - Visual Basic
Commentaires
objword.DisplayAlerts=wdAlertsNone
Mais rien a faire il me l'affiche quand même.
D'où est-ce que ca peut venir ?
Je ne suis pas en mesure de coder moi même une classe d'accès universelle dans toutes les versions de microsoft office...reste à le tester sous 2007 !
Cette version fonctionne assez bien sous 97.
(en tout cas ma secrétaire ne passe pas sa vie à imprimer des words ///)
Malheureusement je ne parviens (visiblement) pas à le faire fonctionner complètement avec Word 2002 SP3. J'ai une erreur 461 et le débugger pointe sur "Me.cboPrinters" (ligne 225).
Etant néophyte, je ne sais pas s'il sagit d'un problème de compatibilité entre les versions de word, ou si j'ai fait une fausse manoeuvre.
Avez-vous rencontré le même problème ?
Je vous remercie d'avance pour vos réponse et pour le temps que vous y aurai consacré :-).
Bonne journée à vous
Sela devrait bien m'aider...
J'aimerais imprimer une liste de fichier contenu dans une table, mais les fichiers ne sont pas tous du type Word, ni office d'ailleur... Pourrais tu m'aider ?
Biensur ce n'est pas de moi car c'est vraiement chiadé, mais je l'ai découvert sur un truc complètement différement et je l'ai adapté au cas de figure....
'petite note sur print out avec display alert false et background false
'ainsi on n'a pas de message spéciaux types les marges d'impression etc...
Application.ActivePrinter = printer
With Application
.DisplayAlerts = wdAlertsNone
.PrintOut FileName:=docu, Range:=wdPrintAllDocument, Item:= _
wdPrintDocumentContent, Copies:=nbre, Pages:="", PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=True, Background:=False, PrintToFile:= _
False
.DisplayAlerts = wdAlertsAll
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.