vb可以用的Unicode Label控件

imperialeast

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

VERSION 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菌

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

imperialeast

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

imperialeast

imperialeast

YY菌

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

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

imperialeast

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

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

imperialeast

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

imperialeast

想一个list