Greg,
it seemed to work, but when I enter my own string strTeller I receive an
error 13
here's the complete code:
Option Explicit
Private Const pad1 As String = "\\test path\1\"
Private Const pad2 As String = "\\test path\2\"
Private Const pad3 As String = "\\test path\3\"
Private Const pad4 As String = "\\test path\4\"
Private Const pad5 As String = "\\test path\5\"
Private Const pad6 As String = "\\test path\6\"
Private Const pad7 As String = "\\test path\7\"
Private Const pad8 As String = "\\test path\8\"
Private Const pad9 As String = "\\test path\"
Private Const Printer1 As String = "printer name"
Dim StrStandaardprinter As String
Dim Brieventeller1 As Integer
Dim Brieventeller2 As Integer
Dim Brieventeller3 As Integer
Dim Brieventeller4 As Integer
Dim Brieventeller5 As Integer
Dim Brieventeller6 As Integer
Dim Brieventeller7 As Integer
Dim Brieventeller8 As Integer
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const MAX_PATH As Integer = 255
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub StandaardPrinter()
'maak gebruik van de door de gebruiker ingestelde standaard printer
ActiveDocument.PrintOut
MsgBox "document wordt nu op de standaard afdelingsprinter geprint",
vbInformation, "Standaard printer"
End Sub
Function fncPrintMap(strZOEKPAD As String, strDocNaam As String, strSepPage
As String, strTeller As Integer, strDocSoort As String)
'***************************************************
'deze code is voor iemand van FSB die de docs in één keer moet printen
'***************************************************
'deze functie maakt een map aan voor reserve kopieën van de bestanden
'dan worden alle gevonden bestanden (per stuk) naar deze backupmap gekopieerd,
'geprint en uit de hoofdmap gewist.
'***************************************************
Dim DagBackupMap As String
'Dim strTeller As String
Dim StrStandaardprinter As String
'printeroutput moet naar een andere dan de huidig ingestelde printer....
'bepaal standaardprinter en zet aan het einde van de printactie de
standaardprinter weer terug
'haal de naam van de huidige printer op
StrStandaardprinter = ActivePrinter
'gebruik tijdelijk een andere printer
With Dialogs(wdDialogFilePrintSetup)
.printer = Printer1
.DoNotSetAsSysDefault = True
.Execute
End With
' Print batch specifiek scheidingspagina
ChangeFileOpenDirectory pad9
With ActiveDocument.PageSetup
.FirstPageTray = wdPrinterUpperBin
.OtherPagesTray = wdPrinterUpperBin
End With
Application.PrintOut FileName:=strSepPage
strTeller = 0 'teller die aan het einde van de printactie wordt getoond
DagBackupMap = strZOEKPAD & Format(Date, "yyyymmdd") & "\"
'aanmaken van de dagbackupmap
On Error GoTo foutafhandeling
MkDir DagBackupMap
Dim strfILE As String
' Haal alle gezochte bestanden op in de opgegeven map
strfILE = Dir(strZOEKPAD & strDocNaam)
Do Until strfILE = ""
'Debug.Print strfILE 'test of het werkt
'copy het gevonden bestand naar de dag-backupmap
FileCopy strZOEKPAD & strfILE, DagBackupMap & strfILE
'print het gevonden document
Application.PrintOut FileName:=strZOEKPAD & strfILE,
Background:=False
strTeller = strTeller + 1
'onderstaande SLEEP is nodig omdat het document nog niet naar de printer
is, terwijl
'het al gewist moet worden en de KILL niet altijd goed werkt
Sleep (0) ' Wacht 1 seconde (1000 msec.)
'wissen van het zojuist gekopieerde en geprinte document
Kill strZOEKPAD & strfILE
'zoek verder naar het volgende document
strfILE = Dir
Loop
'Print een scheidingspagina met het aantal geprinte documenten
Dim pStr1 As String
Dim pStr2 As String
pStr1 = "Er zijn "
pStr2 = "brieven geprint."
Dim oDoc As Document
Set oDoc = Documents.Add
With ActiveDocument.PageSetup
.FirstPageTray = wdPrinterUpperBin
.OtherPagesTray = wdPrinterUpperBin
End With
With oDoc.Range
.Text = pStr1 + strTeller + pStr2
.Font.Name = "Verdana"
.Font.Size = "18"
.Font.Bold = True
End With
oDoc.PrintOut
oDoc.Close wdDoNotSaveChanges
Exit Function
foutafhandeling:
If Err.Number = 75 Or Err.Number = 70 Then
'directory bestaat al
Resume Next
ElseIf Err.Number = 70 Then 'bestand is in gebruik
Resume Next
Else
MsgBox "Hier gaat iets niet helemaal goed!!!" & vbCrLf &
"foutmelding: " & Err.Number
'terugzetten naar de oorspronkelijke printer omdat anders de
standaardprinter is gewijzigd
ActivePrinter = StrStandaardprinter
Exit Function
End If
End Function
Sub MessageBox()
'********* alle gevonden documenten zijn geprint
'Als er geen documenten meer zijn:
MsgBox "Er zijn " & vbCrLf & Brieventeller1 & " Enkelvoudige DL
A&M brieven geprint" & vbCrLf & Brieventeller2 & " meervoudige DL A&M brieven
geprint" & vbCrLf & Brieventeller3 & " enkelvoudige DL Claims brieven
geprint" & vbCrLf & Brieventeller4 & " meervoudige DL Claims brieven geprint"
& vbCrLf & Brieventeller5 & " enkelvoudige OHRA brieven geprint" & vbCrLf &
Brieventeller6 & " meervoudige OHRA brieven geprint" & vbCrLf &
Brieventeller7 & " DL restant brieven geprint" & vbCrLf & Brieventeller8 & "
OHRA restant brieven geprint", vbInformation, "Centraal afdrukken brieven"
'terugzetten naar de oorspronkelijke printer
ActivePrinter = StrStandaardprinter
End Sub
Sub PrintPGSDocumenten()
Call fncPrintMap(pad1, "d*.doc", "doc1.doc", Brieventeller1, "test text ")
Call fncPrintMap(pad2, "d*.doc", "doc2.doc", Brieventeller2, "test text ")
Call fncPrintMap(pad3, "d*.doc", "doc3.doc", Brieventeller3, "test text ")
Call fncPrintMap(pad4, "d*.doc", "doc4.doc", Brieventeller4, "test text ")
Call fncPrintMap(pad5, "d*.doc", "doc5.doc", Brieventeller5, "test text ")
Call fncPrintMap(pad6, "d*.doc", "doc6.doc", Brieventeller6, "test text ")
Call fncPrintMap(pad7, "d*.doc", "doc7.doc", Brieventeller7, "test text ")
Call fncPrintMap(pad8, "d*.doc", "doc8.doc", Brieventeller8, "test text ")
Call MessageBox
End Sub
