Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
VBAから片面/両面 印刷設定
投稿日時: 18/12/10 19:04:01
投稿者: S.Kos

みなさま、こんにちは
 
VBAからのプリンタ設定、やはりWin32APIに頼るしかないようです。
Windoes10/Pro(64ビット)+EXCEL2016(32ビット)で、下記コードの動作を確認しています。けれど、どことなく不安が残ります。
と言うのも、Win/XP(32ビット)時代にゴリゴリのCで書いたコードがベースなのですが、その分量は1/3以下です。メモリの取得や解放など、VBAのガベージコレクションがやってくれるだろう・・・と、全て省いています。
あ、動いた! で安心した良いのか、ご意見をお聞かせください。
 
' 定数
Private Const DM_IN_BUFFER = 8
Private Const DM_OUT_BUFFER = 2
 
' DEVMODE構造体のポインタをVBA/Longで受ける
Private Type PRINTER_INFO_9
  pDevmode As Long
End Type
 
' DEVMODE構造体
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
 
' Win32API
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)
 
'
' プリンタ制御 Sw = 0:片面, 1:両面印刷(短辺綴じ), 2:両面印刷(長辺綴じ)
'
Public Sub CtrlPrinter(sw As Long)
  Dim sPrinterName As String
  Dim sDefaultPrinter As String
  Dim hPrinter As Long
  Dim Pinfo9 As PRINTER_INFO_9
  Dim dm As DEVMODE
  Dim yDevModeData() As Byte
  Dim nRet As Long
   
  sDefaultPrinter = Application.ActivePrinter ' 通常使うプリンタ, 後ろにポートがくっついてるので、
  sPrinterName = Left(sDefaultPrinter, InStr(sDefaultPrinter, " on ") - 1) ' ポート削除
  nRet = OpenPrinter(sPrinterName, hPrinter, ByVal 0&) ' Open Printer
   
  nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0) ' DEVMODE構造体のサイズ取得
  If (nRet < 0) Then
    MsgBox " Cannot get the size of the DEVMODE structure. "
    Exit Sub
  End If
   
  ReDim yDevModeData(nRet + 100) As Byte ' 余裕を持たせてDEVMODE構造体取得
  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
   
  Call CopyMemory(dm, yDevModeData(0), Len(dm)) ' DEVMODE構造体をコピー
   
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' パラメータセット/両面印刷のみ
  dm.dmDuplex = sw
   
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Call CopyMemory(yDevModeData(0), dm, Len(dm)) ' 変更したDEVMODE構造体を再コピー
   
  ' DEVMODE構造体確認, 必ずErrorとなるので…
  nRet = DocumentProperties(0, hPrinter, sPrinterName, VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), DM_IN_BUFFER Or DM_OUT_BUFFER)
  Pinfo9.pDevmode = VarPtr(yDevModeData(0))
   
  nRet = SetPrinter(hPrinter, 9, Pinfo9, 0) ' 変更したDEVMODE構造体を書き戻す
  If (nRet <= 0) Then
    MsgBox " Cannot set the DEVMODE structure. "
    Exit Sub
  End If
   
  nRet = ClosePrinter(hPrinter) ' Close the Printer
 
End Sub
 
 

投稿日時: 18/12/25 20:00:52
投稿者: S.Kos

閉じます。