VB6 - Unicode Captions for all intrinsic controls (yes, LABEL too!) - no OCX required

[VanGoghGaming]

When developing international applications there is often a need to display user interface elements in foreign languages. I've put together a small "cCapW" class that can handle Unicode captions for all intrinsic controls (Form, CommandButton, CheckBox, OptionButton, Frame and Label). The class only has one property which is also marked as "Default" to keep the syntax as short as possible. It is also "Predeclared" so it can be used "as is" without declaring new instances:

' For example instead of using:
cmdButton.Caption = "Some ANSI Text"
' Now we can use:
cCapW(cmdButton) = "千άη匚𝓎 𝐮ⓝ𝔦¢ｏ𝓓ε 𝓣έⓍ𝔱"

Here's a screenshot of the demo program showing Unicode captions in action (clicking on each element will randomly change its caption from a selection of strings loaded from a file):



While for most controls the solution can be as easy as subclassing their hWnd and handling WM_GETTEXT and WM_SETTEXT messages, the Label control proved to be a little tricky as it doesn't have a hWnd at all. It turns out the Label is using the "TextOut" GDI function to draw text directly on the device context of its parent window (which is usually a form). In this case the solution was to change the ANSI version of the "TextOutA" GDI function and point it to our own custom "HookedTextOut" function that ends up calling the Unicode-capable "TextOutW" function to draw the actual text.

The "Caption" property of a label is only capable of holding ANSI text so all Unicode captions are first encoded to Base64 and then decoded on the fly by our "HookedTextOut" function when they need to be rendered on the screen. Another problem that needed addressing was that the form is being repainted multiple times (when moved around, when covered by other windows, when minimized and restored, etc). On every such repainting event the form is using "TextOut" to write all Label captions at once so we needed to identify which caption was already encoded to Base64 and which was not because a form can contain both ANSI and Unicode labels at the same time depending on user needs.

Finally, the "TextOut" function is not capable of formatted output on its own (for example it cannot draw multiple lines of text at once). Internally, the Label control has additional code that can format the caption text and call "TextOut" multiple times in order to draw multi-line captions or captions that wrap around at the edge. The latest version of this project addresses this problem and can now draw multi-line Unicode captions as long as the lines are separated by NewLine characters (vbCrLf). The obvious limitation of this approach is that it won't work with the "AutoSize" and "WordWrap" properties of a Label control and all captions will be left-aligned.

cCapW.cls

Option Explicit

Implements ISubclass

Private Const TextOutA As String = "TextOutA", GDI32_DLL As String = "gdi32.dll", CRYPT_STRING_BASE64 As Long = 1, CRYPT_STRING_NOCRLF As Long = &H40000000, _
              WM_SETTEXT As Long = &HC, WM_GETTEXT As Long = &HD, WM_GETTEXTLENGTH As Long = &HE

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function CryptBinaryToString Lib "crypt32" Alias "CryptBinaryToStringW" (pbBinary As Any, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, pcchString As Long) As Long
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, pbBinary As Any, pcbBinary As Long, pdwSkip As Long, pdwFlags As Long) As Long

Private lOriginalProcAddress As Long, byteOriginalAddress(0 To 5) As Byte

