エクセルVBAで最高画質印刷

質問

エクセルVBAでプリントを綺麗にさせたい場合、わたしのプリンターでは
.PrintQuality = 1200
を指定しています。

しかし、印刷品質はプリンターによると思いますので、他のプリンタを使う端末で作動させた場合、1200dpiが使えないものなら.PrintQuality = 1200ではエラーになると思います。

こういった場合（どんなプリンターかわからない場合）、そのプリンターの最高画質で印刷させるためにはVBAをどんなふうに記述すればいいでしょうか？

回答No.2

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

下記コードをそれぞれの場所にコピー＆ペーストして下さい。

ご希望どおり動くと思いますが、テストする時間がなかったので、
いきなり重要なファイルでは試さなさないで下さい。

'◆場所：ThisWorkbook ------------------------------------------------
Option Explicit

'印刷クオリティー調整
Private Sub Workbook_BeforePrint(Cancel As Boolean)

　　Dim sPrinter As String
　　Dim lResmode As Long

　　On Error GoTo ErrorHandler

　　'アクティブプリンタ名取得
　　sPrinter = GetActivePrinter()
　　If sPrinter <> vbNullString Then
　　　　'アクティブプリンタの最高解像度取得
　　　　lResmode = GetHighResMode(sPrinter)
　　End If
　　'解像度が取得できたときのみ変更
　　If lResmode <> 0 Then
　　　　ActiveSheet.PageSetup.PrintQuality = lResmode
　　End If
　　Exit Sub

ErrorHandler:
End Sub

'----------------------------------------ここまで ThisWorkbook--------

'◆場所：標準モジュール ----------------------------------------------
Option Explicit

'プリンタデバイスドライバの能力を取得する
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
　　Alias "DeviceCapabilitiesA" ( _
　　ByVal pDevice As String, _
　　ByVal pPort As String, _
　　ByVal fwCapability As Long, _
　　pOutput As Any, _
　　pDevMode As Any _
) As Long
'fwCapability定数
Private Const DC_ENUMRESOLUTONS = 13　'使用可能な解像度リスト

'プリンタの最高印刷解像度を取得
Public Function GetHighResMode(strPrinterName) As Long

　　Dim lngApiResultCode As Long
　　Dim lngResMode()　　 As Long

　　'関数初期化
　　GetHighResMode = 0
　　'使用可能な解像度モード数(Long)*2 = バッファサイズ
　　lngApiResultCode = _
　　　　DeviceCapabilities( _
　　　　　　strPrinterName, vbNullString, _
　　　　　　DC_ENUMRESOLUTONS, _
　　　　　　ByVal vbNullString, _
　　　　　　ByVal vbNullString _
　　　　)
　　If lngApiResultCode <> 0 Then
　　　　'解像度取得
　　　　ReDim lngResMode(lngApiResultCode * 2 - 1)
　　　　lngApiResultCode = _
　　　　　　DeviceCapabilities( _
　　　　　　　　strPrinterName, _
　　　　　　　　vbNullString, _
　　　　　　　　DC_ENUMRESOLUTONS, _
　　　　　　　　lngResMode(0), _
　　　　　　　　ByVal vbNullString _
　　　　　　)
　　　　If lngApiResultCode <> 0 Then
　　　　　　'最高解像度を返す
　　　　　　GetHighResMode = Application _
　　　　　　.WorksheetFunction.Max(lngResMode)
　　　　End If
　　End If

End Function

'アクティブプリンタ名を返す（不要文字カット）
Public Function GetActivePrinter() As String

　　Dim sPrinterName As String
　　Dim iSplitPos　　As Integer

　　GetActivePrinter = vbNullString
　　sPrinterName = Application.ActivePrinter
　　iSplitPos = InStr(1, sPrinterName, " on")
　　If iSplitPos > 0 Then
　　　　GetActivePrinter = Left$(sPrinterName, iSplitPos - 1)
　　Else
　　　　iSplitPos = InStr(1, sPrinterName, "の")
　　　　If iSplitPos > 0 Then
　　　　　　GetActivePrinter = Mid$(sPrinterName, iSplitPos + 2)
　　　　End If
　　End If

End Function

'--------------------------------------ここまで 標準モジュール--------

お礼

うっひゃぁ～！
ほんとに大掛かりなコードですねえ！

こうなると、もう何がなんだかわかりませんが、何度もありがとうございました。

このままコピペしてためしたら、ばっちりOKでした。

回答No.1

KenKen_SP

こんにちは。KenKen_SP です。

> そのプリンターの最高画質で印刷させるためにはVBAをどんなふう
> に記述すればいいでしょうか？

Win32 API の DocumentProperties あたりを使うと可能ですが、複雑
で大掛かりなコードになります。プリンタ制御って結構難しい部類で
すね。技術資料が少ないのです。

On Error ステートメントで逃げるのはダメですか？

下記のコードは、ThisWorkbook に貼り付けて下さい。

'印刷クオリティー調整（場所：ThisWorkbook)
Private Sub Workbook_BeforePrint(Cancel As Boolean)

　　On Error Resume Next
　　ActiveSheet.PageSetup.PrintQuality = 1200
　　'実行時エラーが発生した場合
　　If Err.Number > 0 Then
　　　　ActiveSheet.PageSetup.PrintQuality = 600
　　End If
　　On Error GoTo 0

End Sub

お礼

KenKen_SPさん、いつもお世話様です。

プリンタ制御って大変なんですね。
そんな大掛かりなコードになるなら、上記のやりかたで十分です。
ありがとうございました。