WinGDI in QB64

[SpriggsySpriggs]

Here is some code you can use for accessing WinGDI in QB64. You can print straight to your printer or you can pick "Microsoft Print to PDF" if you just want to save a file.
Attached is the necessary header file as well as a PDF output of what the code currently makes.

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

[Pete]

The routine calls "PrintJob" to start the printing process. How does that sub-routine get the info to print, as the sub call has no parameters, or does this example simply print the contents of the active window?

Thanks,

Pete

[SpriggsySpriggs]

The routine calls "PrintJob" to start the printing process. How does that sub-routine get the info to print, as the sub call has no parameters, or does this example simply print the contents of the active window?

Thanks,

Pete

The program just calls that to start up the sample code. DrawPage creates each page. You can download the attached PDF to see what the code creates. DrawPage can be tweaked to show different things on the page such as different font sizes, colors, and families. This code isn't a library just yet but can be easily changed to one.

[Pete]

Got it.

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)

This is the area that could be modified to provide line by line printing from a file. Reminds me of formatting with .rtf files. Nice!

Pete