Public Property Get CaptionW(objControl As Object) As String
Dim lTextLen As Long, byteCaption() As Byte
On Error GoTo ErrorHandler
    With objControl
        If TypeOf objControl Is Label Then ' Labels are a special case since they don't have a hWnd
            If lOriginalProcAddress = 0 Then HookTextOut ' Hook the "TextOutA" function if it hasn't been done already
            CaptionW = .Caption
            If Left$(CaptionW, 1) = vbVerticalTab Then ' A "VerticalTab (ASCII 11)" character is used to mark this label caption as Base64 encoded
                CaptionW = Mid$(CaptionW, 2) ' Remove the "VerticalTab" character from the caption
                If CryptStringToBinary(StrPtr(CaptionW), Len(CaptionW), CRYPT_STRING_BASE64, ByVal 0&, lTextLen, ByVal 0&, ByVal 0&) Then ' Get the data length required for Base64 decoding
                    ReDim byteCaption(0 To lTextLen - 1) ' Allocate memory for decoding the Base64 Caption
                    If CryptStringToBinary(StrPtr(CaptionW), Len(CaptionW), CRYPT_STRING_BASE64, byteCaption(0), lTextLen, ByVal 0&, ByVal 0&) Then ' Decode the Caption from Base64
                        CaptionW = byteCaption ' The byte array already contains a Unicode string (due to using the Unicode version of "CryptStringToBinary") so just assign it to the caption
                    End If
                End If
            End If
        Else ' Everything else can easily handle Unicode via a simple WM_GETTEXT message
            lTextLen = DefWindowProc(.hWnd, WM_GETTEXTLENGTH, 0&, 0&)  ' Get the caption length
            CaptionW = String$(lTextLen, vbNullChar) ' Allocate memory for the caption
            DefWindowProc .hWnd, WM_GETTEXT, lTextLen + 1, StrPtr(CaptionW) ' Get the caption text
        End If
    End With
    Exit Property
ErrorHandler:
    Err.Clear ' This isn't a valid object or the control doesn't have a hWnd property
End Property

Public Property Let CaptionW(objControl As Object, sCaption As String)
Dim lTextLen As Long, sBase64Caption As String
On Error GoTo ErrorHandler
    With objControl
        If TypeOf objControl Is Label Then ' Labels are a special case since they don't have a hWnd
            If lOriginalProcAddress = 0 Then HookTextOut ' Hook the "TextOutA" function if it hasn't been done already
            If CryptBinaryToString(ByVal StrPtr(sCaption), Len(sCaption) * 2, CRYPT_STRING_BASE64 Or CRYPT_STRING_NOCRLF, 0&, lTextLen) Then ' Get the data length required for Base64 encoding
                sBase64Caption = String$(lTextLen - 1, vbNullChar) ' Allocate memory for the new Caption encoded to Base64
                If CryptBinaryToString(ByVal StrPtr(sCaption), Len(sCaption) * 2, CRYPT_STRING_BASE64 Or CRYPT_STRING_NOCRLF, StrPtr(sBase64Caption), lTextLen) Then ' Encode the Unicode Caption to Base64
                    .Caption = vbVerticalTab & sBase64Caption ' A "VerticalTab (ASCII 11)" character is used to mark this label caption as Base64 encoded
                End If
            Else
                .Caption = sCaption ' "CryptBinaryToString" fails for an empty string so just assign it to the label's Caption
            End If
            .Refresh ' Call the refresh method on this label to force a redraw and render the correct Unicode caption
        Else ' Everything else can easily handle Unicode via a simple WM_SETTEXT message
            SubclassWnd .hWnd, Me ' Subclass this hWnd if it hasn't already been subclassed.
            DefWindowProc .hWnd, WM_SETTEXT, 0&, StrPtr(sCaption) ' Set the new caption
            .Refresh ' Force the control to be redrawn to show the new caption immediately
        End If
    End With
    Exit Property
ErrorHandler:
    Err.Clear ' This isn't a valid object or the control doesn't have a hWnd property
End Property

Private Sub HookTextOut()
Dim bytePatch(0 To 5) As Byte, hGDI32Lib As Long
    If lOriginalProcAddress = 0 Then
        hGDI32Lib = LoadLibrary(StrPtr(GDI32_DLL)) ' Load the gdi32.dll library and get its handle
        lOriginalProcAddress = GetProcAddress(hGDI32Lib, TextOutA) ' Get the entry point address of the ANSI TextOutA function from gdi32.dll
        If ReadProcessMemory(GetCurrentProcess, ByVal lOriginalProcAddress, byteOriginalAddress(0), 6, ByVal 0&) Then ' Save it to be restored on exit
            Debug.Print "Saved original TextOutA address"
        End If
        CopyMemory bytePatch(0), &H68, 1 ' push
        CopyMemory bytePatch(1), ProcPtr(AddressOf HookedTextOut), 4 ' Get the address of our replacement HookedTextOut function
        CopyMemory bytePatch(5), &HC3, 1 ' ret
        If WriteProcessMemory(GetCurrentProcess, ByVal lOriginalProcAddress, bytePatch(0), 6, ByVal 0&) Then ' Apply patch, all calls to TextOutA will execute our HookedTextOut function now
            Debug.Print "Hooked TextOutA address"
        End If
    End If
