vb可以用的Unicode Label控件

imperialeast 发表于 2025-10-23 19:25:31

本帖最后由 imperialeast 于 2025-10-25 14:56 编辑

https://www.0xaa55.com/data/attachment/album/202510/24/214215d0fvgts3h0vz3bps.jpg

VERSION 5.00
Begin VB.UserControl UnicodeLabel
BackColor    = &H00FFFFFF&
ClientHeight = 450
ClientLeft    = 0
ClientTop    = 0
ClientWidth = 915
FontTransparent = 0 'False
ScaleHeight = 450
ScaleWidth    = 915
End
Attribute VB_Name = "UnicodeLabel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Private Const WS_EX_CLIENTEDGE As Long = &H200
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_BORDER As Long = &H800000
Private Const WS_VSCROLL As Long = &H200000
Private Const WS_HSCROLL As Long = &H100000
Private Const LABS_VCENTER As Long = &H200'垂直居中
Private Const LABS_HCENTER As Long = &H1 '水平居中

Private Const Transparent = 1
Private Const ES_WANTRETURN As Long = &H1000
Private Const ES_MULTILINE = &H4
Private Const WM_SETTEXT As Long = &HC
Private Const TEXT_LEFT As Long = &H10
Private Const TEXT_CENTER As Long = &H6
Private Const TEXT_RIGHT As Long = &H2
Private Const WM_SETTEXTALIGN As Long = &H111

Private Const WM_SETFONT As Long = &H30
Private Const WM_GETTEXT As Long = &HD
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const SYSTEM_FIXED_FONT As Long = 16
Private Const DEFAULT_GUI_FONT As Long = 17

Private Const FW_BOLD = 70 ' 加粗权重
Private Const DEFAULT_CHARSET = 1 ' 默认字符集（适配中文）

Private Type LOGFONTW ' 宽字符版字体结构
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 * 64 ' 宽字符：32个字符×2字节=64，避免截断
End Type

Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirectW Lib "gdi32.dll" (lpLogFont As LOGFONTW) As Long ' 宽字符版本
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Const LOGPIXELSY = 90 ' 垂直DPI

Private Const IID_IFont = "{0BE35203-8F91-11CE-9DE3-00AA004BB851}"

Private Declare Function MessageBoxW Lib "user32.dll" (ByVal hWnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal wType As Long) As Long
Private Declare Function SendMessageW Lib "user32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CreateWindowExW Lib "user32" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByVal lpParam As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function DefWindowProcW Lib "user32.dll" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetFocusW Lib "user32.dll" Alias "SetFocus" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hDC As Long, ByVal nBKMode As Long) As Long

Private m_hWnd As Long
Private m_Text As String
Private m_Align As Integer

Public Function MsgBoxW(Optional ByVal hWnd As Long = 0, Optional ByVal lpText As String = "", Optional ByVal lpCaption As String = "", Optional ByVal wType As Long = 0) As Long
MsgBoxW = MessageBoxW(hWnd, StrPtr(lpText), StrPtr(lpCaption), wType)
End Function

Private Function CreateUnicodeLabel(ByVal hOwnerWnd As Long, ByVal nStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal W As Long, ByVal H As Long, Optional dwFondType As Long = DEFAULT_GUI_FONT) As Long
CreateUnicodeLabel = CreateWindowExW(0, StrPtr("Static"), StrPtr(m_Text), nStyle, X, Y, W, H, hOwnerWnd, 0, App.hInstance, 0)
SendMessageW CreateUnicodeLabel, WM_SETFONT, GetStockObject(dwFondType), 1
End Function

Private Sub SetUnicodeTextToCtrl(ByVal hWnd As Long, ByVal sz As String)
SendMessageW hWnd, WM_SETTEXT, 0, StrPtr(sz)
End Sub

