display unicode text(by windows api)

[bplus]

Well yes the fonts aren't loading except first?

Didn't get anywhere with Chinese Text.

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

At least it runs without error for me.
   

Actually the font looks unchanged so maybe even the first font, fn = OKFont&(FONT_PATH + "simsun.ttc", 20, "automono"), didn't load right either???