End Sub

Private Sub Class_Terminate()
    If lOriginalProcAddress Then
        If WriteProcessMemory(GetCurrentProcess, ByVal lOriginalProcAddress, byteOriginalAddress(0), 6, ByVal 0&) Then ' Restore the address of the original TextOutA function (only useful in IDE)
            Debug.Print "Restored original TextOutA address"
        End If
    End If
End Sub

Private Function ISubclass_WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
Dim bDiscardMessage As Boolean
    Select Case uMsg
        Case WM_GETTEXT ' Force this message to be processed by the Unicode version of the window procedure (DefWindowProcW) and then discard it
            ISubclass_WndProc = DefWindowProc(hWnd, uMsg, wParam, lParam): bDiscardMessage = True
    End Select
    If Not bDiscardMessage Then ISubclass_WndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
End Function

The "HookedTextOut" function takes care of rendering Unicode captions for the correct labels:

mdlCapW.bas

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const WM_NCDESTROY As Long = &H82, CRYPT_STRING_BASE64 As Long = 1, DT_CALCRECT As Long = &H400, DT_EXTERNALLEADING As Long = &H200, DT_EDITCONTROL As Long = &H2000

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function WideCharToMultiBytePtrs Lib "kernel32" Alias "WideCharToMultiByte" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideCharPtrs Lib "kernel32" Alias "MultiByteToWideChar" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Public Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryA" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, pbBinary As Any, pcbBinary As Long, pdwSkip As Long, pdwFlags As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As Long, ByVal lpStr As Long, ByVal nCount As Long, ByVal lpRect As Long, ByVal wFormat As Long) As Long

