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

@H_301_0@ 去年曾写过一篇博文，名称叫《用VB无窗口透明Usercontrol编写透明浮动按钮》，该文有一个观点是错误的，即透明无窗口Usercontrol不支持设计时点选。其实，通过在UserControl_HitTest过程里加入HitResult = vbHitResultHit语句，就可以实现设计时的点选了，为此，修改代码如下：

@H_301_0@

'* ************************************************************** *
'*    程序<a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>：Button.ctl
'*    程序<a href="/tag/gongneng/" target="_blank" class="keywords">功能</a>：透明浮动按扭
'*    作者：lyserver，最后<a href="/tag/xiugai/" target="_blank" class="keywords">修改</a>日期：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()

'----------------------------------------------------------------------
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>变量声明
'----------------------------------------------------------------------
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 '

SetRect rcDraw,ScaleHeight
    DrawPicture hdc,rcDraw,m_objPicture
End Sub

'----------------------------------------------------------------------
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a><a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>：HoverPicture
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>说明：读取和设置鼠标悬停时的<a href="/tag/tupian/" target="_blank" class="keywords">图片</a>
'----------------------------------------------------------------------
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

'----------------------------------------------------------------------
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a><a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>：Enabled
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>说明：读取和设置Enabled<a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>
'----------------------------------------------------------------------
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

'----------------------------------------------------------------------
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a><a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>：TextAlign
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>说明：读取和设置文本对齐方式
'----------------------------------------------------------------------
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 '<a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>改变时重绘控件
End Property

'----------------------------------------------------------------------
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a><a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>：Padding
' <a href="/tag/shuxing/" target="_blank" class="keywords">属性</a>说明：读取和设置内部填充像素
'----------------------------------------------------------------------
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

'----------------------------------------------------------------------
' <a href="/tag/hanshu/" target="_blank" class="keywords">函数</a><a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>：DrawPicture
' <a href="/tag/hanshu/" target="_blank" class="keywords">函数</a>说明：在指定位置和大小的矩形内绘制<a href="/tag/tupian/" target="_blank" class="keywords">图片</a>
'----------------------------------------------------------------------
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,vbPixels)
        Select Case m_lngTextAlign
            Case [Top] '<a href="/tag/wenzi/" target="_blank" class="keywords">文字</a>居上图像居下
                bmLeft = rcDraw.Left + (rcWidth - bmWidth) / 2
                bmTop = rcDraw.Top + (rcHeight - bmHeight - ScaleY(TextHeight(m_strCaption),vbPixels,ScaleMode))
            Case [Bottom] '<a href="/tag/wenzi/" target="_blank" class="keywords">文字</a>居下图像居上
                bmLeft = rcDraw.Left + (rcWidth - bmWidth) / 2
                bmTop = rcDraw.Top
            Case [Left] '<a href="/tag/wenzi/" target="_blank" class="keywords">文字</a>居左图像居右
                bmLeft = rcDraw.Left + (rcWidth - bmWidth - ScaleX(TextWidth(m_strCaption),ScaleMode))
                bmTop = rcDraw.Top + (rcHeight - bmHeight) / 2
            Case [Right] '<a href="/tag/wenzi/" target="_blank" class="keywords">文字</a>居右图像居左
                bmLeft = rcDraw.Left
                bmTop = rcDraw.Top + (rcHeight - bmHeight) / 2
            Case Else '<a href="/tag/wenzi/" target="_blank" class="keywords">文字</a>和图像均居中
                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,LenB(StrConv(m_strCaption,vbFromUnicode)),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,vbPixels) + 2 * m_lngPadding) * m_dblScale
        h = (ScaleY(m_objPicture.Height,vbPixels) + 2 * m_lngPadding) * m_dblScale
        UserControl.Size w,h
    End If
End Sub

@H_301_0@ 此外，为了让控件在没有提供的容器里（如Frame）正常运行，读者可以在Usercontrol上使用Image和Label控件来显示文字和图像，即可实现。不过，还得需要处理Image和Label子控件的鼠标事件，在此就不是提供代码了。

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

猜你在找的VB相关文章