再谈用VB无窗口透明Usercontrol编写透明浮动按钮

最新推荐文章于 2021-01-28 20:33:19 发布
antoni
最新推荐文章于 2021-01-28 20:33:19 发布
阅读量1.2k
点赞数
分类专栏： VB 文章标签： vb function integer user button string
VB 专栏收录该内容
9 篇文章 0 订阅
订阅专栏
'* ************************************************************** *  
'*    程序名称：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子控件的鼠标事件，在此就不是提供代码了。
Link: http://blog.csdn.net/lyserver/archive/2009/09/19/4571003.aspx