画面ハードコピー印刷のサンプル(VB6)

＜このサンプルの概要＞
画面のハードコピーを簡易帳票として印刷するためにサンプルソースを作ってみました。
VB6のフォームにCommandButtonを２つ追加してお試しください。本サンプルのキーワード
は以下の通りです。
(1)Printer.PaintPicture
(2)keybd_event
(3)VK_SNAPSHOT
(4)VK_LMENU
(5)余白を考慮した拡大／縮小
(6)プリンタを指定した印刷

Option Explicit
' キーイベントＡＰＩ
Private Declare Sub keybd_event Lib "user32.dll" _
        (ByVal bVk As Byte, ByVal bScan As Byte, _
         ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_SNAPSHOT = &H2C
Private Const VK_LMENU = &HA4
Private Const KEYEVENTF_KEYUP = &H2
Private Const KEYEVENTF_EXTENDEDKEY = &H1

' 余白サイズ(論理センチあたり567twip)
Private Const lngYLeft = 567
Private Const lngYTop = 567
Private Const lngYRight = 567
Private Const lngYBottom = 567

Private Sub Command1_Click()
    ' 通常使うプリンタへの
    ' アクティブウィンドウのハードコピー
    HardCopy True, Printer
End Sub

Private Sub Command2_Click()
    ' 使用可能なプリンターを検索
    Dim objPrinter As Printer
    For Each objPrinter In Printers
        If objPrinter.DeviceName = "My Printer" Then
            ' 指定のプリンタ発見
            Set Printer = objPrinter
            Exit For
        End If
    Next
    
    ' 用紙方向を横向きに設定
    Printer.Orientation = vbPRORLandscape

    ' 用紙サイズをＡ４に設定
    Printer.PaperSize = vbPRPSA4
    
    ' 指定のプリンタへの
    ' スクリーン全体のハードコピー
    HardCopy False, Printer
End Sub

Public Sub HardCopy(blnTargetWin As Boolean, objPrinter As Object)
    On Error Resume Next

    ' OSイベント
    DoEvents
    
    ' クリップボードクリア
    Clipboard.Clear

    If blnTargetWin Then
        ' ActiveWindowのPrintScreen
        Call keybd_event(VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY Or 0, 0)
        Call keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY Or 0, 0)
        Call keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
        Call keybd_event(VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Else
        ' FullScreenのPrintScreen
        Call keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0)
        Call keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    End If
    
    ' OSイベント
    DoEvents

    ' ピクチャーを印刷する
    If Clipboard.GetFormat(vbCFBitmap) Then
        Dim lngHZoom As Single
        Dim lngWZoom As Single
        Dim lngHeight As Long
        Dim lngWidth  As Long
        
        Dim objPicture As Picture
        Set objPicture = Clipboard.GetData
        
        ' デフォルトプリンタ設定
        If objPrinter Is Nothing Then
            Set objPrinter = Printer
        End If
            
        ' 座標スケールの単位
        objPicture.ScaleMode = vbTwips
        objPrinter.ScaleMode = vbTwips
        
        ' ピクチャーのサイズ
        lngHeight = objPicture.Height
        lngWidth = objPicture.Width
        
        ' 拡大／縮小率を元に印字サイズの計算
        If lngHeight > objPrinter.Height - (lngYTop + lngYBottom) Or _
           lngWidth > objPrinter.Width - (lngYLeft + lngYRight) Then
            ' 用紙サイズ　＜　ピクチャーサイズ
            ' 拡大／縮小率を計算（余白考慮）
            lngHZoom = (objPrinter.Height - (lngYTop + lngYBottom)) / lngHeight
            lngWZoom = (objPrinter.Width - (lngYLeft + lngYRight)) / lngWidth
            ' 印字サイズの計算
            If lngHZoom < lngWZoom Then
                lngHeight = lngHeight * lngHZoom
                lngWidth = lngWidth * lngHZoom
            Else
                lngHeight = lngHeight * lngWZoom
                lngWidth = lngWidth * lngWZoom
            End If
        End If
        
        ' ピクチャー印刷
        objPrinter.PaintPicture _
            objPicture, lngYLeft, lngYTop, lngWidth, lngHeight
        objPrinter.EndDoc
    End If
End Sub