VB6 UniCaption

I was fooling around with different ways of changing a form's caption to Unicode. I've seen commercial controls that take over the drawing routine with some heavy subclassing and other similar poor attempts, which have then broken, if not when theme changes, then by when Vista got released.

I started off by figuring out a way to create a custom Unicode window and then make an existing form a child of it, but this got pretty messy and I wasn't very happy with the complexity. However, I had a bug during this process that I by mistake used a non-Unicode version of DefWindowProc, which prevented the caption to be Unicode. And it didn't take me long to figure out that by temporarily changing a window's window procedure any window caption can be made Unicode.

So here it is: a very short and clean way to have an Unicode caption in your forms! The following can be pasted directly to your form.

Code:

---

Option Explicit

Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowLongW Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowTextW Lib "user32" (ByVal hWnd As Long, ByVal lpString As Long) As Long

Private Const GWL_WNDPROC = -4

Private m_Caption As String

Public Property Get CaptionW() As String
    CaptionW = m_Caption
End Property
Public Property Let CaptionW(ByRef NewValue As String)
    Static WndProc As Long, VBWndProc As Long
    m_Caption = NewValue
    ' get window procedures if we don't have them
    If WndProc = 0 Then
        ' the default Unicode window procedure
        WndProc = GetProcAddress(GetModuleHandleW(StrPtr("user32")), "DefWindowProcW")
        ' window procedure of this form
        VBWndProc = GetWindowLongA(hWnd, GWL_WNDPROC)
    End If
    ' ensure we got them
    If WndProc <> 0 Then
        ' replace form's window procedure with the default Unicode one
        SetWindowLongW hWnd, GWL_WNDPROC, WndProc
        ' change form's caption
        SetWindowTextW hWnd, StrPtr(m_Caption)
        ' restore the original window procedure
        SetWindowLongA hWnd, GWL_WNDPROC, VBWndProc
    Else
        ' no Unicode for us
        Caption = m_Caption
    End If
End Property

---

And an additional sample:

Code:

---

Private Sub Form_Load()
    ' some hiragana (you need Japanese fonts installed to see them)
    CaptionW = ChrW$(&H3042) & ChrW$(&H3044) & ChrW$(&H3046) & ChrW$(&H3048) & ChrW$(&H304A) & " ovat japanilaisia hiragana-merkkejä."
End Sub

---

This works great on XP and Vista.
On Win2K it changes the caption to Unicode but then it changes back to "???" when you restore the original window procedure (SetWindowLongA). Any ideas for Win2K?

I don't know about Win2k, haven't had the chance to test, but after some feedback over at Planet Source Code here is a different kind of solution:

Code:

---

Option Explicit

Private Declare Function DefWindowProcW Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub PutMem4 Lib "msvbvm60" (Destination As Any, Value As Any)
Private Declare Function SysAllocStringLen Lib "oleaut32" (ByVal OleStr As Long, ByVal bLen As Long) As Long

Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_SETTEXT = &HC

Public Property Get CaptionW() As String
    Dim lngLen As Long, lngPtr As Long
    lngLen = DefWindowProcW(Me.hWnd, WM_GETTEXTLENGTH, 0, ByVal 0)
    If lngLen Then
        lngPtr = SysAllocStringLen(0, lngLen)
        PutMem4 ByVal VarPtr(CaptionW), ByVal lngPtr
        DefWindowProcW Me.hWnd, WM_GETTEXT, lngLen + 1, ByVal lngPtr
    End If
End Property

Public Property Let CaptionW(ByRef NewValue As String)
    DefWindowProcW Me.hWnd, WM_SETTEXT, 0, ByVal StrPtr(NewValue)
End Property

---

So, setting the caption was simplified by a great deal, and getting the caption is done from the window and not from a local variable.

Works great on XP/Vista but still the infamous "???" for TitleBar on Win2K. The good news is that the Unicode does appear correctly in the TaskBar on Win2K.

It probably means the only solution for Windows 2000 is a dirty solution: draw the text yourself.

Owner-draw seems like the only solution for Win2K.
Put your code in Module and updated Get CaptionW to use StrPtr. It appears to work OK on XP and Vista:

Code:

---

Option Explicit

Private Declare Function DefWindowProcW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_SETTEXT = &HC

Public Property Get CaptionW(ByVal hwnd As Long) As String
    Dim lngLen As Long
    lngLen = DefWindowProcW(hwnd, WM_GETTEXTLENGTH, 0, ByVal 0)
    If lngLen Then
        CaptionW = Space$(lngLen)
        DefWindowProcW hwnd, WM_GETTEXT, lngLen + 1, StrPtr(CaptionW)
    End If
End Property

Public Property Let CaptionW(ByVal hwnd As Long, ByVal NewValue As String)
    DefWindowProcW hwnd, WM_SETTEXT, 0, ByVal StrPtr(NewValue)
End Property

---