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

 

    使用无窗口透明控件，好处是控件不是从窗口类继承而来的，可以节省一些内存资源，难点是鼠标控制和坐标计算，缺点是无法直接响应键盘事件。而且，需要注意的是，在Paint事件里，坐标是从（0，0）开始的，而在其它地方，坐标是相对于容器的。缺点是设计时，无法用鼠标点选控件（只能用键盘移动），微软公司也在MSDN里说了这是一个BUG，但至今未解决。

    好了，废话俺不说了，打开VB6，新建一个“标准 EXE”，然后添加一个用户控件，把控件的BackStyle属性设置为“透明”，把Windowless属性设置为“True”，再把俺的代码复制过去，一个美观大方的透明浮动按钮便完成了。用户还可以设置控件的Caption属性和Picture属性进一步美化。如有不解之处，可与俺联系：

'* ************************************************************** * '* 程序名称：FloatButton.ctl '* 程序功能：透明浮动按扭 '* 作者：lyserver '* 联系方式：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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, 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, 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 '====================================================================== ' 事件声明 '====================================================================== Public Event Click() '====================================================================== ' 属性变量声明 '====================================================================== Dim m_Picture As StdPicture Dim m_Caption As String Dim m_TextAlign As AlignConstants '====================================================================== ' 模块公共变量声明 '====================================================================== Dim m_rcDraw As RECT Dim m_MouseButton As Integer Dim WithEvents tm As Timer '====================================================================== ' 函数名称：UserControl_Initialize ' 函数说明：初始化控件 '====================================================================== Private Sub UserControl_Initialize() Set tm = UserControl.Controls.Add("VB.Timer", "tm") '加载定时器 tm.Interval = 10 UserControl.ScaleMode = vbPixels End Sub '====================================================================== ' 函数名称：UserControl_Terminate ' 函数说明：销毁控件 '====================================================================== Private Sub UserControl_Terminate() tm.Enabled = False '关闭定时器 UserControl.Controls.Remove "tm" '删除定时器 End Sub '====================================================================== ' 函数名称：UserControl_ReadProperties ' 函数说明：读取控件属性 '====================================================================== Private Sub UserControl_ReadProperties(PropBag As PropertyBag) On Error Resume Next m_Caption = PropBag.ReadProperty("Caption", "") m_TextAlign = PropBag.ReadProperty("TextAlign", vbAlignNone) Set m_Picture = PropBag.ReadProperty("Picture", Nothing) End Sub '====================================================================== ' 函数名称：UserControl_WriteProperties ' 函数说明：保存控件属性 '====================================================================== Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("Caption", m_Caption, "") Call PropBag.WriteProperty("TextAlign", m_TextAlign, vbAlignNone) Call PropBag.WriteProperty("Picture", m_Picture, Nothing) End Sub '====================================================================== ' 函数名称：UserControl_Resize ' 函数说明：调整控件大小 '====================================================================== Private Sub UserControl_Resize() Dim nScaleX As Long Dim nScaleY As Long nScaleX = UserControl.Extender.Width / UserControl.ScaleWidth nScaleY = UserControl.Extender.Height / UserControl.ScaleHeight If nScaleX = 0 Then nScaleX = 1 If nScaleY = 0 Then nScaleY = 1 m_rcDraw.Left = UserControl.Extender.Left / nScaleX m_rcDraw.Top = UserControl.Extender.Top / nScaleY m_rcDraw.Right = m_rcDraw.Left + UserControl.ScaleWidth - 1 m_rcDraw.Bottom = m_rcDraw.Top + UserControl.ScaleHeight - 1 End Sub '====================================================================== ' 函数名称：UserControl_HitTest ' 函数说明：检测鼠标移动和进入事件 '====================================================================== Private Sub UserControl_HitTest(x As Single, y As Single, HitResult As Integer) Dim hdc As Long If Not UserControl.Ambient.UserMode Then '如果处于设计时则退出 Exit Sub End If If HitResult = vbHitResultOutside Then HitResult = vbHitResultHit If Not tm.Enabled Then '鼠标进入事件 DrawEdge UserControl.Extender.Container.hdc, m_rcDraw, BDR_RAISEDINNER, BF_RECT '绘制浮起边框 tm.Enabled = True End If End If End Sub '====================================================================== ' 函数名称：tm_Timer ' 函数说明：定时检测鼠标移出事件 '====================================================================== Private Sub tm_Timer() Dim pt As POINTAPI GetCursorPos pt ScreenToClient UserControl.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 m_MouseButton = 0 UserControl.Refresh DoEvents End If End Sub '====================================================================== ' 函数名称：UserControl_MouseDown ' 函数说明：鼠标按键事件 '====================================================================== Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Dim hdc As Long m_MouseButton = Button If m_MouseButton = 1 Then DrawEdge UserControl.Extender.Container.hdc, m_rcDraw, BDR_SUNKENINNER, BF_RECT 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 m_MouseButton = 1 Then m_MouseButton = 0 DrawEdge UserControl.Extender.Container.hdc, m_rcDraw, BDR_RAISEDINNER, BF_RECT If tm.Enabled Then RaiseEvent Click '激发单击事件 End If End Sub '====================================================================== ' 函数名称：UserControl_Paint ' 函数说明：绘制控件 '====================================================================== Private Sub UserControl_Paint() Dim rcDraw As RECT Dim hdcDraw As Long, nLen As Long, dtAlign As Long Dim bmLeft As Long, bmTop As Long, bmWidth As Long, bmHeight As Long nLen = LenB(StrConv(m_Caption, vbFromUnicode)) rcDraw.Left = 4 rcDraw.Top = 4 rcDraw.Right = UserControl.ScaleWidth - 4 rcDraw.Bottom = UserControl.ScaleHeight - 4 If Not (m_Picture Is Nothing) Then bmWidth = ScaleX(m_Picture.Width, vbHimetric, vbPixels) bmHeight = ScaleY(m_Picture.Height, vbHimetric, vbPixels) End If Select Case m_TextAlign Case vbAlignNone '文字和图像均居中 dtAlign = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE bmLeft = (rcDraw.Right - rcDraw.Left - bmWidth) / 2 bmTop = (rcDraw.Bottom - rcDraw.Top - bmHeight) / 2 Case vbAlignTop '文字居上图像居下 dtAlign = DT_CENTER Or DT_TOP Or DT_SINGLELINE bmLeft = (rcDraw.Right - rcDraw.Left - bmWidth) / 2 bmTop = rcDraw.Bottom - bmHeight - TextHeight(m_Caption) Case vbAlignBottom '文字居下图像居上 dtAlign = DT_CENTER Or DT_BOTTOM Or DT_SINGLELINE bmLeft = (rcDraw.Right - rcDraw.Left - bmWidth) / 2 bmTop = rcDraw.Top Case vbAlignLeft '文字居左图像居右 dtAlign = DT_VCENTER Or DT_LEFT Or DT_SINGLELINE bmLeft = rcDraw.Right - bmWidth - TextWidth(m_Caption) bmTop = (rcDraw.Bottom - rcDraw.Top - bmHeight) / 2 Case vbAlignRight '文字居右图像居左 dtAlign = DT_VCENTER Or DT_RIGHT Or DT_SINGLELINE bmLeft = rcDraw.Left bmTop = (rcDraw.Bottom - rcDraw.Top - bmHeight) / 2 End Select hdcDraw = UserControl.Extender.Container.hdc If Not (m_Picture Is Nothing) Then If m_MouseButton = 1 Then '如果当前鼠标为按键状态，则图像下沉一个像素 bmTop = bmTop + 1 bmLeft = bmLeft + 1 End If m_Picture.Render CLng(hdcDraw), CLng(bmLeft), CLng(bmTop), CLng(bmWidth), CLng(bmHeight), _ 0, m_Picture.Height, m_Picture.Width, -m_Picture.Height, ByVal 0& End If DrawText hdcDraw, m_Caption, nLen, rcDraw, dtAlign End Sub '====================================================================== ' 函数名称：Caption ' 函数说明：读取和设置Caption属性 '====================================================================== Public Property Get Caption() As String Caption = m_Caption End Property Public Property Let Caption(ByVal New_Caption As String) m_Caption = New_Caption PropertyChanged "Caption" UserControl.Refresh '属性改变时重绘控件 End Property '====================================================================== ' 函数名称：TextAlign ' 函数说明：读取和设置TextAlign属性 '====================================================================== Public Property Get TextAlign() As AlignConstants TextAlign = m_TextAlign End Property Public Property Let TextAlign(ByVal New_TextAlign As AlignConstants) m_TextAlign = New_TextAlign PropertyChanged "TextAlign" UserControl.Refresh '属性改变时重绘控件 End Property '====================================================================== ' 函数名称：Picture ' 函数说明：读取和设置Picture属性 '====================================================================== Public Property Get Picture() As StdPicture Set Picture = m_Picture End Property Public Property Set Picture(ByVal New_Picture As StdPicture) Set m_Picture = New_Picture PropertyChanged "Picture" UserControl.Refresh '属性改变时重绘控件 End Property

 

效果如下：