' ******************************************************' 印刷ダイアログ用' ******************************************************
Type PrintDlg
lStructSize As Long
hwndOwner As Long
hDevMode As Long
hDevNames As Long
hdc As Long
flags As Long
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As Long
lpfnSetupHook As Long
lpPrintTemplateName As String
lpSetupTemplateName As String
hPrintTemplate As Long
hSetupTemplate As Long
End Type
Public Const PD_ALLPAGES = &H0
Public Const PD_SELECTION = &H1
Public Const PD_PAGENUMS = &H2
Public Const PD_NOSELECTION = &H4
Public Const PD_NOPAGENUMS = &H8
Public Const PD_COLLATE = &H10
Public Const PD_PRINTTOFILE = &H20
Public Const PD_PRINTSETUP = &H40
Public Const PD_NOWARNING = &H80
Public Const PD_RETURNDC = &H100
Public Const PD_RETURNIC = &H200
Public Const PD_RETURNDEFAULT = &H400
Public Const PD_SHOWHELP = &H800
Public Const PD_ENABLEPRINTHOOK = &H1000
Public Const PD_ENABLESETUPHOOK = &H2000
Public Const PD_ENABLEPRINTTEMPLATE = &H4000
Public Const PD_ENABLESETUPTEMPLATE = &H8000
Public Const PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
Public Const PD_ENABLESETUPTEMPLATEHANDLE = &H20000
Public Const PD_USEDEVMODECOPIES = &H40000
Public Const PD_USEDEVMODECOPIESANDCOLLATE = &H40000
Public Const PD_DISABLEPRINTTOFILE = &H80000
Public Const PD_HIDEPRINTTOFILE = &H100000
Public Const PD_NONETWORKBUTTON = &H200000
Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" ( _
pPrintdlg As PrintDlg _
) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
' ******************************************************' 印刷API用' ******************************************************
Type DOCINFO
cbSize As Long
lpszDocName As String
lpszOutput As String
End Type
Declare Function StartDoc Lib "gdi32" Alias "StartDocA" ( _
ByVal hdc As Long, _
lpdi As DOCINFO _
) As Long
Declare Function StartPage Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function EndPage Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function EndDoc Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function AbortDoc Lib "gdi32" (ByVal hdc As Long) As Long
' ******************************************************' データ出力用' ******************************************************
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
Public Const DT_TOP = &H0
Public Const DT_LEFT = &H0
Public Const DT_CENTER = &H1
Public Const DT_RIGHT = &H2
Public Const DT_VCENTER = &H4
Public Const DT_BOTTOM = &H8
Public Const DT_WORDBREAK = &H10
Public Const DT_SINGLELINE = &H20
Public Const DT_EXPANDTABS = &H40
Public Const DT_TABSTOP = &H80
Public Const DT_NOCLIP = &H100
Public Const DT_EXTERNALLEADING = &H200
Public Const DT_CALCRECT = &H400
Public Const DT_NOPREFIX = &H800
Public Const DT_INTERNAL = &H1000
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
' ******************************************************' 線引き用' ******************************************************
Type POINTAPI
x As Long
y As Long
End Type
Declare Function MoveToEx Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
lpPoint As POINTAPI _
) As Long
Declare Function LineTo Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long _
) As Long
' ******************************************************' 色塗り用' ******************************************************
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function SelectObject Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long _
) As Long
Declare Function FillRect Lib "user32" ( _
ByVal hdc As Long, _
lpRect As RECT, _
ByVal hBrush As Long _
) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
' ******************************************************' 印刷デバイス情報取得' ******************************************************
Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long _
) As Long
Public Const PHYSICALWIDTH = 110 ' Physical Width in device units
Public Const PHYSICALHEIGHT = 111 ' Physical Height in device units
Public Const PHYSICALOFFSETX = 112 ' Physical Printable Area x margin
Public Const PHYSICALOFFSETY = 113 ' Physical Printable Area y margin
Public Const SCALINGFACTORX = 114 ' Scaling factor x
Public Const SCALINGFACTORY = 115 ' Scaling factor y
Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" ( _
ByVal hdc As Long, _
lpMetrics As TEXTMETRIC _
) As Long
' ******************************************************' フォント' ******************************************************
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( _
ByVal H As Long, _
ByVal W As Long, _
ByVal E As Long, _
ByVal O As Long, _
ByVal W As Long, _
ByVal i As Long, _
ByVal u As Long, _
ByVal S As Long, _
ByVal C As Long, _
ByVal OP As Long, _
ByVal CP As Long, _
ByVal Q As Long, _
ByVal PAF As Long, _
ByVal F As String _
) As Long
Public Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Public Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Declare Function MulDiv Lib "kernel32" ( _
ByVal nNumber As Long, _
ByVal nNumerator As Long, _
ByVal nDenominator As Long _
) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
' ******************************************************' 印刷用構造体(オリジナル)' ******************************************************
Type INFO_FOR_PRINT
nOrgPageWidth As Long
nOrgPageLength As Long
nPageWidth As Long
nPageLength As Long
nPageOffsetWidth As Long
nPageOffset As Long
nCharWidth As Long
nLinePitch As Long
nLines As Long
hDevMode As Long
hDevNames As Long
hdc As Long
hPageFont As Long
hPageFontOld As Long
End Type
Global ifp As INFO_FOR_PRINT
' ******************************************************' 印刷開始' ******************************************************
Public Function StartPrint(strDocName As String, hWnd As Long) As Boolean
Dim pd As PrintDlg
Dim tm As TEXTMETRIC
Dim di As DOCINFO
Dim retDlg As Long
ifp.hPageFont = 0
pd.lStructSize = 66
pd.flags = PD_RETURNDC
pd.hwndOwner = hWnd
pd.nFromPage = 1
pd.nToPage = 1
pd.nMaxPage = 999
pd.nMinPage = 1
pd.nCopies = 1
retDlg = PrintDlg(pd)
If retDlg = 0 Then
StartPrint = False
Exit Function
End If
ifp.hDevMode = pd.hDevMode
ifp.hDevNames = pd.hDevNames
ifp.hdc = pd.hdc
ifp.nOrgPageWidth = GetDeviceCaps(pd.hdc, PHYSICALWIDTH)
ifp.nOrgPageLength = GetDeviceCaps(pd.hdc, PHYSICALHEIGHT)
ifp.nPageOffsetWidth = GetDeviceCaps(pd.hdc, PHYSICALOFFSETX)
ifp.nPageOffset = GetDeviceCaps(pd.hdc, PHYSICALOFFSETY)
ifp.nPageLength = ifp.nOrgPageLength - ifp.nPageOffsetWidth * 2
Call GetTextMetrics(pd.hdc, tm)
ifp.nCharWidth = tm.tmAveCharWidth
ifp.nLinePitch = tm.tmHeight
ifp.nPageWidth = ifp.nOrgPageLength - ifp.nPageOffsetWidth * 2 - ifp.nCharWidth
ifp.nLines = ifp.nPageLength / ifp.nLinePitch - 1
ifp.nPageLength = ifp.nLinePitch * ifp.nLines
di.cbSize = 12
di.lpszDocName = strDocName
Call StartDoc(pd.hdc, di)
Call StartPage(pd.hdc)
StartPrint = True
End Function
' ******************************************************' フォント変更' ******************************************************
Public Function ChangePageFont( _
FontName As String, _
nFontPoint As Long _
)
Dim hFont As Long
Dim nHeight As Long
Dim hFontOld As Long
Dim tm As TEXTMETRIC
nHeight = -MulDiv(nFontPoint, GetDeviceCaps(ifp.hdc, LOGPIXELSY), 72)
ifp.hPageFont = CreateFont(nHeight, 0, 0, 0, 0, 0, 0, 0, 128, 0, 0, 0, &H1 Or &H30, FontName)
ifp.hPageFontOld = SelectObject(ifp.hdc, ifp.hPageFont)
Call GetTextMetrics(ifp.hdc, tm)
ifp.nCharWidth = tm.tmAveCharWidth
ifp.nLinePitch = tm.tmHeight
ifp.nPageWidth = ifp.nOrgPageLength - ifp.nPageOffsetWidth * 2 - ifp.nCharWidth
ifp.nLines = ifp.nPageLength / ifp.nLinePitch - 1
ifp.nPageLength = ifp.nLinePitch * ifp.nLines
End Function
' ******************************************************' 印刷終了' ******************************************************
Public Function EndPrint()
Call EndPage(ifp.hdc)
Call EndDoc(ifp.hdc)
If ifp.hPageFont <> 0 Then
Call SelectObject(ifp.hdc, ifp.hPageFontOld)
Call DeleteObject(ifp.hPageFont)
End If
If ifp.hdc <> 0 Then
DeleteDC ifp.hdc
End If
If ifp.hDevMode <> 0 Then
GlobalFree ifp.hDevMode
End If
If ifp.hDevNames <> 0 Then
GlobalFree ifp.hDevNames
End If
End Function
' ******************************************************' 改ページ' ******************************************************
Public Function NextPage(hPdc As Long)
If hPdc = 0 Then
Call EndPage(ifp.hdc)
Call StartPage(ifp.hdc)
Else
Call EndPage(hPdc)
Call StartPage(hPdc)
End If
End Function
' ******************************************************' カラム位置と行位置を指定して印字' ******************************************************
Public Function ColPrint(CurCol As Integer, CurRow As Integer, strData As String)
Call TextOut( _
ifp.hdc, _
CurCol * ifp.nCharWidth, _
CurRow * ifp.nLinePitch, strData, _
LenB(StrConv(strData, vbFromUnicode)) _
)
End Function
' ******************************************************' フォントを指定とカラム位置と行位置を指定して印字' ******************************************************
Public Function ColFontPrint( _
FontName As String, _
nFontPoint As Long, _
CurCol As Integer, _
CurRow As Integer, _
strData As String _
)
Dim hFont As Long
Dim nHeight As Long
Dim hFontOld As Long
nHeight = -MulDiv(nFontPoint, GetDeviceCaps(ifp.hdc, LOGPIXELSY), 72)
hFont = CreateFont(nHeight, 0, 0, 0, 0, 0, 0, 0, 128, 0, 0, 0, &H1 Or &H30, FontName)
hFontOld = SelectObject(ifp.hdc, hFont)
Call ColPrint(CurCol, CurRow, strData)
Call SelectObject(ifp.hdc, hFontOld)
Call DeleteObject(hFont)
End Function
' ******************************************************' カラム位置と行位置を指定してBOX罫線(同一行)' ******************************************************
Public Function ColBox(CurCol As Integer, CurRow As Integer, CurCol2 As Integer)
Dim pa As POINTAPI
Call MoveToEx(ifp.hdc, CurCol * ifp.nCharWidth, CurRow * ifp.nLinePitch, pa)
Call LineTo(ifp.hdc, CurCol2 * ifp.nCharWidth, CurRow * ifp.nLinePitch)
Call LineTo(ifp.hdc, CurCol2 * ifp.nCharWidth, (CurRow + 1) * ifp.nLinePitch)
Call LineTo(ifp.hdc, CurCol * ifp.nCharWidth, (CurRow + 1) * ifp.nLinePitch)
Call LineTo(ifp.hdc, CurCol * ifp.nCharWidth, CurRow * ifp.nLinePitch)
End Function
' ******************************************************' カラム位置と行位置を指定してBOX罫線' ******************************************************
Public Function ColLargeBox( _
CurCol As Integer, _
CurRow As Integer, _
CurCol2 As Integer, _
CurRow2 As Integer _
)
Dim pa As POINTAPI
Call MoveToEx(ifp.hdc, CurCol * ifp.nCharWidth, CurRow * ifp.nLinePitch, pa)
Call LineTo(ifp.hdc, CurCol2 * ifp.nCharWidth, CurRow * ifp.nLinePitch)
Call LineTo(ifp.hdc, CurCol2 * ifp.nCharWidth, (CurRow2 + 1) * ifp.nLinePitch)
Call LineTo(ifp.hdc, CurCol * ifp.nCharWidth, (CurRow2 + 1) * ifp.nLinePitch)
Call LineTo(ifp.hdc, CurCol * ifp.nCharWidth, CurRow * ifp.nLinePitch)
End Function
' ******************************************************' カラム位置と行位置を指定して色を塗る(同一行)' ******************************************************
Public Function ColPaintBox( _
CurCol As Integer, _
CurRow As Integer, _
CurCol2 As Integer, _
Color As Long _
)
Dim hBrush As Long
Dim rt As RECT
hBrush = CreateSolidBrush(Color)
rt.Right = CurCol2 * ifp.nCharWidth
rt.Bottom = (CurRow + 1) * ifp.nLinePitch
rt.Top = CurRow * ifp.nLinePitch
rt.Left = CurCol * ifp.nCharWidth
Call FillRect(ifp.hdc, rt, hBrush)
Call DeleteObject(hBrush)
End Function
' ******************************************************' カラム位置と行位置で指定した長方形に色を塗る' ******************************************************
Public Function ColPaintLargeBox( _
CurCol As Integer, _
CurRow As Integer, _
CurCol2 As Integer, _
CurRow2 As Integer, _
Color As Long _
)
Dim hBrush As Long
Dim rt As RECT
hBrush = CreateSolidBrush(Color)
rt.Right = CurCol2 * ifp.nCharWidth
rt.Bottom = (CurRow2 + 1) * ifp.nLinePitch
rt.Top = CurRow * ifp.nLinePitch
rt.Left = CurCol * ifp.nCharWidth
Call FillRect(ifp.hdc, rt, hBrush)
Call DeleteObject(hBrush)
End Function
' ******************************************************' カラム位置と行位置で指定した長方形に文字列を印字' ******************************************************
Public Function ColPrintLargeBox( _
CurCol As Integer, _
CurRow As Integer, _
CurCol2 As Integer, _
CurRow2 As Integer, _
strData As String, _
nFormat As Long _
)
Dim rt As RECT
rt.Right = CurCol2 * ifp.nCharWidth
rt.Bottom = (CurRow2 + 1) * ifp.nLinePitch
rt.Top = CurRow * ifp.nLinePitch
rt.Left = CurCol * ifp.nCharWidth
Call DrawText(ifp.hdc, strData, LenB(StrConv(strData, vbFromUnicode)), rt, nFormat)
End Function
印刷処理サンプル(フレキシブルグリッドより印刷)
' ******************************************************' 印刷処理' ******************************************************
Private Sub cmdPrint_Click()
Dim i As Integer, j As Integer, x As Integer, x2 As Integer
Dim yOffset As Integer
If Not StartPrint("出欠未入力一覧", Me.hWnd) Then
Exit Sub
End If
' タイトル
Call ColPaintLargeBox(15, 0, 150, 1, RGB(255, 200, 200))
Call SetBkColor(ifp.hdc, RGB(255, 200, 200))
Call ColFontPrint("MS ゴシック", 20, 20, 0, "出欠未入力一覧表")
Call SetBkColor(ifp.hdc, RGB(255, 255, 255))
Call ColLargeBox(15, 0, 150, 1)
Call ColPrint(20, 3, "基準日 : " & frmMain.dtp指定日.Value)
Call ColPrint(20, 4, "教師 : " & frmMain.cmb教師.Text)
Call ColPrint(20, 5, "期間 : " & frmMain.cmb期間.Text)
yOffset = 7
' ---------------------------------------------------
' i は「行」
' j は「列」
' ---------------------------------------------------
For i = 0 To 7
For j = 0 To 7
With grd未入力一覧
If j = 0 Then
x = j * 20 + 14
Else
x = j * 20
End If
x2 = (j + 1) * 20
.Col = j: .Row = i: .ColSel = j: .RowSel = i
If .CellBackColor = RGB(256, 200, 200) Then
Call ColPaintBox(x - 2, i + yOffset, x2 - 2, RGB(256, 200, 200))
End If
If .CellBackColor = RGB(200, 256, 200) Then
Call ColPaintBox(x - 2, i + yOffset, x2 - 2, RGB(0, 256, 0))
End If
If i = 0 Or i = 1 Or j = 0 Then
Call ColPrint(x, i + yOffset, .TextMatrix(i, j))
Call ColBox(x - 2, i + yOffset, x2 - 2)
Else
If .CellBackColor = RGB(200, 200, 200) Then
Call ColPrint(x, i + yOffset, .TextMatrix(i, j))
End If
Call ColBox(x - 2, i + yOffset, x2 - 2)
End If
End With
Next
Next
For i = 13 To grd未入力一覧.Rows - 1
For j = 0 To 7
With grd未入力一覧
If j = 0 Then
x = j * 20 + 14
Else
x = j * 20
End If
x2 = (j + 1) * 20
.Col = j: .Row = i: .ColSel = j: .RowSel = i
If .CellBackColor = RGB(256, 200, 200) Then
Call ColPaintBox(x - 2, i - 5 + yOffset, x2 - 2, RGB(256, 200, 200))
End If
If .CellBackColor = RGB(200, 256, 200) Then
Call ColPaintBox(x - 2, i - 5 + yOffset, x2 - 2, RGB(0, 256, 0))
End If
If i Mod 7 = 6 Or i Mod 7 = 0 Or j = 0 Then
Call ColPrint(x, i - 5 + yOffset, .TextMatrix(i, j))
Call ColBox(x - 2, i - 5 + yOffset, x2 - 2)
Else
If .CellBackColor = RGB(200, 200, 200) Then
Call ColPrint(x, i - 5 + yOffset, .TextMatrix(i, j))
End If
Call ColBox(x - 2, i - 5 + yOffset, x2 - 2)
End If
End With
Next
Next
Call EndPrint
End Sub