'-lang qb
Const FONT_PATH = "E:\tools\tiko\myfb\hzfont\"

Sub DrawHZK48 (x As Integer, y As Integer, highByte As Integer, lowByte As Integer)
    Dim As uByte buffer(287), area, tops
    Dim As uInteger i, k,pattern
    Dim As uLong hzk48, offset 
    
    ' 计算区码和位码
    area = highByte - &HA0
    tops = lowByte - &HA0
    ' 计算偏移量 (48×48 = 2304位 = 288字节)
    offset = ((area - 1) * 94 + (tops - 1)) * 288
    hzk48 = FreeFile
    Open FONT_PATH + "hzk48" For Binary As #hzk48
    If hzk48 <= 0 Then
        Print "Font open fail."
        Sleep
        Exit Sub
    End If
    ' 读取288字节数据
    Get #hzk48, offset + 1, buffer()
    For i = 0 To 47 ' 48行
        ' 每行6字节，分三段绘制：16像素 + 16像素 + 16像素
        ' 第一段：前16像素（字节0-1）
        pattern = (buffer(i * 6) Shl 8) + buffer(i * 6 + 1)
        If pattern > 0 Then
            Line (x, y + i)-Step(15, 0), , , pattern
        End If
        ' 第二段：中间16像素（字节2-3）
        pattern = (buffer(i * 6 + 2) Shl 7) + (buffer(i * 6 + 3) ShR 1)
        If pattern > 0 Then
            Line (x + 15, y + i)-Step(15, 0), , , pattern
        End If
        ' 第三段：最后的16像素（字节4-5）
        pattern = (buffer(i * 6 + 4) Shl 7) + (buffer(i * 6 + 5) ShR 1)
        If pattern > 0 Then
            Line (x + 30, y + i)-Step(16, 0), , , pattern
        End If
    Next i
End Sub

Sub DrawASC48 (x As Integer, y As Integer, asciiCode As Integer)
    Dim buffer(143) As uByte, i As Integer
    Dim As Long offset,asc48
    Dim pattern As uInteger
    ' ASCII字符从32-126，共95个字符
    ' 每个字符48×48 = 288字节
    offset = (asciiCode - 32) * 144
    asc48 = FreeFile
    Open FONT_PATH + "asc48_1" For Binary As #asc48
    If asc48 <= 0 Then
        Print "Font open fail."
        Sleep
        Exit Sub
    End If
    ' 读取288字节数据
    Get #asc48, offset + 1, buffer()
    For i = 0 To 47 ' 48行
        ' 每行3字节，分2段绘制：16像素 + 8像素
        pattern = buffer(i * 3) shl 8 + buffer(i * 3 + 1)
        If pattern > 0 Then
            Line (x, y + i)-Step(15, 0), , , pattern
        End If
        pattern = buffer(i * 3 + 2) shl 7'* 128
        If pattern > 0 Then
            Line (x + 15, y + i)-Step(7, 0), , , pattern
        End If
    Next i
End Sub

Sub Printhz (x0 As Integer, y0 As Integer, hzWord As String, hzcol As Integer,fSize as integer)
    Dim As Integer baseX, baseY, areaCode, posCode
    Dim As Integer totalLen, now, y,pixel
    Dim filePos As Long
    Dim As UByte ascArr(15), byteArr(31)
    Dim As Long zkasc, zkhzk
    '打开字库文件，zkasc，zkhzk汉字库
    zkasc = FreeFile
    Open FONT_PATH + "asc16" For Binary As #zkasc
    If LOF(zkasc) = 0 Then Print "没有汉字库！ ": End
    zkhzk = FreeFile
    Open FONT_PATH + "hzk16" For Binary As #zkhzk
    If LOF(zkhzk) = 0 Then Print "没有汉字库！ ": End
    '设定坐标，总字长
    baseX = x0: baseY = y0
    totalLen = Len(hzWord)
    '读取汉字并显示
    For now = 1 To totalLen
        areaCode = Asc(hzWord, now)
        If areaCode >= 161 Then
            If now + 1 > totalLen Then
                ' 单字节汉字，视为非法，跳过并提示（可选）
                Print "Warning:Incomplete Chinese characters."
                now = now + 1: Exit For
            End If
            If now + 1 > totalLen Then Exit For
            posCode = Asc(hzWord, now + 1)
            If areaCode < 161 Or areaCode > 254 Or posCode < 161 Or posCode > 254 Then
                baseX = baseX + 16:
                now = now + 1: Exit For ' 跳过非法字符
            End If
            select case fSize
               case 16
                 '读取字库，如有不显示的情况，可减32的不显示区，或再-15的扩展区
                  filePos = (areaCode - 161) * 94& * 32& + (posCode - 161) * 32& + 1
                  Get #zkhzk, filePos, byteArr()
                  For y = 0 To 15
                     pixel = byteArr(y * 2) shl 8 + byteArr(y * 2 + 1) 'shl=bytearr(y*2)*256
                     Line (baseX, baseY + y)-Step(15, 0), hzcol, , pixel
                  Next y
                  baseX = baseX + 16': now = now + 1 
               case 48
                  DrawHZK48 baseX, baseY, areacode, poscode   
                  baseX = baseX + 48
            end select
            now = now + 1 
         Else
            select case fsize
               case 16
                     Get #zkasc, areaCode * 16&, ascArr()
                     For y = 0 To 15
                        pixel = ascArr(y) shl 7'*128 'shl=ascarr(y) * 256
                        Line (baseX, baseY + y + 1)-Step(15, 0), hzcol, , pixel
                     Next y
                   baseX = baseX + 9
               case 48
                  drawasc48 baseX, baseY, areacode  
                  baseX=baseX+24
            end select
        End If
      Next now
      Close #zkhzk,#zkasc
End Sub

Screenres 800,600,32
dim as string hz1,hz2
hz1 = "123微软专用操作系统安装工具456！"
hz2 = "abcgq这是显示汉字的子程序def"
Color rgb(0, 0, 0), rgb(151, 151, 151)
Cls
printhz 50,150,hz1,2,16
printhz 50,170,hz2,4,16
printhz 50,50,"功能强大的Freebasic!",0,48
sleep
system