display unicode text(by windows api)

Code: (Select All)

'$Console

_Title "Display Unicode Character - Test"

Declare Dynamic Library "kernel32"

    FUNCTION MultiByteToWideChar& (BYVAL CodePage AS LONG, BYVAL dwFlags AS LONG,_

                                  BYVAL lpMultiByteStr AS _OFFSET, BYVAL cbMultiByte AS LONG,_

                                  BYVAL lpWideCharStr AS _OFFSET, BYVAL cchWideChar AS LONG)

End Declare

'You can modify the path to point to their local font directory.

Const FONT_PATH = "c:\windows\fonts\"

'Define global font IDs (handles) for four fonts to be loaded

Dim Shared As Long fN3 'fn, fn1, fn2, fn3



text$ = "美丽中国Beautiful China"

mk_data$ = StringToUnicodeMK(text$)



'Dim As String inputStrSc, inputStrCon

'Use input,QBpe IDE shows garbled (ANSI display), but data stores correctly.

'Line Input "Input texts in the screen:", inputStrSc

'Initializes the screen and loads fonts.

initinput

'Switch to console (native Unicode support) for clean input

'_ScreenHide

'_Console On

'_Dest _Console

'Line Input "Input texts in the console:", inputStrCon

'_Console Off

'_ScreenShow

'_ScreenMove _Middle

'_Dest 0



'_UPrintString (50, 50), StringToUnicodeMK(inputStrSc + inputStrCon), , 16, fn

'_UPrintString (50, 80), mk_data$, , 16, fn

'_UPrintString (50, 110), mk_data$, , 16, fn1

'_UPrintString (50, 150), mk_data$, , 16, fn2

If fN3 > 0 Then

    _UPrintString (50, 200), mk_data$, , 16, fN3

Else

    _PrintString (50, 40), "Font load false._UPrintString may not work, use _PrintString for English"

End If

Sleep

_Font 16

'_FreeFont fn

'_FreeFont fn1

'_FreeFont fn2

_FreeFont fN3

System



'Initializes the screen and loads fonts.

Sub initinput

    Screen _NewImage(1000, 760, 32)

    _ScreenMove _Middle

    Cls , _RGB32(155, 155, 155)

    _PrintMode _KeepBackground

    Color _RGB32(0, 0, 0)

    'You may substitute simsun.ttc... with a locally supported font file.

    'fn = _LoadFont(FONT_PATH + "simsun.ttc", 20, "automono")

    'fn1 = _LoadFont(FONT_PATH + "KTGB2312.ttf", 30, "automono")

    'fn2 = _LoadFont(FONT_PATH + "STLITI.TTF", 40, "automono")

    fN3 = _LoadFont(FONT_PATH + "STHUPO.TTF", 50, "automono")

    If fN3 <= 0 Then

        ' Second fallback also failed

        Print "Fallback font also unavailable."

        Print "Using system default font (English only)."

        ' Use system default font (won't display Chinese properly)

        _Font 16

        ' Note: System font handle cannot be obtained directly

    End If

End Sub



'  Main function: Converts entire string at once, then unpacks

Function StringToUnicodeMK$ (teXt As String)

    Const CP_ACP = 0 ' Code page: ANSI (default system locale)

    Const UTF16_WIDTH = 2 'Character width in bytes for UTF-16 (little-endian)

    Dim As String result, buffer, str_null

    Dim As _Unsigned Long needed, written

    Dim As _Unsigned Integer i, posC

    Dim hi As _Unsigned _Byte

    If Len(teXt) = 0 Then Exit Function

    result = ""

    ' Convert entire string to Unicode in one operation

    str_null = teXt + Chr$(0)

    needed = MultiByteToWideChar(CP_ACP, 0, _Offset(str_null$), Len(str_null$), 0, 0)

    If needed <= 1 Then Exit Function

    buffer = Space$(needed * UTF16_WIDTH) ' Allocate buffer for wide chars

    written = MultiByteToWideChar(CP_ACP, 0, _Offset(str_null$), Len(str_null$), _Offset(buffer), needed)

    If written <= 1 Then Exit Function

    ' Unpack wide characters and pack into MK$ format (skip final null)

    For i = 1 To written - 1

        posC = (i - 1) * UTF16_WIDTH + 1 'Position in byte buffer (1-based)

        ' Asc(buffer, posC + 1)  High byte (for Chinese characters)

        ' If hi = 0, character is ASCII, value is low byte only

        ' Pack as little-endian 16-bit integer (QB64 uses little-endian architecture)

        result = result + _MK$(Integer, Asc(buffer, posC + 1) * 256 + Asc(buffer, posC))

    Next

    StringToUnicodeMK = result

End Function

Code: (Select All)

$Console

_Title "Display Unicode Character - Test"

