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:
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):
![Name: UnicodeCaptionsTest.jpg
Views: 123
Size: 57.7 KB]()
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 "TextOutA" for its Unicode equivalent "TextOutW".
Another problem 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 Labels at once so we needed to identify which caption went to which label. For this purpose we are using a Dictionary of captions for all label controls present on the form and we are selecting the correct one inside our replacement function for the obsolete "TextOutA". The dictionary key is made up from a combination of the label's position (Left and Top coordinates) as well as its container window's hWnd. This way the key is unique even for labels placed at the same position but in different containers (forms, pictureboxes, frames):
cCapW.cls
The "HookedTextOut" function takes care of rendering captions for the correct labels:
mdlCapW.bas
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)
Code:
' For example instead of using:
cmdButton.Caption = "Some ANSI Text"
' Now we can use:
cCapW(cmdButton) = "Fancy Unicode Text"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 "TextOutA" for its Unicode equivalent "TextOutW".
Another problem 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 Labels at once so we needed to identify which caption went to which label. For this purpose we are using a Dictionary of captions for all label controls present on the form and we are selecting the correct one inside our replacement function for the obsolete "TextOutA". The dictionary key is made up from a combination of the label's position (Left and Top coordinates) as well as its container window's hWnd. This way the key is unique even for labels placed at the same position but in different containers (forms, pictureboxes, frames):
cCapW.cls
Code:
Option Explicit
Implements ISubclass
Private Const RDW_INVALIDATE = &H1, RDW_UPDATENOW = &H100, TextOutA As String = "TextOutA", GDI32_DLL As String = "gdi32.dll", WM_SETTEXT = &HC, WM_GETTEXT = &HD, WM_GETTEXTLENGTH = &HE
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 RedrawWindow Lib "user32" (ByVal hWnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw 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 TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As Long, ByVal nCount 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, hWnd As Long, lLeft As Long, lTop As Long, sKey As String
On Error GoTo ErrorHandler
If TypeOf objControl Is Label Then ' Labels are a special case since they don't have a hWnd
If lOriginalProcAddress = 0 Then ApplyPatch ' Hook the "TextOutA" function if it hasn't been done already
lLeft = objControl.Parent.ScaleX(objControl.Left, objControl.Parent.ScaleMode, vbPixels) ' Convert "Left" and "Top" coordinates to pixels
lTop = objControl.Parent.ScaleY(objControl.Top, objControl.Parent.ScaleMode, vbPixels)
sKey = lLeft & lTop & objControl.Container.hWnd
If dictLabelCaptions.Exists(sKey) Then
CaptionW = dictLabelCaptions(sKey) ' Return the label's Unicode caption stored in the dictionary
Else
CaptionW = objControl.Caption ' This label doesn't have an updated caption yet, get the original caption instead
End If
Else ' Everything else can easily handle Unicode via a simple WM_GETTEXT message
hWnd = objControl.hWnd
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
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 hWnd As Long, lLeft As Long, lTop As Long
On Error GoTo ErrorHandler
If TypeOf objControl Is Label Then ' Labels are a special case since they don't have a hWnd
If lOriginalProcAddress = 0 Then ApplyPatch ' Hook the "TextOutA" function if it hasn't been done already
lLeft = objControl.Parent.ScaleX(objControl.Left, objControl.Parent.ScaleMode, vbPixels) ' Convert "Left" and "Top" coordinates to pixels
lTop = objControl.Parent.ScaleY(objControl.Top, objControl.Parent.ScaleMode, vbPixels)
TextOut 0, lLeft, lTop, StrPtr(sCaption), objControl.Container.hWnd ' Call our hooked TextOutA function with a hDC parameter of zero to update the label captions dictionary
objControl.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
hWnd = objControl.hWnd
SubclassWnd hWnd, Me ' Subclass this hWnd if it hasn't been already been subclassed.
DefWindowProc hWnd, WM_SETTEXT, 0&, StrPtr(sCaption) ' Set the new caption
RedrawWindow hWnd, 0, 0, RDW_INVALIDATE Or RDW_UPDATENOW ' Force the control to be redrawn to show the new caption immediately
End If
Exit Property
ErrorHandler:
Err.Clear ' This isn't a valid object or the control doesn't have a hWnd property
End Property
Private Sub ApplyPatch()
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
AsByte(bytePatch(0)) = &H68 ' push
AsLong(bytePatch(1)) = ProcPtr(AddressOf HookedTextOut) ' Get the address of our replacement HookedTextOut function
AsByte(bytePatch(5)) = &HC3 ' 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 FunctionmdlCapW.bas
Code:
Option Explicit
Public Enum eCodePageIds
CP_Autodetect_All = 50001
CP_Unicode_UTF_16_LE = 1200
CP_Unicode_UTF_8 = 65001
CP_Windows_1250_ANSI_Central_European_Latin_2 = 1250
CP_Windows_1251_ANSI_Cyrillic = 1251
CP_Windows_1252_ANSI_Western_European_Latin_1 = 1252
CP_Windows_1253_ANSI_Greek = 1253
CP_Windows_1254_ANSI_Turkish = 1254
CP_Windows_1255_ANSI_Hebrew = 1255
CP_Windows_1256_ANSI_Arabic = 1256
CP_Windows_1257_ANSI_Baltic = 1257
CP_Windows_1258_ANSI_Vietnamese = 1258
End Enum
Private Const WM_NCDESTROY = &H82
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 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 WindowFromDC Lib "user32" (ByVal hDC As Long) As Long
Public dictLabelCaptions As New Dictionary
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, sCaption As String, sKey As String, hWndFromDC As Long
If hDC Then ' hDC parameter is not zero, this is where the system is calling TextOut to do the actual drawing
hWndFromDC = WindowFromDC(hDC): sKey = X & Y & hWndFromDC ' The "Left" and "Top" coordinates of each label as well as its container's hWnd make up the dictionary key
If dictLabelCaptions.Exists(sKey) Then ' This key is found in the dictionary, meaning this label has an updated caption
HookedTextOut = TextOut(hDC, X, Y, StrPtr(dictLabelCaptions(sKey)), Len(dictLabelCaptions(sKey))) ' Call the Unicode function TextOutW to perform the actual rendering
Else ' This key is not found in the dictionary so we render the original caption on this label after converting it from ANSI to Unicode:
ReDim byteCaption(0 To nCount - 1)
CopyMemory byteCaption(0), ByVal lpString, nCount
StrConvW sCaption, byteCaption, vbUnicode ' Convert the byte array to a Unicode string
HookedTextOut = TextOut(hDC, X, Y, StrPtr(sCaption), nCount)
End If
Else ' We are calling this function with a hDC parameter of zero in order to update our dictionary of label captions
sKey = X & Y & nCount ' The "Left" and "Top" coordinates of each label as well as its container's hWnd make up the dictionary key
If dictLabelCaptions.Exists(sKey) Then
dictLabelCaptions(sKey) = AsString(lpString) ' Key exists, update this label's caption with the new value
Else
dictLabelCaptions.Add sKey, AsString(lpString) ' Key is not found, add it to the dictionary
End If
End If
End Function
Public Sub StrConvW(sStringData As String, byteData() As Byte, StrConvType As VbStrConv, Optional eCodePage As eCodePageIds = CP_Unicode_UTF_8)
Dim lDataLen As Long
Select Case StrConvType
Case vbFromUnicode
lDataLen = WideCharToMultiBytePtrs(eCodePage, 0, StrPtr(sStringData), Len(sStringData), 0, 0, 0, 0)
ReDim byteData(0 To lDataLen - 1)
lDataLen = WideCharToMultiBytePtrs(eCodePage, 0, StrPtr(sStringData), Len(sStringData), VarPtr(byteData(0)), lDataLen, 0, 0)
Case vbUnicode
lDataLen = MultiByteToWideCharPtrs(eCodePage, 0, VarPtr(byteData(0)), UBound(byteData) - LBound(byteData) + 1, StrPtr(sStringData), 0)
sStringData = String$(lDataLen, vbNullChar)
lDataLen = MultiByteToWideCharPtrs(eCodePage, 0, VarPtr(byteData(0)), UBound(byteData) - LBound(byteData) + 1, 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 FunctionUnicodeCaptions.zip (Updated)