Private Function GetUnicodeTextFromCtrl(ByVal hWnd As Long) As String
Dim tl As Long
Dim ba() As Byte
tl = SendMessageW(hWnd, WM_GETTEXTLENGTH, 0, 0)
If tl <> 0 Then
   tl = tl + 1
   ReDim ba(tl * 2)
   If SendMessageW(hWnd, WM_GETTEXT, tl, VarPtr(ba(0))) > 0 Then
      GetUnicodeTextFromCtrl = ba
   End If
End If
End Function

'【Unicode Label 控件】

'看了网上技术宅们的文章，写了这控件，希望对大家有用
'TextAlign 0 左对齐 1是水平居中 2是垂直居中 3 是水平垂直均居中

Private Sub UserControl_Initialize()
Select Case m_Align
      Case 0
         '左对齐
            m_hWnd = CreateUnicodeLabel(UserControl.hWnd, WS_CHILD Or WS_VISIBLE, 0, 0, 0, 0)
      Case 1
            m_hWnd = CreateUnicodeLabel(UserControl.hWnd, WS_CHILD Or WS_VISIBLE Or LABS_HCENTER, 0, 0, 0, 0)
      Case 2
            m_hWnd = CreateUnicodeLabel(UserControl.hWnd, WS_CHILD Or WS_VISIBLE Or LABS_VCENTER, 0, 0, 0, 0)
      Case 3
            m_hWnd = CreateUnicodeLabel(UserControl.hWnd, WS_CHILD Or WS_VISIBLE Or LABS_VCENTER Or LABS_HCENTER, 0, 0, 0, 0)
End Select

UserControl_Resize
End Sub

Private Sub UserControl_Resize()
MoveWindow m_hWnd, 0, 0, UserControl.Width / Screen.TwipsPerPixelX, UserControl.Height / Screen.TwipsPerPixelY, 1
End Sub

Private Sub UserControl_Terminate()
DestroyWindow m_hWnd
End Sub

Private Sub UserControl_GotFocus()
SetFocusW m_hWnd
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Caption = PropBag.ReadProperty("Caption", m_Text)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "Caption", Caption
End Sub

Public Property Get hWnd() As Long
Attribute hWnd.VB_Description = "Get the HWND of the control."
hWnd = m_hWnd
End Property

Public Property Get hDC() As Long
hDC = GetDC(m_hWnd)
End Property

Public Property Let BackColor(ByVal newColor As Long)
UserControl.BackColor = newColor
PropertyChanged "BackColor"
End Property

Public Property Get BackColor() As Long
BackColor = UserControl.BackColor
End Property

Public Property Let ForeColor(ByVal newColor As Long)
' SendMessageW hDC, &H6, newColor, 0
UserControl.ForeColor = newColor
PropertyChanged "ForeColor"
End Property

Public Property Get ForeColor() As Long
ForeColor = UserControl.ForeColor
End Property

'TextAlign 0 左对齐，1是水平居中 2是垂直居中 3是水平垂直均居中
Public Property Let TextAlign(ByVal newAlign As Integer)
Dim NewStyle As Long
m_Align = newAlign
Call UserControl_Initialize
PropertyChanged "TextAlign"
End Property

Public Property Get TextAlign() As Integer
TextAlign = m_Align
End Property

Public Property Get Visible() As Integer
Visible = UserControl.BackStyle
End Property

Public Property Let Visible(ByVal NewStyle As Integer)
UserControl.BackStyle = NewStyle
PropertyChanged "BackStyle"
End Property

Public Property Get Caption() As String
Attribute Caption.VB_Description = "Get / Set the text of the control."
m_Text = Replace$(GetUnicodeTextFromCtrl(m_hWnd), vbNullChar, "")
Caption = m_Text
End Property

Public Property Let Caption(ByVal NewStr As String)
m_Text = NewStr
SetUnicodeTextToCtrl m_hWnd, m_Text
PropertyChanged "Caption"
End Property