Declare Dynamic Library "kernel32"

    FUNCTION MultiByteToWideChar& (BYVAL CodePage AS LONG, BYVAL dwFlags AS LONG,_

                                  BYVAL lpMultiByteStr AS _OFFSET, BYVAL cbMultiByte AS LONG,_

                                  BYVAL lpWideCharStr AS _OFFSET, BYVAL cchWideChar AS LONG)

End Declare

'You can modify the path to point to their local font directory.

Const FONT_PATH = "c:\windows\fonts\"



Dim Shared As Long fn, fn1, fn2, fn3



text$ = "????Beautiful China"

mk_data$ = StringToUnicodeMK(text$)



Dim As String inputStrSc, inputStrCon

'Use input,QBpe IDE shows garbled (ANSI display), but data stores correctly.

'Line Input "Input texts in the screen:",

inputStrSc = "Hi qbfans!"

'Initializes the screen and loads fonts.

initinput

'Switch to console (native Unicode support) for clean input

_ScreenHide

_Console On

_Dest _Console

'Line Input "Input texts in the console:",

inputStrCon = " testing code..."

_Console Off

_ScreenShow

_Delay .3

_ScreenMove _Middle

_Dest 0



_UPrintString (50, 50), StringToUnicodeMK(inputStrSc + inputStrCon), , 16, fn

_UPrintString (50, 80), mk_data$, , 16, fn

'_UPrintString (50, 110), mk_data$, , 16, fn1

'_UPrintString (50, 150), mk_data$, , 16, fn2

'_UPrintString (50, 200), mk_data$, , 16, fn3



Sleep

_Font 16

_FreeFont fn

'_FreeFont fn1  ' not found

'_FreeFont fn2  ' ditto

'_FreeFont fn3  ' ditto

System



'Initializes the screen and loads fonts.

Sub initinput

    Screen _NewImage(1000, 760, 32)

    _ScreenMove _Middle

    Cls , _RGB32(155, 155, 155)

    _PrintMode _KeepBackground

    Color _RGB32(0, 0, 0)

    'You may substitute simsun.ttc... with a locally supported font file.

    fn = OKFont&(FONT_PATH + "simsun.ttc", 20, "automono")

    'fn1 = OKFont&(FONT_PATH + "KTGB2312.ttf", 30, "automono")

    'fn2 = OKFont&(FONT_PATH + "STLITI.TTF", 40, "automono")

    'fn3 = OKFont&(FONT_PATH + "STHUPO.TTF", 50, "automono")

End Sub



'  Main function: Converts entire string at once, then unpacks

Function StringToUnicodeMK$ (teXt As String)

    Const CP_ACP = 0 ' Code page: ANSI (default system locale)

    Const UTF16_WIDTH = 2 'Character width in bytes for UTF-16 (little-endian)

    Dim As String result, buffer, str_null

    Dim As _Unsigned Long needed, written

    Dim As _Unsigned Integer i, posC

    Dim hi As _Unsigned _Byte

    If Len(teXt) = 0 Then Exit Function

    result = ""

    ' Convert entire string to Unicode in one operation

    str_null = teXt + Chr$(0)

    needed = MultiByteToWideChar(CP_ACP, 0, _Offset(str_null$), Len(str_null$), 0, 0)

    If needed <= 1 Then Exit Function

    buffer = Space$(needed * UTF16_WIDTH) ' Allocate buffer for wide chars

    written = MultiByteToWideChar(CP_ACP, 0, _Offset(str_null$), Len(str_null$), _Offset(buffer), needed)

    If written <= 1 Then Exit Function

    ' Unpack wide characters and pack into MK$ format (skip final null)

    For i = 1 To written - 1

        posC = (i - 1) * UTF16_WIDTH + 1 'Position in byte buffer (1-based)

        ' Asc(buffer, posC + 1)  High byte (for Chinese characters)

        ' If hi = 0, character is ASCII, value is low byte only

        ' Pack as little-endian 16-bit integer (QB64 uses little-endian architecture)

        result = result + _MK$(Integer, Asc(buffer, posC + 1) * 256 + Asc(buffer, posC))

    Next

    StringToUnicodeMK = result

End Function



Function OKFont& (pathFile$, size%, style$)

    result& = _LoadFont(pathFile$, size%, style$)

    If result& > 0 Then OKFont& = result& Else Print pathFile$ + " not found, goodbye": End

End Function

Screen _NewImage(800, 600, 32) chinese$ = _ReadFile$("Chinese-Simplified8.txt") 'read out chinese file Screen _NewImage(800, 600, 32) '32-bit screen for custom font f = _LoadFont("msyh.ttc", 16, "monospace") 'load the windows built in chinese font _Font f 'swap to that font _UPrintString (0, 0), chinese$, 800, 8, f 'print the file 'note that there are no breakpoints in this file and no wordwrap. You'd need to detect those and split them yourself.