再談用VB無窗口透明Usercontrol編寫透明浮動按鈕

    去年曾寫過一篇博文，名稱叫《用VB無窗口透明Usercontrol編寫透明浮動按鈕》，該文有一個觀點是錯誤的，即透明無窗口Usercontrol不支持設計時點選。其實，通過在UserControl_HitTest過程里加入HitResult = vbHitResultHit語句，就可以實現設計時的點選了，爲此，修改代碼如下：

'* ************************************************************** * '* 程序名稱：Button.ctl '* 程序功能：透明浮動按扭 '* 作者：lyserver，最後修改日期：2009年11月 '* 聯繫方式：http://blog.csdn.net/lyserver '* ************************************************************** * Option Explicit '---------------------------------------------------------------------- ' API 聲明 '---------------------------------------------------------------------- Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function SetRect Lib "user32" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function OffsetRect Lib "user32" (ByRef lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, ByRef qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long Private Const BDR_RAISED = &H5 Private Const BDR_SUNKEN = &HA Private Const BDR_RAISEDINNER = &H4 Private Const BDR_SUNKENINNER = &H8 Private Const BDR_RAISEDOUTER = &H1 Private Const BDR_SUNKENOUTER = &H2 Private Const BF_RECT = &HF Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long Private Const DT_CENTER = &H1 Private Const DT_VCENTER = &H4 Private Const DT_TOP = &H0 Private Const DT_BOTTOM = &H8 Private Const DT_LEFT = &H0 Private Const DT_RIGHT = &H2 Private Const DT_SINGLELINE = &H20 Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long Private Declare Function LoadCursorBynum& Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) Private Const IDC_HAND = 32649& Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long '---------------------------------------------------------------------- ' 公共枚舉類型 '---------------------------------------------------------------------- Public Enum TextAlignConstants [Top] = DT_TOP Or DT_CENTER Or DT_SINGLELINE [Bottom] = DT_BOTTOM Or DT_CENTER Or DT_SINGLELINE [Left] = DT_LEFT Or DT_VCENTER Or DT_SINGLELINE [Right] = DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE [Center] = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE End Enum '---------------------------------------------------------------------- ' 事件聲明 '---------------------------------------------------------------------- Public Event Click() '---------------------------------------------------------------------- ' 屬性變量聲明 '---------------------------------------------------------------------- Dim m_blnAutoSize As Boolean Dim m_strCaption As String Dim m_objHoverPicture As StdPicture Dim m_lngPadding As Long Dim m_objPicture As StdPicture Dim m_lngTextAlign As TextAlignConstants '---------------------------------------------------------------------- ' 模塊公共變量聲明 '---------------------------------------------------------------------- Dim m_rcDraw As RECT '控件位置及大小(像素單位) Dim WithEvents tm As Timer Dim m_dblScale As Long ' '---------------------------------------------------------------------- ' 函數名稱：UserControl_Initialize ' 函數說明：初始化控件 '---------------------------------------------------------------------- Private Sub UserControl_Initialize() 'Windowless = True '設計時設置該屬性 BackStyle = 0 '設置控件背景透明 ScaleMode = vbPixels '設置控件縮放模式爲像素 ClipBehavior = 0 '設置控件剪切方式爲無(即全部) Set tm = Controls.Add("VB.Timer", "tm") '加載定時器 tm.Enabled = False tm.Interval = 50 '設置定時器間隔爲50毫秒 m_strCaption = "透明浮動按鈕" m_lngTextAlign = [Bottom] End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_Terminate ' 函數說明：控件被銷燬 '---------------------------------------------------------------------- Private Sub UserControl_Terminate() tm.Enabled = False '關閉定時器 Controls.Remove "tm" '刪除定時器 End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_Resize ' 函數說明：調整控件大小 '---------------------------------------------------------------------- Private Sub UserControl_Resize() If UserControl.ScaleWidth > 0 Then m_dblScale = Extender.Width / UserControl.ScaleWidth SetRect m_rcDraw, 0, 0, ScaleWidth, ScaleHeight OffsetRect m_rcDraw, Extender.Left / m_dblScale, Extender.Top / m_dblScale End If End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_ReadProperties ' 函數說明：讀取控件屬性 '---------------------------------------------------------------------- Private Sub UserControl_ReadProperties(PropBag As PropertyBag) m_blnAutoSize = PropBag.ReadProperty("AutoSize", False) m_strCaption = PropBag.ReadProperty("Caption", "透明浮動按鈕") Set m_objHoverPicture = PropBag.ReadProperty("HoverPicture", Nothing) UserControl.Enabled = PropBag.ReadProperty("Enabled", True) m_lngPadding = PropBag.ReadProperty("Padding", 0) Set m_objPicture = PropBag.ReadProperty("Picture", Nothing) m_lngTextAlign = PropBag.ReadProperty("TextAlign", DT_BOTTOM Or DT_CENTER Or DT_SINGLELINE) Call ResizeMe End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_WriteProperties ' 函數說明：保存控件屬性 '---------------------------------------------------------------------- Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("AutoSize", m_blnAutoSize, False) Call PropBag.WriteProperty("Caption", m_strCaption, "透明浮動按鈕") Call PropBag.WriteProperty("HoverPicture", m_objHoverPicture, Nothing) Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True) Call PropBag.WriteProperty("Padding", m_lngPadding, 0) Call PropBag.WriteProperty("Picture", m_objPicture, Nothing) Call PropBag.WriteProperty("TextAlign", m_lngTextAlign, DT_BOTTOM Or DT_CENTER Or DT_SINGLELINE) End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_HitTest ' 函數說明：檢測鼠標移動和進入事件 '---------------------------------------------------------------------- Private Sub UserControl_HitTest(x As Single, y As Single, HitResult As Integer) Static hCursor As Long If Not Ambient.UserMode Then '處理設計時點選問題 HitResult = vbHitResultHit 'UserControl.Refresh Else '處理運行時鼠標進入事件 If HitResult = vbHitResultOutside Then HitResult = vbHitResultHit If UserControl.Enabled Then If hCursor = 0 Then hCursor = LoadCursorBynum&(0&, IDC_HAND) SetCursor hCursor '設置鼠標形狀爲手型 If Not tm.Enabled Then '鼠標進入事件 Dim hParentDC As Long hParentDC = GetDC(ContainerHwnd) If Not m_objHoverPicture Is Nothing Then DrawPicture hParentDC, m_rcDraw, m_objHoverPicture DrawEdge hParentDC, m_rcDraw, BDR_RAISEDINNER, BF_RECT '繪製浮起邊框 ReleaseDC ContainerHwnd, hParentDC tm.Enabled = True End If End If End If End If End Sub '---------------------------------------------------------------------- ' 函數名稱：tm_Timer ' 函數說明：定時檢測鼠標移出事件 '---------------------------------------------------------------------- Private Sub tm_Timer() Dim pt As POINTAPI GetCursorPos pt ScreenToClient ContainerHwnd, pt If pt.x < m_rcDraw.Left Or pt.y < m_rcDraw.Top Or pt.x > m_rcDraw.Right Or pt.y > m_rcDraw.Bottom Then tm.Enabled = False Refresh DoEvents End If End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_MouseDown ' 函數說明：鼠標按鍵事件 '---------------------------------------------------------------------- Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 1 Then Dim hParentDC As Long hParentDC = GetDC(ContainerHwnd) DrawEdge hParentDC, m_rcDraw, BDR_SUNKENOUTER, BF_RECT ReleaseDC ContainerHwnd, hParentDC End If End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_DblClick ' 函數說明：鼠標雙擊事件，視作鼠標按鍵事件 '---------------------------------------------------------------------- Private Sub UserControl_DblClick() Call UserControl_MouseDown(1, 0, 1, 1) End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_DblClick ' 函數說明：鼠標鬆鍵事件，在此激發單擊事件 '---------------------------------------------------------------------- Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 1 And tm.Enabled Then Dim hParentDC As Long hParentDC = GetDC(ContainerHwnd) DrawEdge hParentDC, m_rcDraw, BDR_RAISEDINNER, BF_RECT ReleaseDC ContainerHwnd, hParentDC If tm.Enabled Then RaiseEvent Click '激發單擊事件 End If End Sub '---------------------------------------------------------------------- ' 函數名稱：UserControl_Paint ' 函數說明：繪製控件 '---------------------------------------------------------------------- Private Sub UserControl_Paint() Dim rcDraw As RECT SetRect rcDraw, 0, 0, ScaleWidth, ScaleHeight DrawPicture hdc, rcDraw, m_objPicture End Sub '---------------------------------------------------------------------- ' 函數名稱：AutoSize ' 函數說明：當Caption屬性爲空而圖片不爲空時，控件大小自動調整爲圖片大小 '---------------------------------------------------------------------- Public Property Get AutoSize() As Boolean AutoSize = m_blnAutoSize End Property Public Property Let AutoSize(ByVal New_Value As Boolean) m_blnAutoSize = New_Value PropertyChanged "AutoSize" Call ResizeMe End Property '---------------------------------------------------------------------- ' 函數名稱：Caption ' 函數說明：讀取和設置Caption屬性 '---------------------------------------------------------------------- Public Property Get Caption() As String Caption = m_strCaption End Property Public Property Let Caption(ByVal New_Caption As String) m_strCaption = New_Caption PropertyChanged "Caption" Call ResizeMe UserControl.Refresh '屬性改變時重繪控件 End Property '---------------------------------------------------------------------- ' 屬性名稱：HoverPicture ' 屬性說明：讀取和設置鼠標懸停時的圖片 '---------------------------------------------------------------------- Public Property Get HoverPicture() As StdPicture Set HoverPicture = m_objHoverPicture End Property Public Property Set HoverPicture(ByRef New_Value As StdPicture) Set m_objHoverPicture = New_Value End Property '---------------------------------------------------------------------- ' 屬性名稱：Enabled ' 屬性說明：讀取和設置Enabled屬性 '---------------------------------------------------------------------- Public Property Get Enabled() As Boolean Enabled = UserControl.Enabled End Property Public Property Let Enabled(ByVal New_Value As Boolean) UserControl.Enabled = New_Value PropertyChanged "Enabled" End Property '---------------------------------------------------------------------- ' 屬性名稱：TextAlign ' 屬性說明：讀取和設置文本對齊方式 '---------------------------------------------------------------------- Public Property Get TextAlign() As TextAlignConstants TextAlign = m_lngTextAlign End Property Public Property Let TextAlign(ByVal New_TextAlign As TextAlignConstants) m_lngTextAlign = New_TextAlign PropertyChanged "TextAlign" Refresh '屬性改變時重繪控件 End Property '---------------------------------------------------------------------- ' 屬性名稱：Padding ' 屬性說明：讀取和設置內部填充像素 '---------------------------------------------------------------------- Public Property Get Padding() As Long Padding = m_lngPadding End Property Public Property Let Padding(ByVal New_Value As Long) m_lngPadding = New_Value PropertyChanged "Padding" Call ResizeMe End Property '---------------------------------------------------------------------- ' 函數名稱：Picture ' 函數說明：讀取和設置Picture屬性 '---------------------------------------------------------------------- Public Property Get Picture() As StdPicture Set Picture = m_objPicture End Property Public Property Set Picture(ByVal New_Picture As StdPicture) Set m_objPicture = New_Picture PropertyChanged "Picture" Call ResizeMe Refresh '屬性改變時重繪控件 End Property '---------------------------------------------------------------------- ' 函數名稱：DrawPicture ' 函數說明：在指定位置和大小的矩形內繪製圖片 '---------------------------------------------------------------------- Private Sub DrawPicture(ByRef hParentDC As Long, ByRef rcDraw As RECT, ByRef objPicture As StdPicture) Dim rcWidth As Long Dim rcHeight As Long Dim bmLeft As Long Dim bmTop As Long Dim bmWidth As Long Dim bmHeight As Long 'UserControl.Cls If Not objPicture Is Nothing Then rcWidth = rcDraw.Right - rcDraw.Left rcHeight = rcDraw.Bottom - rcDraw.Top bmWidth = ScaleX(objPicture.Width, vbHimetric, vbPixels) bmHeight = ScaleY(objPicture.Height, vbHimetric, vbPixels) Select Case m_lngTextAlign Case [Top] '文字居上圖像居下 bmLeft = rcDraw.Left + (rcWidth - bmWidth) / 2 bmTop = rcDraw.Top + (rcHeight - bmHeight - ScaleY(TextHeight(m_strCaption), vbPixels, ScaleMode)) Case [Bottom] '文字居下圖像居上 bmLeft = rcDraw.Left + (rcWidth - bmWidth) / 2 bmTop = rcDraw.Top Case [Left] '文字居左圖像居右 bmLeft = rcDraw.Left + (rcWidth - bmWidth - ScaleX(TextWidth(m_strCaption), vbPixels, ScaleMode)) bmTop = rcDraw.Top + (rcHeight - bmHeight) / 2 Case [Right] '文字居右圖像居左 bmLeft = rcDraw.Left bmTop = rcDraw.Top + (rcHeight - bmHeight) / 2 Case Else '文字和圖像均居中 bmLeft = rcDraw.Left + (rcWidth - bmWidth) / 2 bmTop = rcDraw.Top + (rcHeight - bmHeight) / 2 End Select objPicture.Render CLng(hParentDC), CLng(bmLeft), CLng(bmTop), CLng(bmWidth), CLng(bmHeight), _ 0, objPicture.Height, objPicture.Width, -objPicture.Height, ByVal 0& End If DrawText hParentDC, m_strCaption, LenB(StrConv(m_strCaption, vbFromUnicode)), rcDraw, m_lngTextAlign End Sub Private Sub ResizeMe() Dim w As Long, h As Long If m_blnAutoSize And Len(m_strCaption) = 0 And (Not m_objPicture Is Nothing) Then w = (ScaleX(m_objPicture.Width, vbHimetric, vbPixels) + 2 * m_lngPadding) * m_dblScale h = (ScaleY(m_objPicture.Height, vbHimetric, vbPixels) + 2 * m_lngPadding) * m_dblScale UserControl.Size w, h End If End Sub

    此外，爲了讓控件在沒有提供的容器裏（如Frame）正常運行，讀者可以在Usercontrol上使用Image和Label控件來顯示文字和圖像，即可實現。不過，還得需要處理Image和Label子控件的鼠標事件，在此就不是提供代碼了。