● 指定ウインドウを紙の中央に印刷する ●

いわゆるハードコピーというやつ。業務用かな。オマケとして、右上に日付を表示するようにしといたよ。

はい、いきなり構造体・API関数・定数の宣言

Private Type SIZE
    cx As Long
    cy As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

'ビットマップを転送する
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

'オブジェクトを破棄する
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'オブジェクトを選択する
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

'デバイスと互換性のあるデバイスコンテキストを作成する
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long

'指定したDCにあるBMPと互換のビットマップオブジェクトを作成する
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

'デバイスコンテキストを破棄する
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

'デバイス情報を取得する
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const HORZRES = 8     '幅
Private Const VERTRES = 10    '高さ

'デスクトップのウインドウハンドルを取得する
Private Declare Function GetDesktopWindow Lib "user32" () As Long

'デバイスコンテキストを取得する
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long         'クライアント領域
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long   'ウインドウズ全体

'Windowのサイズを取得する
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

'デバイスコンテキストを開放する
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

'定義済みのペン、フォント、ブラシのハンドル取得
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long

Private Const WHITE_BRUSH = 0               '白のブラシ
Private Const LTGRAY_BRUSH = 1              '明るい灰色のブラシ
Private Const GRAY_BRUSH = 2                '灰色のブラシ
Private Const DKGRAY_BRUSH = 3              '濃い灰色のブラシ
Private Const BLACK_BRUSH = 4               '黒のブラシ
Private Const NULL_BRUSH = 5                '空のブラシ

'文字列の描画
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

'長方形の塗りつぶし
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long<

Private Const SM_CXFRAME = 32

'文字色を設定する
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long

'文字列を出力する
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

'文字列の幅と高さを取得する
Private Declare Function GetTextExtentPoint Lib "gdi32" Alias "GetTextExtentPointA" (ByVal hDC As Long, ByVal lpszString As String, ByVal cbString As Long, lpSize As SIZE) As Long

'クリップボードを開く
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long

'クリップボードを空にする
Private Declare Function EmptyClipboard Lib "user32" () As Long

'クリップボードにデータをセットする
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long

'クリップボードを閉じる
Private Declare Function CloseClipboard Lib "user32" () As Long

Public Const NORMAL_EXIT As Long = 0           '正常終了
Public Const ERR_H_DESKTOP_DC As Long = 1      'デスクトップのデバイスコンテキストハンドル取得に失敗
Public Const ERR_W_GET_RECT As Long = 2        'ウインドウ領域取得に失敗
Public Const ERR_W_SELECTOBJECT As Long = 3    'SelectObject関数エラー
Public Const ERR_FILLRECT As Long = 4          'FillRect関数エラー
Public Const ERR_BITBLT As Long = 5            'BitBlt関数エラー
Public Const ERR_GETTEXTWIDTH As Long = 6      'GetTextExtentPoint関数エラー
Public Const ERR_CLIPBAORD As Long = 7         'クリップボード関連関数エラー

以下が関数。長いけど、やっていること自体は簡単です。ディスプレイと同じサイズのビットマップを作成し、これ白で塗りつぶした後、指定ウインドウを作成したビットマップの中央に転送し、クリップボードを経由して印刷しているだけ。サイズはA4を対象としてるけどここら辺は適当に改造してね。