Public Function HookedTextOut(ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
Dim byteCaption() As Byte, lTextLen As Long, sCaption As String
    If nCount > 0 Then
        CopyMemory lTextLen, ByVal lpString, 1
        If lTextLen = 11 Then ' A "VerticalTab (ASCII 11)" character is used to mark this label caption as Base64 encoded
            If CryptStringToBinary(lpString + 1, nCount, CRYPT_STRING_BASE64, ByVal 0&, lTextLen, ByVal 0&, ByVal 0&) Then ' Get the data length required for Base64 decoding
                ReDim byteCaption(0 To lTextLen - 1) ' Allocate memory for decoding the Base64 Caption
                If CryptStringToBinary(lpString + 1, nCount, CRYPT_STRING_BASE64, byteCaption(0), lTextLen, ByVal 0&, ByVal 0&) Then ' Decode the Caption from Base64 into a byte array using the ANSI version of "CryptStringToBinary"
                    If InStrB(byteCaption, vbNewLine) Then ' The label caption includes multiple lines of text
                        Dim rcRect As RECT
                        With rcRect: .Left = X: .Top = Y: End With ' Initialize the upper-left corner of the drawing rectangle
                        DrawText hDC, VarPtr(byteCaption(0)), lTextLen \ 2, VarPtr(rcRect), DT_CALCRECT Or DT_EXTERNALLEADING Or DT_EDITCONTROL ' Calculate the height of the rectangle where the label caption is to be drawn
                        HookedTextOut = DrawText(hDC, VarPtr(byteCaption(0)), lTextLen \ 2, VarPtr(rcRect), DT_EXTERNALLEADING Or DT_EDITCONTROL) ' Draw the actual multi-line caption
                    Else
                        HookedTextOut = TextOut(hDC, X, Y, VarPtr(byteCaption(0)), lTextLen \ 2) ' Call the Unicode function TextOutW to perform the actual rendering
                    End If
                End If
            End If
        Else ' This Caption hasn't been encoded to Base64 yet so just convert it from ANSI to Unicode and render it
            ReDim byteCaption(0 To nCount - 1)
            CopyMemory byteCaption(0), ByVal lpString, nCount ' Retrieve the text stored in the label's Caption property
            StrConvW sCaption, byteCaption, vbUnicode ' Convert the byte array to a Unicode string
            HookedTextOut = TextOut(hDC, X, Y, StrPtr(sCaption), nCount) ' Call the Unicode function TextOutW to perform the actual rendering
        End If
    End If
End Function

Public Sub StrConvW(sStringData As String, byteData() As Byte, StrConvType As VbStrConv, Optional lCodePage As Long = 65001) ' CP_Unicode_UTF_8
Dim lDataLen As Long, lLen As Long
    Select Case StrConvType
        Case vbFromUnicode
            lDataLen = WideCharToMultiBytePtrs(lCodePage, 0, StrPtr(sStringData), Len(sStringData), 0, 0, 0, 0)
            ReDim byteData(0 To lDataLen - 1)
            lDataLen = WideCharToMultiBytePtrs(lCodePage, 0, StrPtr(sStringData), Len(sStringData), VarPtr(byteData(0)), lDataLen, 0, 0)
        Case vbUnicode
            lLen = UBound(byteData) - LBound(byteData) + 1
            lDataLen = MultiByteToWideCharPtrs(lCodePage, 0, VarPtr(byteData(0)), lLen, StrPtr(sStringData), 0)
            sStringData = String$(lDataLen, vbNullChar)
            lDataLen = MultiByteToWideCharPtrs(lCodePage, 0, VarPtr(byteData(0)), lLen, StrPtr(sStringData), lDataLen)
        Case vbUpperCase, vbLowerCase, vbProperCase
            sStringData = StrConv(sStringData, StrConvType)
    End Select
End Sub

Public Function ProcPtr(ByVal lAddress As Long) As Long
    ProcPtr = lAddress
End Function

Public Sub SubclassWnd(hWnd As Long, Subclass As ISubclass, Optional dwRefData As Long)
Dim uIdSubclass As Long
    uIdSubclass = ObjPtr(Subclass)
    If Not IsWndSubclassed(hWnd, uIdSubclass) Then
        SetProp hWnd, CStr(hWnd), uIdSubclass: SetWindowSubclass hWnd, AddressOf WndProc, uIdSubclass, dwRefData
    End If
End Sub

Public Sub UnSubclassWnd(hWnd As Long, Optional Subclass As ISubclass)
Dim uIdSubclass As Long
    If Subclass Is Nothing Then
        uIdSubclass = GetProp(hWnd, CStr(hWnd))
    Else
        uIdSubclass = ObjPtr(Subclass)
    End If
    If IsWndSubclassed(hWnd, uIdSubclass) Then
        RemoveProp hWnd, CStr(hWnd): RemoveWindowSubclass hWnd, AddressOf WndProc, uIdSubclass
    End If
End Sub

Public Function IsWndSubclassed(hWnd As Long, uIdSubclass As Long, Optional dwRefData As Long) As Boolean
    IsWndSubclassed = GetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
End Function

Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Subclass As ISubclass, ByVal dwRefData As Long) As Long
    Select Case uMsg
        Case WM_NCDESTROY
            UnSubclassWnd hWnd, Subclass
            WndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
        Case Else
            WndProc = Subclass.WndProc(hWnd, uMsg, wParam, lParam, dwRefData)
    End Select
End Function

That's all there is to it. Here's a small demo program showing the Unicode captions in action (clicking on each element will randomly change its caption from a selection of strings loaded from a file):

UnicodeCaptions.zip (Updated)

[yokesee]

good job

[xiaoyao]

Your work is very great, applaud. Give VB6 life, help it more perfect and easier to use.

[Niya]

the Label control proved to be a little tricky as it doesn't have a hWnd at all.

The Label control belongs to a class of controls called windowless controls. The Image control is another example of a windowless control. They don't have window handles which necessitates the parent handling it's window functionality like drawing and responding to messages. Note that this is a VB6 specific thing and not a Windows thing.

