这是我的问题。
我正在尝试访问打印机并更改颜色和双面设置。到目前为止,我拥有的代码允许我更改网络打印机的用户首选项。但我有以下两个问题。
1) 代码将打印机按预期设置为单面或双面,但未正确设置颜色首选项!
2) Excel 不会自动采用新设置,我仍然需要进入并手动单击重置按钮才能使新更改生效。
这是我正在使用的代码:
Private Type PRINTER_INFO_9
pDevmode As Long ' Pointer to DEVMODE
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 Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As Any) As Long
Private Declare Function GetPrinter Lib "winspool.drv" Alias _
"GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
buffer As Long, ByVal pbSize As Long, pbSizeNeeded As Long) As Long
Private Declare Function SetPrinter Lib "winspool.drv" Alias _
"SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Any, ByVal Command 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
Private Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Const DM_IN_BUFFER = 8
Private Const DM_OUT_BUFFER = 2
Private Sub CommandButton1_Click()
Dim sPrinterName As String
Dim my_printer_address As String
Dim hPrinter As Long
Dim Pinfo9 As PRINTER_INFO_9
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim nRet As Long
my_printer_address = Application.ActivePrinter
'slice string for printer name (minus port name)
sPrinterName = Left(my_printer_address, InStr(my_printer_address, " on ") - 1)
'Open Printer
nRet = OpenPrinter(sPrinterName, hPrinter, ByVal 0&)
'Get the size of the DEVMODE structure
nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (nRet < 0) Then MsgBox "Cannot get the size of the DEVMODE structure.": Exit Sub
'Get DEVMODE Structure
ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, sPrinterName, VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Cannot get the DEVMODE structure."
Exit Sub
End If
'Copy the DEVMODE structure
Call CopyMemory(dm, yDevModeData(0), Len(dm))
'Change DEVMODE Stucture as required
dm.dmColor = 1 ' 1 = colour, 2 = b/w
dm.dmDuplex = 2 ' 1 = simplex, 2 = duplex
'Replace the DEVMODE structure
Call CopyMemory(yDevModeData(0), dm, Len(dm))
'Verify DEVMODE Stucture
nRet = DocumentProperties(0, hPrinter, sPrinterName, VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), DM_IN_BUFFER Or DM_OUT_BUFFER)
Pinfo9.pDevmode = VarPtr(yDevModeData(0))
'Set DEVMODE Stucture with any changes made
nRet = SetPrinter(hPrinter, 9, Pinfo9, 0)
If (nRet <= 0) Then MsgBox "Cannot set the DEVMODE structure.": Exit Sub
'Close the Printer
nRet = ClosePrinter(hPrinter)
End Sub
如果您能提供任何帮助,我们将不胜感激!几周来我一直在用这个头撞墙!
最佳答案
经过一番广泛的研究,我找到了我正在寻找的答案。我把它贴在这里,以防有人有类似的情况。
我遇到的主要问题是让 Excel 接受新的更改,关闭工作簿或必须进入打印首选项并单击“重置”。
我提出的解决方案是暂时将事件打印机设置为另一台打印机,然后将其设置回更改设置的打印机,这会强制 Excel 采用新设置。
以下是公共(public)类型、函数和常量:
Public Type PRINTER_INFO_9
pDevmode As Long '''' POINTER TO DEVMODE
End Type
Public 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
Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As Any) As Long
Public Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, buffer As Long, ByVal pbSize As Long, pbSizeNeeded As Long) As Long
Public Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal Command As Long) As Long
Public 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
Public Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cbLength As Long)
Public Const DM_IN_BUFFER = 8
Public Const DM_OUT_BUFFER = 2
这是我用来设置新值的例程:
Public Sub SetPrinterProperty(ByVal sPrinterName As String, ByVal iPropertyType As Long)
Dim PrinterName, sPrinter, sDefaultPrinter As String
Dim Pinfo9 As PRINTER_INFO_9
Dim hPrinter, nRet As Long
Dim yDevModeData() As Byte
Dim dm As DEVMODE
'''' STROE THE CURRENT DEFAULT PRINTER
sDefaultPrinter = sPrinterName
'''' USE THE FULL PRINTER ADDRESS TO GET THE ADDRESS AND NAME MINUS THE PORT NAME
PrinterName = Left(sDefaultPrinter, InStr(sDefaultPrinter, " on ") - 1)
'''' OPEN THE PRINTER
nRet = OpenPrinter(PrinterName, hPrinter, ByVal 0&)
'''' GET THE SIZE OF THE CURRENT DEVMODE STRUCTURE
nRet = DocumentProperties(0, hPrinter, PrinterName, 0, 0, 0)
If (nRet < 0) Then MsgBox "Cannot get the size of the DEVMODE structure.": Exit Sub
'''' GET THE CURRENT DEVMODE STRUCTURE
ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, PrinterName, VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then MsgBox "Cannot get the DEVMODE structure.": Exit Sub
'''' COPY THE CURRENT DEVMODE STRUCTURE
Call CopyMemory(dm, yDevModeData(0), Len(dm))
'''' CHANGE THE DEVMODE STRUCTURE TO REQUIRED
dm.dmDuplex = iPropertyType ' 1 = simplex, 2 = duplex
'''' REPLACE THE CURRENT DEVMODE STRUCTURE WITH THE NEWLEY EDITED
Call CopyMemory(yDevModeData(0), dm, Len(dm))
'''' VERIFY THE NEW DEVMODE STRUCTURE
nRet = DocumentProperties(0, hPrinter, PrinterName, VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), DM_IN_BUFFER Or DM_OUT_BUFFER)
Pinfo9.pDevmode = VarPtr(yDevModeData(0))
'''' SET THE DEMODE STRUCTURE WITH ANY CHANGES MADE
nRet = SetPrinter(hPrinter, 9, Pinfo9, 0)
If (nRet <= 0) Then MsgBox "Cannot set the DEVMODE structure.": Exit Sub
'''' CLOSE THE PRINTER
nRet = ClosePrinter(hPrinter)
'''' GET THE FULL PRINTER NAME FOR THE CUTE PDF WRITER
sPrinter = GetPrinterFullName("CutePDF")
'''' CHECK TO MAKE SURE THE CUTEPDF WAS FOUND
If sPrinter <> vbNullString Then
'''' THIS FORCES EXCEL TO ACCEPT THE NEW CHANGES THAT HAVE BEEN MADE TO THE PRINTER SETTINGS
'''' SET THE ACTIVE PRINTER TEMPERARILLY TO THE CUTE PDF WRITER
Application.ActivePrinter = sPrinter
'''' SET THE PRINTER BACK TO THE DEFAULY FOLLOW ME.
Application.ActivePrinter = sDefaultPrinter
End If
End Sub
然后我调用这两个子程序中的任何一个来设置首选项:
Public Sub SetDuplex(ByVal sPrinterName As String, iDuplex As Long)
SetPrinterProperty sPrinterName, iDuplex
End Sub
Public Sub SetSimplex(ByVal sPrinterName As String, iDuplex As Long)
SetPrinterProperty sPrinterName, iDuplex
End Sub
关于vba - Excel VBA打印机API,设置颜色和双面打印,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/40848751/