'-------------------------------------------------------------------
' 関数名 : PrintFormCenter
' 機能   : 指定のウインドウを紙の真ん中に印刷する
' 引数   : (in) hWnd  … 印刷するウインドウのハンドル
'           (in) sParam … 表示する文字列、何も指定しないと日付を表示する
'           (in) pMode … True:印刷する
'                        False:クリップボードにコピー
' 返り値 : なし
' 備考   : 取りあえずサイズはA4が対象、右上に日付を出す
'-------------------------------------------------------------------
Public Function PrintFormCenter(ByVal hWnd As Long, _
                            Optional ByVal sParam As String = vbNullString, _
                            Optional ByVal pMode As Boolean = True) As Long

    Dim hDesktop As Long    'デスクトップのハンドル
    Dim hDesktopDC As Long  'デスクトップのデバイスコンテキストのハンドル
    Dim hOldBitmap As Long  'デフォルトのビットマップハンドル
    Dim hNewDC As Long      'デバイスコンテキストのハンドル
    Dim hBitMap As Long    'ビットマップのハンドル
    Dim hFormDC As Long    'フォームのデバイスコンテキストのハンドル
    Dim dWidth As Long    'デスクトップの幅
    Dim dHeight As Long    'デスクトップの高さ
    Dim fWidth As Long    'フォームの幅
    Dim fHeight As Long    'フォームの高さ
    Dim xPos As Long    'フォームのX位置
    Dim yPos As Long    'フォームのY位置
    Dim hsrcFormDC As Long    'フォームのデバイスコンテキストのハンドル
    Dim udtFormRECT As RECT    'フォームのサイズを取得するRECT構造体
    Dim udtDesktopRECT As RECT    'デスクトップのサイズを取得するRECT構造体
    Dim sNowDate As String    '現在時刻を表示
    Dim udtSIZE As SIZE    'SIZE構造体
    Dim ret As Long    'API関数の戻り値

    On Error GoTo ErrHandler

    'マウスカーソルを砂時計に変える
    Screen.MousePointer = vbHourglass

    'デスクトップのハンドルを取得
    hDesktop = GetDesktopWindow

    'デスクトップのデバイスコンテキストのハンドルを取得
    hDesktopDC = GetDC(hDesktop)

    'デスクトップのデバイスコンテキストハンドル取得に失敗
    If hDesktopDC = 0 Then
        PrintFormCenter = ERR_H_DESKTOP_DC
        GoTo LastOperation
    End If

    'デスクトップのサイズを取得
    dWidth = GetDeviceCaps(hDesktopDC, HORZRES)  '幅
    dHeight = GetDeviceCaps(hDesktopDC, VERTRES)  '高さ

    'フォームのサイズを取得
    ret = GetWindowRect(hWnd, udtFormRECT)

    'フォームサイズ取得に失敗
    If ret = 0 Then
        PrintFormCenter = ERR_W_GET_RECT
        GoTo LastOperation
    End If

    'フォームの幅、高さを取得
    With udtFormRECT
        fWidth = (.Right - .Left)  '幅
        fHeight = (.Bottom - .Top) '高さ
    End With

    'フォームのX位置、Y位置を取得
    xPos = (dWidth - fWidth + GetSystemMetrics(SM_CXFRAME) * 2) \ 2
    yPos = (dHeight - fHeight) \ 2

    'フォームのデバイスコンテキストのハンドルを取得
    hFormDC = GetWindowDC(hWnd)

    'デバイスコンテキストのハンドルを取得
    hNewDC = CreateCompatibleDC(hDesktopDC)

    'ビットマップを作成する
    hBitMap = CreateCompatibleBitmap(hDesktopDC, dWidth, dHeight)

    'ビットマップを作成したデバイスコンテキストに割り付ける
    hOldBitmap = SelectObject(hNewDC, hBitMap)

    'SelectObjectに失敗
    If hOldBitmap = 0 Then
        PrintFormCenter = ERR_W_SELECTOBJECT
        GoTo LastOperation
    End If

    'デスクトップ領域セット
    With udtDesktopRECT
        .Left = 0: .Top = 0
        .Right = dWidth
        .Bottom = dHeight
    End With

    '白で塗りつぶす
        ret = FillRect(hNewDC, udtDesktopRECT, GetStockObject(WHITE_BRUSH))

    '塗りつぶしに失敗
    If ret = 0 Then
        PrintFormCenter = ERR_FILLRECT
        GoTo LastOperation
    End If

    '目的のウインドウをを転送する
    ret = BitBlt(hNewDC, xPos, yPos, fWidth, fHeight, hFormDC, 0, 0, vbSrcCopy)

    'BitBlt関数失敗
    If ret = 0 Then
        PrintFormCenter = ERR_BITBLT
        GoTo LastOperation
    End If

    '文字列が指定指定されていない
    If sParam = vbNullString Then
        sNowDate = Format$(Now, "General Date")  '現在時刻を取得
    Else
        '現在時刻を取得
        sNowDate = sParam
    End If

    '文字列の幅を取得
    ret = GetTextExtentPoint(hNewDC, sNowDate, LenB(StrConv(sNowDate, vbFromUnicode)), udtSIZE)

    'GetTextExtentPoint 関数失敗
    If ret = 0 Then
        PrintFormCenter = ERR_GETTEXTWIDTH
        GoTo LastOperation
    End If

    '文字を出力する
    Call TextOut(hNewDC, dWidth - (udtSIZE.cx + 10), 5, sNowDate, LenB(StrConv(sNowDate, vbFromUnicode)))

    'クリップボードを開く
    Call OpenClipboard(hWnd)

    'クリップボードを空にする
    Call EmptyClipboard

    'クリップボードにビットマップをセット
    ret = SetClipboardData(vbCFBitmap, hBitMap)

    'クリップボード関数失敗
    If ret = 0 Then
        PrintFormCenter = ERR_CLIPBAORD
        Goto LastOperation
    End If

    'クリップボードを閉じる
    ret = CloseClipboard

    'クリップボード関数失敗
    If ret = 0 Then
        PrintFormCenter = ERR_CLIPBAORD
        GoTo LastOperation
    End If

    If pMode = True Then
        Printer.PaperSize = vbPRPSA4            '用紙サイズ
        Printer.Orientation = vbPRORLandscape        '印刷方向 - 横
        Printer.PaintPicture Clipboard.GetData, 0, 0  '印刷
        Printer.EndDoc                '印刷ドキュメントを閉じる
        Clipboard.Clear                'クリップボードを空にする
    End If

    '正常終了
    PrintFormCenter = NORMAL_EXIT

  LaOperation:
    'デバイスコンテキストのハンドルを開放する
    If hDesktopDC <> 0 Then Call ReleaseDC(hDesktop, hDesktopDC)  'デスクトップ
    If hFormDC <> 0 Then Call ReleaseDC(hWnd, hFormDC)      'フォーム

    '割り付けたメモリビットマップを元に戻す
    If hOldBitmap <> 0 Then Call SelectObject(hNewDC, hOldBitmap)

    'デバイスコンテキストを開放する
    If hNewDC <> 0 Then Call DeleteObject(hNewDC)

    'マウスカーソルを元に戻す
    Screen.MousePointer = vbDefault

    Exit Function

  Erandler:
    'デバイスコンテキストのハンドルを開放する
    If hDesktopDC <> 0 Then Call ReleaseDC(hDesktop, hDesktopDC)  'デスクトップ
    If hFormDC <> 0 Then Call ReleaseDC(hWnd, hFormDC)      'フォーム

    '割り付けたメモリビットマップを元に戻す
    If hOldBitmap <> 0 Then Call SelectObject(hNewDC, hOldBitmap)

    'デバイスコンテキストを開放する
    If hNewDC <> 0 Then Call DeleteObject(hNewDC)

    Call MsgBox("エラーNo." & Err.Number & vbCrLf & vbCrLf & _
                Err.Description, vbExclamation, "プリント - エラー")

    'マウスカーソルを元に戻す
    Screen.MousePointer = vbDefault

End Function


戻る