Z
Zoo
Hi ,all.
I can display Uniocode Text on UserForm1.Label1.Caption ,
but cannot UserForm1.Caption ?
e.g.
s = ChrW(&H7535) & ChrW(&H8BDD) & ChrW(0)
Me.Controls("Label1").Caption = s '<- This works correctly.
Me.Caption = s '<= This doesn't work. Caption becomes
two question marks.
Does anybody know how to work around this?
I tried to work around this with the followings by myself, but failed.
'----------------------------------------------------
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function BeginPaint Lib "user32.dll" _
(ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function TextOut Lib "gdi32.dll" Alias "TextOutW" _
(ByVal hDC As Long, ByVal nXStart As Long, ByVal nYStart As Long, _
ByVal lpString As Long, ByVal cbString As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function EndPaint Lib "user32.dll" _
(ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Type PAINTSTRUCT
hDC As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved As Byte
End Type
Private Sub UserForm_Activate()
Dim hWnd As Long
On Error Resume Next
Dim sName As String
sName = Me.Controls("Label1").Name
If Err Then
Me.Controls.Add "Forms.Label.1", "Label1", True
End If
On Error GoTo 0
Dim s As String
s = ChrW(&H7535) & ChrW(&H8BDD) & ChrW(0)
Me.Controls("Label1").Caption = s '<- This works correctly.
Me.Caption = s '<= This doesn't work. Caption becomes
two question marks.
'To display Unicode Text on Me.caption, I wrote the followings.
'But they does not work fine.
hWnd = FindWindow(vbNullString, Me.Caption)
Dim hDC As Long
Dim ps As PAINTSTRUCT
hDC = BeginPaint(hWnd, ps)
Dim fnt As Long
Dim lgFont As LOGFONT
With lgFont
.lfFaceName = "NSimSun" & Chr(0)
.lfCharSet = 136
End With
fnt = CreateFontIndirect(lgFont)
Dim fntOrig As Long
fntOrig = SelectObject(hDC, fnt)
TextOut hDC, 0, 0, StrPtr(s), LenB(s) - 2
SelectObject hDC, fntOrig
DeleteObject fnt
EndPaint hDC, ps
End Sub
I can display Uniocode Text on UserForm1.Label1.Caption ,
but cannot UserForm1.Caption ?
e.g.
s = ChrW(&H7535) & ChrW(&H8BDD) & ChrW(0)
Me.Controls("Label1").Caption = s '<- This works correctly.
Me.Caption = s '<= This doesn't work. Caption becomes
two question marks.
Does anybody know how to work around this?
I tried to work around this with the followings by myself, but failed.
'----------------------------------------------------
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function BeginPaint Lib "user32.dll" _
(ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function TextOut Lib "gdi32.dll" Alias "TextOutW" _
(ByVal hDC As Long, ByVal nXStart As Long, ByVal nYStart As Long, _
ByVal lpString As Long, ByVal cbString As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function EndPaint Lib "user32.dll" _
(ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Type PAINTSTRUCT
hDC As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved As Byte
End Type
Private Sub UserForm_Activate()
Dim hWnd As Long
On Error Resume Next
Dim sName As String
sName = Me.Controls("Label1").Name
If Err Then
Me.Controls.Add "Forms.Label.1", "Label1", True
End If
On Error GoTo 0
Dim s As String
s = ChrW(&H7535) & ChrW(&H8BDD) & ChrW(0)
Me.Controls("Label1").Caption = s '<- This works correctly.
Me.Caption = s '<= This doesn't work. Caption becomes
two question marks.
'To display Unicode Text on Me.caption, I wrote the followings.
'But they does not work fine.
hWnd = FindWindow(vbNullString, Me.Caption)
Dim hDC As Long
Dim ps As PAINTSTRUCT
hDC = BeginPaint(hWnd, ps)
Dim fnt As Long
Dim lgFont As LOGFONT
With lgFont
.lfFaceName = "NSimSun" & Chr(0)
.lfCharSet = 136
End With
fnt = CreateFontIndirect(lgFont)
Dim fntOrig As Long
fntOrig = SelectObject(hDC, fnt)
TextOut hDC, 0, 0, StrPtr(s), LenB(s) - 2
SelectObject hDC, fntOrig
DeleteObject fnt
EndPaint hDC, ps
End Sub