VB实现长标题文本压缩

Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'将文本描绘到指定的矩形中
Private Declare Function DrawText Lib “user32” Alias “DrawTextA” (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_LEFT = &H0
Private Const DT_VCENTER = &H4
Private Const DT_VERTICAL = (DT_SINGLELINE Or DT_LEFT Or DT_VCENTER) '垂直居中左对齐
Dim TxtRect As RECT

'返回文本函数(文本,矩形,显示位置格式)
Private Function DrawTextEx(ByVal hDC As Long, ByVal Text As String, BoxRect As RECT, ByVal DisFormat As Long) As Long
Dim TpyRect As RECT, RectWidth As Long, TetxWidth As Long, TetxLen As Long
TpyRect = BoxRect
RectWidth = BoxRect.Right - BoxRect.Left
If TextWidth(Text) > RectWidth Then
TetxLen = Len(Text)
Do While TetxLen > 0
TetxWidth = TextWidth(Left$(Text,TetxLen))IfTetxWidth<=RectWidth-TextWidth("...")ThenExitDoTetxLen=TetxLen-1Loo{p}^{\prime }显示删减后的前段文本TpyRect.Left=BoxRect.LeftTpyRect.Right=BoxRect.Left+TetxWidthDrawTextEx=DrawText(hDC,Left$(Text, TetxLen), -1, TpyRect, DisFormat)
'在删减文本后添加"…"
TpyRect.Left = BoxRect.Left + TetxWidth
TpyRect.Right = BoxRect.Left + RectWidth
DrawTextEx = DrawText(hDC, “…”, -1, TpyRect, DisFormat)
Else
'当文本宽度<矩形时显示完整文本
DrawTextEx = DrawText(hDC, Text, -1, TpyRect, DisFormat)
End If
End Function

Private Sub Form_Load()
Me.AutoRedraw = True: Me.ScaleMode = vbPixels
End Sub

Private Sub Form_Resize()
TxtRect.Left = Me.ScaleLeft
TxtRect.Top = Me.ScaleTop
TxtRect.Right = Me.ScaleWidth
TxtRect.Bottom = Me.ScaleHeight
Me.Cls
Call DrawTextEx(Me.hDC, “这里就是要在窗口或其他控件对象上显示的文本”, TxtRect, DT_VERTICAL)
End Sub