Excel VBA打印机API，设置颜色和双面 [英] Excel VBA printer API, set colour and duplex

问题描述

这是我的问题.

我正在尝试访问打印机并更改颜色和双面设置.到目前为止，我拥有的代码使我可以更改网络打印机的用户首选项.但是我下面有两个问题.

I am trying to access the printer and change the colour and duplex settings. So far the code I have allows me to change the user preferences of the networked printer. But I have the following two problems below.

1)代码将打印机按预期设置为单面或双面，但是不能正确设置颜色首选项！

1) The codes set's the printer to either simplex or duplex as intended, however is does not set the colour preference correctly!

2)Excel不会自动选择新设置，我仍然必须进入并手动单击重置"按钮才能使新更改生效.

2) Excel is not automatically picking up the new settings, I still have to go in and manually click the reset button for the new changes to take affect.

这是我正在使用的代码:

Here is the code I am using:

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

您能提供的任何帮助将不胜感激！！我已经用这个把我的头撞在墙上好几个星期了！

Any help you can provide will be much appreciated!! I have been hitting my head against a wall with this for weeks now!

推荐答案

经过大量研究，我找到了所需的答案.如果有人遇到类似情况，我会在此处发布.

After some extensive research, I have found the answer I was looking for. I have posted it here, in case anyone has a similar situation.

我遇到的主要问题是使Excel能够通过关闭工作簿或进入打印首选项并单击重置"来接受新的更改.

The main issue I was having was getting excel to accept the new changes with closing the workbook or having to go into the print preferences and click reset.

我想出的解决方案是将活动打印机临时设置为另一台打印机，然后将其重新设置为更改设置的打印机，这将迫使Excel选择新设置.

The solution I came up with was to temporarily set the active printer to another printer then set it back to the printer the settings were changed on, this forces Excel to pick up the new settings.

以下是公共类型，函数和常量:

Here are the Public Types, Functions and Constants:

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

这是我用来设置新值的例程:

This is the routine i am using to set the new values:

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

然后我调用这两个子程序之一来设置设置首选项:

I then call either of these two subs to set set preferences:

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

这篇关于Excel VBA打印机API，设置颜色和双面的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！