Word vba imprimer tout un répertoire de fichier *.doc tous les documents d'un dossier

Commenter

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 !

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

S'inscrire maintenant

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.