Hallo,
du kommst evtl. weiter wenn du uns Code lieferst.
Keinen Schimmer woran es liegt.
Wahrscheinlich kein Timeout/ Zeit Puffer zwischen den Drucken.
Ich persönlich verwende zum drucken die Windows Print API und einen Shell Execute.
Hier Beispiel für Shell Execute:
(Wenn du in Excel druckst dann verwende Application.hWnd und nicht
Word.Application.Windows(1).hWnd)
#If VBA7 Then
Private Declare PtrSafe Function apiShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
#Else
Private Declare Function apiShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
#End If
'uses winapi functions to print the word document "silently"
'if bUserClr is true then the printer is supposed to print in color
Public Sub PrintFile(Optional ByVal bUserClr As Boolean = False)
Dim wApp As Word.Application
On Error GoTo UnableToPrint
Set wApp = wFile.Application
'if the user wants a color print
If bUserClr Then
'use the windows Print API to set the device to color mode
PrintAPI.SetColorMode wFile.Parent.ActivePrinter, 2
Else
'use the windows Print API to set the device to black and white mode
PrintAPI.SetColorMode wFile.Parent.ActivePrinter, 1
End If
'use winapi function to execute printing
'needs a Window Handler, the operations and the filepath
apiShellExecute wApp.Windows(1).hwnd, "print", wFile.FullName, vbNullString, vbNullString, _
0
UnableToPrint:
If Err.Number 0 Then
'
'
MsgBox "Ein Fehler beim Ausdrucken der Dokumente ist aufgetreten!" & vbCrLf & Err. _
Description, vbCritical, "Failed Action"
End If
End Sub
mein PrintAPI Modul (das muss so heißen):
Option Explicit
Private Type PRINTER_DEFAULTS
pDatatype As Long
pDevmode As Long
DesiredAccess As Long
End Type
Private Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pCompanyLocation As Long
pDevmode As Long ' Pointer to DEVMODE
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type
Private Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type
Private Const DM_ORIENTATION As Long = &H1
Private Const DM_PAPERSize As Long = &H2
Private Const DM_PAPERLENGTH As Long = &H4
Private Const DM_PAPERWIDTH As Long = &H8
Private Const DM_DEFAULTSOURCE As Long = &H200
Private Const DM_PRINTQUALITY As Long = &H400
Private Const DM_COLOR As Long = &H800
Private Const DM_DUPLEX As Long = &H1000
Private Const DM_IN_BUFFER As Long = 8
Private Const DM_OUT_BUFFER As Long = 2
Private Const Delete As Long = &H10000
Private Const READ_CONTROL As Long = &H20000 ' Allowed to read device information
Private Const WRITE_DAC As Long = &H40000 ' Allowed to write device access control info
Private Const WRITE_OWNER As Long = &H80000 ' Allowed to change the object owner
' Combining these for full access to a device (DELETE + READ_CONTROL + WRITE_DAC + WRITE_OWNER) _
Private Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Private Const SERVER_ACCESS_ADMINISTER As Long = &H1 ' Access rights to administer print _
servers.
Private Const SERVER_ACCESS_ENUMERATE As Long = &H2 ' Access rights to enumerate print _
servers.
Private Const PRINTER_ACCESS_ADMINISTER As Long = &H4 ' Access rights for printers to perform _
administrative tasks.
Private Const PRINTER_ACCESS_USE As Long = &H8 ' Access rights for printers for general _
use (printing, querying).
' Access which allows you to set duplex on or off
Private Const PRINTER_NORMAL_ACCESS = (READ_CONTROL Or PRINTER_ACCESS_USE)
Private Const PRINTER_ENUM_CONNECTIONS As Long = &H4
Private Const PRINTER_ENUM_LOCAL As Long = &H2
Private Declare Function ClosePrinter _
Lib "winspool.drv" ( _
ByVal hPrinter As Long) _
As Long
Private Declare Function DocumentProperties _
Lib "winspool.drv" Alias "DocumentPropertiesA" ( _
ByVal hwnd As Long, _
ByVal hPrinter As Long, _
ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, _
ByVal pDevModeInput As Long, _
ByVal fMode As Long) _
As Long
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetPrinter _
Lib "winspool.drv" Alias "GetPrinterA" ( _
ByVal hPrinter As LongPtr, _
ByVal Level As Long, _
ByRef pPrinter As Any, _
ByVal cbBuf As Long, _
ByRef pcbNeeded As Long) _
As Long
Private Declare PtrSafe Function OpenPrinter _
Lib "winspool.drv" Alias "OpenPrinterA" ( _
ByVal pPrinterName As String, _
ByRef phPrinter As LongPtr, _
ByRef pDefault As PRINTER_DEFAULTS) _
As Long
Private Declare PtrSafe Function SetPrinter _
Lib "winspool.drv" Alias "SetPrinterA" ( _
ByVal hPrinter As LongPtr, _
ByVal Level As Long, _
ByRef pPrinter As Byte, _
ByVal Command As Long) _
As Long
Private Declare PtrSafe Sub CopyMemory _
Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As LongPtr)
Private Declare PtrSafe Sub Sleep _
Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function GetProfileString _
Lib "kernel32.dll" Alias "GetProfileStringA" ( _
ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) _
As Long
#End If
#End If
#If Not VBA7 Then
Private Declare Function GetPrinter _
Lib "winspool.drv" Alias "GetPrinterA" ( _
ByVal hPrinter As Long, _
ByVal Level As Long, _
ByRef pPrinter As Byte, _
ByVal cbBuf As Long, _
ByRef pcbNeeded As Long) _
As Long
Private Declare Function OpenPrinter _
Lib "winspool.drv" Alias "OpenPrinterA" ( _
ByVal pPrinterName As String, _
ByRef phPrinter As Long, _
ByRef pDefault As PRINTER_DEFAULTS) _
As Long
Private Declare Function SetPrinter _
Lib "winspool.drv" Alias "SetPrinterA" ( _
ByVal hPrinter As Long, _
ByVal Level As Long, _
ByRef pPrinter As Byte, _
ByVal Command As Long) _
As Long
Private Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef pDest As Any, _
ByRef pSource As Any, _
ByVal cbLength As Long)
Private Declare Sub Sleep _
Lib "kernel32" ( _
ByVal dwMilliseconds As Long)
Private Declare Function GetProfileString _
Lib "kernel32.dll" Alias "GetProfileStringA" ( _
ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) _
As Long
#End If
Private Declare Function EnumPrinters _
Lib "winspool.drv" Alias "EnumPrintersA" ( _
ByVal flags As Long, _
ByVal name As String, _
ByVal Level As Long, _
ByRef pPrinterEnum As Long, _
ByVal cdBuf As Long, _
ByRef pcbNeeded As Long, _
ByRef pcReturned As Long) _
As Long
Private Declare Function PtrToStr _
Lib "kernel32" Alias "lstrcpyA" ( _
ByVal RetVal As String, _
ByVal Ptr As Long) _
As Long
Private Declare Function StrLen _
Lib "kernel32" Alias "lstrlenA" ( _
ByVal Ptr As Long) _
As Long
Private Declare Function DeviceCapabilities _
Lib "winspool.drv" Alias "DeviceCapabilitiesA" ( _
ByVal lpDeviceName As String, _
ByVal lpPort As String, _
ByVal iIndex As Long, _
ByRef lpOutput As Any, _
ByVal dev As Long) _
As Long
Public Function PrinterList() As Variant
Dim buffer As String
Dim sOPtr As String
Dim iPos As Integer
Dim lChars As Long
Dim prtList() As String
Dim prtSize As Long
buffer = Space(2048)
lChars = GetProfileString("PrinterPorts", vbNullString, "", buffer, Len(buffer))
If lChars > 0 Then
iPos = InStr(buffer, Chr(0))
While iPos > 1
sOPtr = Left(buffer, iPos - 1)
buffer = Mid(buffer, iPos + 1)
iPos = InStr(buffer, Chr(0))
ReDim Preserve prtList(prtSize)
prtList(prtSize) = sOPtr
prtSize = prtSize + 1
Wend
End If
PrinterList = prtList
End Function
Public Sub SetColorMode(ByVal sPrinterName As String, iColorMode As Long)
SetPrinterProperty sPrinterName, DM_COLOR, iColorMode
End Sub
Public Function GetColorMode(ByVal sPrinterName As String) As Long
GetColorMode = GetPrinterProperty(sPrinterName, DM_COLOR)
End Function
Public Sub SetDuplex(ByVal sPrinterName As String, iDuplex As Long)
SetPrinterProperty sPrinterName, DM_DUPLEX, iDuplex
End Sub
Public Function GetDuplex(ByVal sPrinterName As String) As Long
GetDuplex = GetPrinterProperty(sPrinterName, DM_DUPLEX)
End Function
Public Sub SetPrintQuality(ByVal sPrinterName As String, iQuality As Long)
SetPrinterProperty sPrinterName, DM_PRINTQUALITY, iQuality
End Sub
Public Function GetPrintQuality(ByVal sPrinterName As String) As Long
GetPrintQuality = GetPrinterProperty(sPrinterName, DM_PRINTQUALITY)
End Function
Public Function GetPrintername(ByVal prtName As String) As String
Dim tmp As String
tmp = LTrim(RTrim(Left(prtName, InStr(1, prtName, " auf ", vbTextCompare))))
If tmp = vbNullString Then tmp = prtName
GetPrintername = tmp
End Function
Public Function GetFullPrinterName(ByVal prtName As String) As String
Dim regObj As Object
Dim aTypes As Variant
Dim aDevices As Variant
Dim vDevice As Variant
Dim sValue As String
Dim v As Variant
Dim sLocaleOn As String
Const HKEY_CURRENT_USER = &H80000001
v = Split(Application.ActivePrinter, Space(1))
sLocaleOn = Space(1) & CStr(v(UBound(v) - 1)) & Space(1)
Set regObj = GetObject("WINMGMTS:{impersonationLevel=impersonate}!\\.\root\default: _
StdRegProv")
regObj.EnumValues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", _
aDevices, aTypes
For Each vDevice In aDevices
regObj.GetStringValue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\ _
Devices", vDevice, sValue
If Left(vDevice, Len(prtName)) = prtName Then
GetFullPrinterName = vDevice & sLocaleOn & Split(sValue, ",")(1)
Exit Function
End If
Next vDevice
GetFullPrinterName = vbNullString
End Function
Public Function PrinterIsUp(ByVal sPrinterName As String) As Boolean
'Code adapted from Microsoft KB article Q230743
Dim hPrinter As Long 'handle for the current printer
Dim pd As PRINTER_DEFAULTS
Dim RetVal As Long
Dim iCount As Long
On Error GoTo cleanup
pd.DesiredAccess = PRINTER_NORMAL_ACCESS
RetVal = OpenPrinter(sPrinterName, hPrinter, pd)
If (RetVal = 0) Or (hPrinter = 0) Then
'Can't access current printer. Bail out doing nothing
Exit Function
End If
cleanup:
'Release the printer handle
If (hPrinter 0) Then Call ClosePrinter(hPrinter)
'Flush the message queue. If you don't do this,
'you can get page fault errors when you try to
'print a document immediately after setting a printer property.
For iCount = 1 To 20
DoEvents
Next iCount
PrinterIsUp = True
End Function
Private Function SetPrinterProperty(ByVal sPrinterName As String, ByVal iPropertyType As Long, _
_
ByVal iPropertyValue As Long) As Boolean
'Code adapted from Microsoft KB article Q230743
Dim hPrinter As Long 'handle for the current printer
Dim pd As PRINTER_DEFAULTS
Dim PInfo As PRINTER_INFO_2
Dim dm As DEVMODE
Dim yDevModeData() As Byte 'Byte array to hold contents
'of DEVMODE structure
Dim yPInfoMemory() As Byte 'Byte array to hold contents
'of PRINTER_INFO_2 structure
Dim iBytesNeeded As Long
Dim RetVal As Long
Dim iJunk As Long
Dim iCount As Long
On Error GoTo cleanup
pd.DesiredAccess = PRINTER_NORMAL_ACCESS
RetVal = OpenPrinter(sPrinterName, hPrinter, pd)
If (RetVal = 0) Or (hPrinter = 0) Then
'Can't access current printer. Bail out doing nothing
Exit Function
End If
'Get the Size of the DEVMODE structure to be loaded
RetVal = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (RetVal 0) Then Call ClosePrinter(hPrinter)
'Flush the message queue. If you don't do this,
'you can get page fault errors when you try to
'print a document immediately after setting a printer property.
For iCount = 1 To 20
DoEvents
Next iCount
End Function
Private Function GetPrinterProperty(ByVal sPrinterName As String, ByVal iPropertyType As Long) _
As Long
'Code adapted from Microsoft KB article Q230743
Dim hPrinter As Long
Dim pd As PRINTER_DEFAULTS
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim RetVal As Long
On Error GoTo cleanup
pd.DesiredAccess = PRINTER_NORMAL_ACCESS
'Get the printer handle
RetVal = OpenPrinter(sPrinterName, hPrinter, pd)
If (RetVal = 0) Or (hPrinter = 0) Then
'Couldn't access the printer
Exit Function
End If
'Find out how many bytes needed for the printer properties
RetVal = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (RetVal 0) Then Call ClosePrinter(hPrinter)
End Function