[VanGoghGaming]

Yeah I've already seen that article before, did quite a bit of reading on these troublesome windowless controls. I had to rewrite the hooked function for "TextOutA" (already edited the initial post with the new code) and use Base64 encoded captions for all Unicode text while regular ANSI captions remain unencoded.

[taishan]

...I had to rewrite the hooked function for "TextOutA" (already edited the initial post with the new code) and use a Dictionary object to store Unicode captions based on a key which consists of the label's position (Left and Top coordinates) as well as its container window's hWnd...

Truly excellent work. Actually, it's quite amazing. It's a major reason I was moving to TwinBasic. Users should be able to select their own language file in any program.

I had to quick fix Form_Load()

ReadFile "Haiku.txt", sHaikus

to

ReadFile App.Path & "\Haiku.txt", sHaikus

Maybe update that in the zip.

Thanks for all the time you spent on this!

[VanGoghGaming]

It already looks in the current folder if you start the project by double clicking the .vbp file or compile it into an EXE, no need for "App.Path". I'm glad you like it though, cheers!

[saturnian]

very good job !

[VanGoghGaming]

This update fixes a bug where Label captions encoded to Base64 were not correctly distinguished from regular unencoded ANSI captions.

[VanGoghGaming]

This latest update addresses the problem with Labels containing multiple lines of text and can now draw multi-line Unicode captions as long as the lines are separated by NewLine characters (vbCrLf). The obvious limitation of this approach is that it won't work with the "AutoSize" and "WordWrap" properties of a Label control and all captions will be left-aligned:



As usual you can download this latest update from the first post above.

[Erwin69]

Do I understand correcltly that this is targeted at being able to use Unicode texts with the standard common controls?

Supporting Unicode texts independent from the language your Windows version is running in was the key reason for me to switch to Krool's common controls replacement. It offers a simple option to include the controls by using an OCX, or a "more advanced / flexible way" by including all source code for the controls in your application code. Works like a charm!

Showing a user interface in e.g. Thai, Russian or Korean on an English Windows PC is no problem at all.

[VanGoghGaming]

Yes mate, read the description and download the demo project to see it in action. This works for those standard controls that have a "Caption" property (Form, CommandButton, CheckBox, OptionButton, Frame and Label). It's very lightweight and a lot more convenient than including whole new controls instead of these standard ones.

I also have lightweight Unicode replacements for the InputBox and RichEdit TextBox.

However, if you need more complicated Unicode controls in your applications like the TreeView or FlexGrid then you should browse Krool's Shop!

[Erwin69]

Yes mate, read the description and download the demo project to see it in action. This works for those standard controls that have a "Caption" property (Form, CommandButton, CheckBox, OptionButton, Frame and Label). It's very lightweight and a lot more convenient than including whole new controls instead of these standard ones.

I also have lightweight Unicode replacements for the InputBox and RichEdit TextBox.

However, if you need more complicated Unicode controls in your applications like the TreeView or FlexGrid then you should browse Krool's Shop!

I guess posting messages close to midnight after a busy weekend is not a good thing... Was too quick for my own good, and hit Post before "... instrinsic controls ..." hit the correct brain node, and I realized I was in Code Bank...

As I needed TreeViews, ListViews, FlexGrids and then some more, I indeed started using Krool's set, but your solution looks definitely helpful if those are not needed.

[VanGoghGaming]

Well, there's also the matter of how many external OCX-es you want to distribute along with your application and pollute the users' registry with 20-years old technology, unless absolutely necessary of course!

[Mojoho]

Really nice, but I can't seem to get this working with the LabelPlus control, any ideas how?
https://www.vbforums.com/showthread....3707-LabelPlus

[VanGoghGaming]

This works only for the standard controls mate. Also as far as I see, that LabelPlus control already supports Unicode on its own.

[taishan]

This works only for the standard controls mate. Also as far as I see, that LabelPlus control already supports Unicode on its own.

That's a generous response. You are a true hero. Cheers