WinGDI in QB64 - Printable Version

Code: (Select All)
Option _Explicit



$ExeIcon:'.\internal\source\icon.ico'

_Icon



$VersionInfo:CompanyName=SpriggsySpriggs

$VersionInfo:ProductName=WinGDI Test

$VersionInfo:FileDescription=A test of the WinGDI printing system

$ScreenHide



Type SIZE

    As Long cx, cy

End Type



Type POINT

    As Long x, y

End Type



Type MSG

    As _Offset hwnd

    As _Unsigned Long message

    As _Unsigned _Offset wParam

    As _Offset lParam

    As Long time

    As POINT pt

    As Long lPrivate

End Type



Type DOCINFO

    As Long cbSize

    As _Offset lpszDocName, lpszOutput, lpszDatatype

    As _Unsigned Long fwType

End Type



Type PRINTDLG

    As _Unsigned Long lStructSize

    $If 64BIT Then

        As String * 4 padding

    $End If

    As _Offset hwndOwner, hDevMode, hDevNames, hDC

    As _Unsigned Long Flags

    As _Unsigned Integer nFromPage, nToPage, nMinPage, nMaxPage, nCopies

    $If 64BIT Then

        As String * 2 padding2

    $End If

    As _Offset hInstance, lCustData, lpfnPrintHook, lpfnSetupHook, lpPrintTemplateName, lpSetupTemplateName, hPrintTemplate, hSetupTemplate

End Type



Declare Dynamic Library "Comdlg32"

    Sub PrintDlg Alias "PrintDlgA" (ByVal lppd As _Offset)

End Declare



Declare Dynamic Library "Gdi32"

    Function GetDeviceCaps& (ByVal hdc As _Offset, Byval index As Long)

    Sub SelectObject (ByVal hdc As _Offset, Byval h As _Offset)

    Function CreatePen%& (ByVal iStyle As Long, Byval cWidth As Long, Byval color As _Unsigned Long)

    Sub Rectangle (ByVal hdc As _Offset, Byval left As Long, Byval top As Long, Byval right As Long, Byval bottom As Long)

    Sub SetBkMode (ByVal hdc As _Offset, Byval mode As Long)

    Sub TextOut Alias "TextOutA" (ByVal hdc As _Offset, Byval x As Long, Byval y As Long, Byval lpString As _Offset, Byval c As Long)

    Function SetAbortProc& (ByVal hdc As _Offset, Byval proc As _Offset)

    Sub StartDoc Alias "StartDocA" (ByVal hdc As _Offset, Byval lpdi As _Offset)

    Sub StartPage (ByVal hdc As _Offset)

    Sub EndPage (ByVal hdc As _Offset)

    Sub EndDoc (ByVal hdc As _Offset)

    Sub DeleteDC (ByVal hdc As _Offset)

    Function CreateFont%& Alias "CreateFontA" (ByVal cHeight As Long, Byval cWidth As Long, Byval cEscapement As Long, Byval cOrientation As Long, Byval cWeight As Long, Byval bItalic As _Unsigned Long, Byval bUnderline As _Unsigned Long, Byval bStrikeout As _Unsigned Long, Byval iCharSet As _Unsigned Long, Byval iOutPrecision As _Unsigned Long, Byval iClipPrecision As _Unsigned Long, Byval iQuality As _Unsigned Long, Byval iPitchAndFamily As _Unsigned Long, pszFaceName As String)

    Sub SetTextColor (ByVal hdc As _Offset, Byval color As _Unsigned Long)

    Sub GetTextExtentPoint32 Alias "GetTextExtentPoint32A" (ByVal hdc As _Offset, lpString As String, Byval c As Long, Byval psizl As _Offset)

End Declare



Declare CustomType Library

    Function PeekMessage& (ByVal lpMsg As _Offset, Byval hWnd As _Offset, Byval wMsgFilterMin As _Unsigned Long, Byval wMsgFilterMax As _Unsigned Long, Byval wRemoveMsg As _Unsigned Long)

    Sub TranslateMessage (ByVal lpMsg As _Offset)

    Sub DispatchMessage (ByVal lpMsg As _Offset)

    Sub MessageBox (ByVal hWnd As _Offset, lpText As String, lpCaption As String, Byval uType As _Unsigned Long)

    Function GetLastError~& ()

End Declare



Declare CustomType Library "abort"

    Function pAbortProc%& ()

End Declare



$If 64BIT Then

    Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\wingdi"

        Function RGB~& (ByVal r As _Unsigned _Byte, Byval g As _Unsigned _Byte, Byval b As _Unsigned _Byte)

    End Declare

$Else

        Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\wingdi"

        Function RGB~& (ByVal r As _Unsigned _Byte, Byval g As _Unsigned _Byte, Byval b As _Unsigned _Byte)

        End Declare

$End If

Dim Shared As PRINTDLG pdlg

PrintJob

System



Sub InitPrintJobDoc (di As DOCINFO, docname As String)

    docname = docname + Chr$(0)

    di.cbSize = Len(di)

    di.lpszDocName = _Offset(docname)

End Sub



