いわゆるハードコピーというやつ。業務用かな。オマケとして、右上に日付を表示するようにしといたよ。
はい、いきなり構造体・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 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
'オブジェクトを破棄する
'オブジェクトを選択する
'デバイスと互換性のあるデバイスコンテキストを作成する
'指定したDCにあるBMPと互換のビットマップオブジェクトを作成する
'デバイスコンテキストを破棄する
'デバイス情報を取得する
Private Const HORZRES = 8 '幅
'デスクトップのウインドウハンドルを取得する
'デバイスコンテキストを取得する
'Windowのサイズを取得する
'デバイスコンテキストを開放する
'定義済みのペン、フォント、ブラシのハンドル取得
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 GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long<
Private Const SM_CXFRAME = 32
'文字色を設定する
'文字列を出力する
'文字列の幅と高さを取得する
'クリップボードを開く
'クリップボードを空にする
'クリップボードにデータをセットする
'クリップボードを閉じる
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 |