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: 48
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 string array 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":
cCapW.cls
The "HookedTextOut" function takes care of rendering captions for the correct labels:
mdlCapW.bas
In the Form_Load event we are building our array of Label captions. Since labels can have captions of different lengths, we need to pad each string with null chars to accommodate for the longest caption. Also we need to record the position of each label so that we can identify it in our "HookedTextOut" 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
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 string array 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":
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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
On Error GoTo ErrorHandler
If TypeOf objControl Is Label Then ' Labels are a special case since they don't have a hWnd
CaptionW = Left$(sLabelCaptions(Val(objControl.Tag)).sCaption, InStr(sLabelCaptions(Val(objControl.Tag)).sCaption, vbNullChar) - 1) ' Return the caption text without the trailing null chars padding
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
On Error GoTo ErrorHandler
If TypeOf objControl Is Label Then ' Labels are a special case since they don't have a hWnd
sLabelCaptions(Val(objControl.Tag)).sCaption = sCaption & String$(Len(sLabelCaptions(Val(objControl.Tag)).sCaption) - Len(sCaption), vbNullChar) ' Save the caption in our array of label captions preserving the trailing null chars padding
objControl.Caption = sCaption ' Assign the label's caption property to force a redraw of the control 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 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 Class_Initialize()
Dim bytePatch(0 To 5) As Byte, hGDI32Lib As Long
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 Sub
Private Sub Class_Terminate()
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 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
Private Type tLabelCaption
sCaption As String
lLeft As Long
lTop As Long
End Type
Private Const WM_NCDESTROY = &H82
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
Public sLabelCaptions() As tLabelCaption
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 i As Long
For i = LBound(sLabelCaptions) To UBound(sLabelCaptions) ' Loop through our array of saved label captions and positions
If sLabelCaptions(i).lLeft = X And sLabelCaptions(i).lTop = Y Then ' This is the label we're looking for!
HookedTextOut = TextOut(hDC, X, Y, StrPtr(sLabelCaptions(i).sCaption), nCount) ' Call the Unicode function TextOutW to perform the actual rendering
Exit Function
End If
Next i
End Function
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 FunctionCode:
Private Sub Form_Load()
Dim ctlControl As Control, lLabelIndex As Long
For Each ctlControl In Me.Controls
If TypeOf ctlControl Is Label Then
ReDim Preserve sLabelCaptions(0 To lLabelIndex)
sLabelCaptions(lLabelIndex).sCaption = ctlControl.Caption & String$(MAX_PATH, vbNullChar): ctlControl.Tag = lLabelIndex
sLabelCaptions(lLabelIndex).lLeft = Me.ScaleX(ctlControl.Left, Me.ScaleMode, vbPixels)
sLabelCaptions(lLabelIndex).lTop = Me.ScaleY(ctlControl.Top, Me.ScaleMode, vbPixels)
lLabelIndex = lLabelIndex + 1
End If
Next ctlControl
End SubUnicodeCaptions.zip