Sub DrawPage (hdc As _Offset, Page As _Unsigned Long)

    Const HORZRES = 8

    Const VERTRES = 10

    Const PS_SOLID = 0

    Const TRANSPARENT = 1

    Dim As String * 50 gdiline

    Dim As Long nWidth, nHeight

    nWidth = GetDeviceCaps(hdc, HORZRES)

    nHeight = GetDeviceCaps(hdc, VERTRES)

    'SelectObject hdc, CreatePen(PS_SOLID, 2, RGB(255, 0, 0))

    'Rectangle hdc, 0, 0, nWidth - 4, nHeight - 2

    SetBkMode hdc, TRANSPARENT

    Dim As SIZE size

    Dim As String t1, t2, t3

    t1 = "Title!"

    If Page = 1 Then t2 = "This is a print test on page 1!" Else t2 = "This is another print test on page" + _Trim$(Str$(Page)) + "!"

    t3 = "Page" + Str$(Page)

    HDCPrint hdc, t1, "Castellar", 72, "UNDERLINE", "BLACK", 425, 550, RGB(188, 33, 116)

    HDCPrint hdc, t2, "Freestyle Script", 48, "UNDERLINE", "BLACK", 425, 750, RGB(33, 127, 127)

    HDCPrint hdc, t3, "Goudy Stout", 24, "", "BLACK", 425, 1100, RGB(127, 55, 127)

End Sub



Function AbortProc%% (hDC As _Offset, Errr As Long)

    Const PM_REMOVE = &H0001

    Dim As MSG msg

    While PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE)

        TranslateMessage _Offset(msg)

        DispatchMessage _Offset(msg)

    Wend

    AbortProc = -1

End Function



Function GetPrinterDC%& (Pages As _Unsigned Long)

    Const PD_RETURNDC = &H100

    pdlg.lStructSize = Len(pdlg)

    pdlg.Flags = PD_RETURNDC

    pdlg.nMinPage = 1

    pdlg.nMaxPage = Pages

    pdlg.nToPage = Pages

    PrintDlg _Offset(pdlg)

    GetPrinterDC = pdlg.hDC

End Function



Sub PrintJob ()

    Const MB_OK = &H00000000

    Const MB_APPLMODAL = &H00000000

    Const SP_ERROR = -1

    Dim As _Offset hDC

    Dim As DOCINFO di

    hDC = GetPrinterDC(2)

    If hDC = 0 Then

        MessageBox 0, "Error creating DC" + Chr$(0), "Error" + Chr$(0), MB_APPLMODAL Or MB_OK

        Exit Sub

    End If

    If SetAbortProc(hDC, pAbortProc) = SP_ERROR Then

        MessageBox 0, "Error setting up AbortProc" + Chr$(0), "Error" + Chr$(0), MB_APPLMODAL Or MB_OK

        Exit Sub

    End If

    InitPrintJobDoc di, "MyDoc"

    StartDoc hDC, _Offset(di)

    Dim As Long i, l

    For l = 1 To pdlg.nCopies

        For i = 1 To pdlg.nToPage

            StartPage hDC

            DrawPage hDC, i

            EndPage hDC

        Next

    Next

    EndDoc hDC

    DeleteDC hDC

End Sub



Sub HDCPrint (hdc As _Offset, text As String, fontName As String * 32, height As Long, style As String, weightStyle As String, x As Long, y As Long, colorref As _Unsigned Long)

    Dim As _Offset font

    Dim As _Byte bold, underline, strikeout, italic

    Dim As Long weight

    style = UCase$(style)

    If InStr(style, "UNDERLINE") Then underline = -1

    If InStr(style, "STRIKEOUT") Then strikeout = -1

    If InStr(style, "ITALIC") Then italic = -1

    Select Case UCase$(weightStyle)

        Case "THIN"

            weight = 100

        Case "EXTRALIGHT", "ULTRALIGHT"

            weight = 200

        Case "LIGHT"

            weight = 300

        Case "NORMAL", "REGULAR"

            weight = 400

        Case "MEDIUM"

            weight = 500

        Case "SEMIBOLD", "DEMIBOLD"

            weight = 600

        Case "BOLD"

            weight = 700

        Case "EXTRABOLD", "ULTRABOLD"

            weight = 800

        Case "HEAVY", "BLACK"

            weight = 900

        Case Else

            weight = 0

    End Select

    Dim As Long FF_DECORATIVE: FF_DECORATIVE = _ShL(5, 4)

    Dim As Long FF_MODERN: FF_MODERN = _ShL(3, 4)

    Dim As Long FF_ROMAN: FF_ROMAN = _ShL(1, 4)

    Dim As Long FF_SCRIPT: FF_SCRIPT = _ShL(4, 4)

    Dim As Long FF_SWISS: FF_SWISS = _ShL(2, 4)

    Const LOGPIXELSY = 90

    Const LOGPIXELSX = 88

    Const DT_CALCRECT = &H00000400

    Dim As Long DPIScaleY: DPIScaleY = GetDeviceCaps(hdc, LOGPIXELSY) / 96

    Dim As Long DPIScaleX: DPIScaleX = GetDeviceCaps(hdc, LOGPIXELSX) / 96

    font = CreateFont(height * DPIScaleY, 0, 0, 0, weight, italic, underline, strikeout, 0, 0, 0, 5, FF_DECORATIVE Or FF_MODERN Or FF_ROMAN Or FF_SCRIPT Or FF_SWISS, fontName + Chr$(0))

    If font Then

        SelectObject hdc, font

        SetTextColor hdc, colorref

        Dim As SIZE size

        GetTextExtentPoint32 hdc, text, Len(text), _Offset(size)

        Dim As Long nx, ny

        If x > 0 Then nx = (x * DPIScaleX) - size.cx / 2 Else nx = x * DPIScaleX

        If y > 0 Then ny = (y * DPIScaleY) - (size.cy) Else ny = y * DPIScaleY

        TextOut hdc, nx, ny, _Offset(text), Len(text)

    End If

End Sub