This code sample demonstrates how to output a text character using the Win32 api textout. The process includes two parts starting first with a two dimensional character array called aScreenChars mapping to a column and row on the display and a two dimensional attributes string array containing a concatenation of attributes commands per string. The attributes string is parsed and the attributes applied before the character is rasterized.
Each textout character is rasterized using the text_opaque turned on. The form font properties are initialized or de-initialized in a functional called setattributes. Some of the font attributes include underline, bold, background color, and text color.
The screeninitialize method extracts the character width and height used during text rasterization.
The form paint events calls the displaytext method which can render out a single character
or all characters in the ascreenChars array.
API Module
Option Explicit Public 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 Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor _ As Long) As Long Public Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As _ Long) As Long Public Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long Public Const TEXT_TRANSPARENT = 1 Public Const TEXT_OPAQUE = 2 Public Const conScreenHeight = 24 Public Const conScreenWidth = 80 Public aScreenChars(conScreenWidth + 1, conScreenHeight + 1) As String Public aAttributes(conScreenWidth + 1, conScreenHeight + 1) As String Public Const constATTR_NORMAL = "0"
frmMain (variables)
Option Explicit Const constOne = 1 Const constAll = 2 Dim iCharWidth, iCharHeight As Integer Dim iCursorRow, iCursorColumn As Integer Dim iTermBKColor, iTermTextColor As Long
frmMain (functions)
Public Sub ScreenInitialize()
Dim RC
With Me
.FontUnderline = False
.FontItalic = False
.FontBold = False
.Font.Name = "Fixedsys"
.ScaleMode = 3
If iCharWidth = 0 Then
iCharWidth = .TextWidth("M")
End If
If iCharHeight = 0 Then
iCharHeight = .TextHeight("M") + 2
End If
End With
'Setup the User Scale of the display
With Me
.ScaleMode = 0
.ScaleWidth = conScreenWidth
.ScaleHeight = conScreenHeight
End With
Me.Scale (0, 0)-(conScreenWidth - 1, conScreenHeight - 1)
RC = SetBkMode(hDC, TEXT_OPAQUE)
iTermTextColor = QBColor(15)
iTermBKColor = QBColor(0)
End Sub
Public Sub DisplayText(iType As Integer)
Dim i
Dim j
Dim sBuffer
Dim iAttrChangeOffset As Integer
Dim sAttributeCmds As String
Dim iNewAttribute As Integer
Dim sOldAttributeCmds As String
Dim iRow As Integer
Dim iColumn As Integer
If iType = constAll Then
For i = 0 To conScreenHeight
sBuffer = ""
For j = 0 To conScreenWidth
sBuffer = aScreenChars(j, i)
sAttributeCmds = aAttributes(j, i)
If sAttributeCmds <> sOldAttributeCmds Then
Do
iNewAttribute = Val(EscapeParseArg(sAttributeCmds))
SetAttribute (iNewAttribute)
Loop While sAttributeCmds <> ""
End If
TextOut hDC, j * iCharWidth, i * iCharHeight, sBuffer, Len(sBuffer)
sOldAttributeCmds = sAttributeCmds
Next
Next
ElseIf iType = constOne Then
i = iCursorRow
j = iCursorColumn - 1
sBuffer = aScreenChars(j, i)
sAttributeCmds = aAttributes(j, i)
Do
iNewAttribute = Val(EscapeParseArg(sAttributeCmds))
SetAttribute (iNewAttribute)
Loop While sAttributeCmds <> ""
TextOut hDC, j * iCharWidth, i * iCharHeight, sBuffer, Len(sBuffer)
End If
End Sub
Private Function EscapeParseArg(s As String) As String
Dim i As Integer
i = InStr(s, ";")
If i = 0 Then
EscapeParseArg = s
s = ""
Else
EscapeParseArg = Left(s, i - 1)
s = Mid(s, i + 1)
End If
End Function
Public Sub SetAttribute(ch As Integer)
Dim RC As Long
Select Case ch
Case 0 'Normal
With Me
.FontUnderline = False
.FontItalic = False
.FontBold = False
.Font.Name = "Fixedsys"
End With
'RC = SetBkColor(hDC, iTermBKColor)
'RC = SetTextColor(hDC, iTermTextColor)
Case 1 'Bold
With Me
.FontBold = True
End With
RC = SetTextColor(hDC, QBColor(9))
Case 5 'Blinking
With Me
.FontItalic = True
End With
RC = SetTextColor(hDC, QBColor(3))
Case 4 'Underscore
With Me
.FontUnderline = True
End With
Case 7 'Reverse Video
iTermTextColor = iTermBKColor
iTermBKColor = iTermTextColor
Case 8 'Cancel
iTermTextColor = iTermBKColor
iTermBKColor = iTermTextColor
Case 30 'Black Foreground
iTermTextColor = QBColor(0)
Case 31 'Red Foreground
iTermTextColor = QBColor(4)
Case 32 'Green Foreground
iTermTextColor = QBColor(2)
Case 33 'Yellow Foreground
iTermTextColor = QBColor(14)
Case 34 'Blue Foreground
iTermTextColor = QBColor(1)
Case 35 'Magenta Foreground
iTermTextColor = QBColor(5)
Case 36 'Cyan Foreground
iTermTextColor = QBColor(3)
Case 37 'White Foreground
iTermTextColor = QBColor(15)
Case 40 'Black Background
iTermBKColor = QBColor(0)
Case 41 'Red Background
iTermBKColor = QBColor(4)
Case 42 'Green Background
iTermBKColor = QBColor(2)
Case 43 'Yellow Background
iTermBKColor = QBColor(14)
Case 44 'Blue Background
iTermBKColor = QBColor(1)
Case 45 'Magenta Background
iTermBKColor = QBColor(5)
Case 46 'Cyan Background
iTermBKColor = QBColor(3)
Case 47 'White Background
iTermBKColor = QBColor(15)
End Select
With Me
.ForeColor = iTermTextColor
.BackColor = iTermBKColor
RC = SetBkColor(hDC, .BackColor)
RC = SetTextColor(hDC, .ForeColor)
End With
End Sub
Private Sub Form_Load()
ScreenInitialize
aScreenChars(20, 5) = "H"
aAttributes(20, 5) = "0;1;32"
aScreenChars(21, 5) = "E"
aAttributes(21, 5) = "0"
aScreenChars(22, 5) = "L"
aAttributes(22, 5) = "0"
aScreenChars(23, 5) = "L"
aAttributes(23, 5) = "0"
aScreenChars(24, 5) = "O"
aAttributes(24, 5) = "0;1;33"
End Sub
Private Sub Form_Paint()
DisplayText constAll
End Sub