Public Property Get Font() As Font
Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal NewFont As StdFont)
Dim hFont As Long, lgfntW As LOGFONTW, iid(0 To 3) As Long
With lgfntW
   .lfFaceName = StrConv(NewFont.Name & vbNullChar, vbUnicode)
   .lfHeight = -MulDiv(NewFont.Size, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72)
   .lfWeight = IIf(NewFont.Bold, FW_BOLD, 400)
   .lfCharSet = DEFAULT_CHARSET
End With
hFont = CreateFontIndirectW(lgfntW)
If hFont <> 0 Then
      SendMessageW m_hWnd, WM_SETFONT, hFont, 1
End If
Set UserControl.Font = NewFont
PropertyChanged "Font"
End Property

imperialeast 发表于 2025-10-23 19:26:53

本帖最后由 imperialeast 于 2025-10-25 14:55 编辑

https://www.0xaa55.com/data/attachment/album/202510/24/214215d0fvgts3h0vz3bps.jpgVERSION 5.00
Begin VB.Form Form1
Caption       = "Form1"
ClientHeight = 3015
ClientLeft    = 120
ClientTop    = 465
ClientWidth = 4560
LinkTopic    = "Form1"
ScaleHeight = 3015
ScaleWidth    = 4560
StartUpPosition = 3'窗口缺省
Begin 工程1.UnicodeLabel UnicodeLabel1
   Height       = 855
   Left          = 480
   TabIndex    = 0
   Top          = 1560
   Width       = 3135
   _ExtentX    = 6588
   _ExtentY    = 2143
   Caption       = "xfvdfvdfgv"
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Load()
'TextAlign 这个一定放在首位
UnicodeLabel1.TextAlign = 0

Dim j As New StdFont
j.Name = "黑体"
j.Size = 16
Set UnicodeLabel1.Font = j
UnicodeLabel1.BackColor = vbGreen
UnicodeLabel1.Caption = "Die Liebe ist s" & ChrW(252) & ChrW(223) & "!"
UnicodeLabel1.ForeColor = vbBlue
UnicodeLabel1.Visible = True
'UnicodeLabel1.TextAlign
End Sub

YY菌 发表于 2025-10-24 16:08:44

1.不推荐在Initialize（构造阶段）访问hWnd，这将会导致控件提前被加载。建议将和hWnd相关的操作都延迟到InitProperties和ReadProperties事件中。
2.VB6原版的Label控件是无窗的，可以考虑把UserControl的Windowless设为True，让它也成为一个无窗控件，显示的文本用DrawTextW在Paint事件中画出来就可以了，这样做出来的效果跟VB6原版Label会更接近。

imperialeast 发表于 2025-10-24 21:41:24

这个没有窗口啊，就是有背景不能透明，但是关键是实现世界语言，能显示中文以外的内容

imperialeast 发表于 2025-10-24 21:43:20

https://www.0xaa55.com/home.php?mod=space&uid=9377&do=album&picid=6886

imperialeast 发表于 7 天前

https://www.0xaa55.com/static/image/common/emp.gif

YY菌 发表于 4 天前

imperialeast 发表于 2025-10-24 21:41
这个没有窗口啊，就是有背景不能透明，但是关键是实现世界语言，能显示中文以外的内容 ...

你都CreateWindowExW了还跟我说没有窗口？搞笑呢？CreateWindowExW的你还传了UserControl.hWnd作为父窗口，这一个控件整个两个窗口，还说没有窗口？

imperialeast 发表于 4 天前

YY菌发表于 2025-10-28 10:05
你都CreateWindowExW了还跟我说没有窗口？搞笑呢？CreateWindowExW的你还传了UserControl.hWnd作为父窗口 ...

我以为什么窗口呢，这个子窗口才是控件的核心啊

imperialeast 发表于 4 天前

https://www.0xaa55.com/home.php?mod=follow
这个就是你要的，我简单的写了简化版的

页: [1]

技术宅的结界's Archiver

vb可以用的Unicode Label控件