Lightbox Info Board : SQLの窓

PRINT.bas by Lightbox


' ******************************************************
' 印刷ダイアログ用
' ******************************************************
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("ＭＳ ゴシック", 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