淡入淡出按钮实现bbtn
VERSION 5.00Begin VB.UserControl BBtn
AutoRedraw = -1'True
ClientHeight = 2295
ClientLeft = 0
ClientTop = 0
ClientWidth = 4950
ScaleHeight = 153
ScaleMode = 3'Pixel
ScaleWidth = 330
Begin VB.Timer TBlend
Enabled = 0 'False
Interval = 33
Left = 2880
Top = 1680
End
Begin VB.Timer Tout
Enabled = 0 'False
Interval = 100
Left = 2880
Top = 960
End
End
Attribute VB_Name = "BBtn"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'作者：夏煜 【Email:imperialeast@126.com QQ:499932452】
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte ' 透明度：0=全透，255=不透明
AlphaFormat As Byte
End Type
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Function AlphaBlend Lib "Msimg32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal cxSrc As Long, ByVal cySrc As Long, ByVal BLENDFUNCTION As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long ' 像素宽度
bmHeight As Long ' 像素高度
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Public CircleChk As Boolean
Public Event Click()
Dim BlendVal As Byte
Dim Pmove As Boolean
Dim lFlags As Byte
Dim m_Picture As StdPicture
Dim height As Long
Dim width As Long
Public Property Get hDC() As Long
hDC = UserControl.hDC
End Property
Public Property Get hWnd() As Long
hWnd = UserControl.hWnd
End Property
Sub DrawNor()
Dim Bmp As BITMAP
If m_Picture Is Nothing Then Exit Sub
GetObject m_Picture.handle, Len(Bmp), Bmp
height = Bmp.bmHeight
width = Bmp.bmWidth
UserControl.width = (width / 4) * Screen.TwipsPerPixelX
UserControl.height = height * Screen.TwipsPerPixelY
End Sub
Sub DoDraw(ByVal BlendVal As Byte, Optional ByVal flags As Byte = 0)
Dim mDC As Long, mBmp As Long, OldBmp As Long, ResDC As Long, ResBmp As Long, Blen As BLENDFUNCTION, lBF As Long
If m_Picture Is Nothing Then Exit Sub
mDC = CreateCompatibleDC(UserControl.hDC)
mBmp = CreateCompatibleBitmap(UserControl.hDC, width / 4, height)
OldBmp = SelectObject(mDC, mBmp)
ResDC = CreateCompatibleDC(UserControl.hDC)
ResBmp = SelectObject(ResDC, m_Picture.handle)
With Blen
.AlphaFormat = 0
.BlendFlags = 0
.BlendOp = 0
.SourceConstantAlpha = BlendVal
End With
UserControl.Refresh
Select Case flags
Case 0 'normal
If BlendVal < 255 Then
BitBlt mDC, 0, 0, width / 4, height, ResDC, 0, 0, vbSrcCopy
SelectObject ResDC, ResBmp
DeleteDC ResDC
RtlMoveMemory lBF, Blen, 4
AlphaBlend hDC, 0, 0, width / 4, height, mDC, 0, 0, width / 4, height, lBF
Else
UserControl.Cls
BitBlt mDC, 0, 0, width / 4, height, ResDC, 0, 0, vbSrcCopy
SelectObject ResDC, ResBmp
DeleteDC ResDC
BitBlt hDC, 0, 0, width / 4, height, mDC, 0, 0, vbSrcCopy
End If
Case 1 'over
If BlendVal < 255 Then
BitBlt mDC, 0, 0, width / 4, height, ResDC, width / 4, 0, vbSrcCopy
SelectObject ResDC, ResBmp
DeleteDC ResDC
RtlMoveMemory lBF, Blen, 4
AlphaBlend hDC, 0, 0, width / 4, height, mDC, 0, 0, width / 4, height, lBF
Else
UserControl.Cls
BitBlt mDC, 0, 0, width / 4, height, ResDC, width / 4, 0, vbSrcCopy
SelectObject ResDC, ResBmp
DeleteDC ResDC
BitBlt hDC, 0, 0, width / 4, height, mDC, 0, 0, vbSrcCopy
End If
Case 2 'down
UserControl.Cls
BitBlt mDC, 0, 0, width / 4, height, ResDC, width / 2, 0, vbSrcCopy
SelectObject ResDC, ResBmp
DeleteDC ResDC
BitBlt hDC, 0, 0, width / 4, height, mDC, 0, 0, vbSrcCopy
Case 3 'gray not enabled
BitBlt mDC, 0, 0, width / 4, height, ResDC, width * 3 / 4, 0, vbSrcCopy
SelectObject ResDC, ResBmp
DeleteDC ResDC
BitBlt hDC, 0, 0, width / 4, height, mDC, 0, 0, vbSrcCopy
End Select
SelectObject mDC, OldBmp
DeleteObject mBmp
DeleteDC mDC
End Sub
Private Sub TBlend_Timer()
BlendVal = BlendVal + 15
DoDraw BlendVal, lFlags
If BlendVal > 150 Then
BlendVal = 1
TBlend.Enabled = False
End If
End Sub
Private Function IsMouseOver() As Boolean
Dim pt As POINTAPI
GetCursorPos pt
If CircleChk = False Then
IsMouseOver = (WindowFromPoint(pt.X, pt.Y) = hWnd) 'RECT
Else
ScreenToClient Me.hWnd, pt
IsMouseOver = IsInCircle(pt.X, pt.Y) 'Circle
End If
If IsMouseOver = False Then
Pmove = False
lFlags = 0
BlendVal = 1
TBlend.Enabled = True
Tout.Enabled = False
End If
End Function
Private Sub Tout_Timer()
IsMouseOver
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
If CircleChk = True Then
If IsInCircle(X, Y) Then DoDraw 255, 2
Else
DoDraw 255, 2
End If
End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Pmove = False Then
If CircleChk = True Then
If IsInCircle(X, Y) Then Pmove = True: lFlags = 1: BlendVal = 1: TBlend.Enabled = True: Tout.Enabled = True
Else
Pmove = True: lFlags = 1: BlendVal = 1: TBlend.Enabled = True: Tout.Enabled = True
End If
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If CircleChk = True Then
If IsInCircle(X, Y) Then DoDraw 255, 1: RaiseEvent Click
Else
DoDraw 255, 1: RaiseEvent Click
End If
End Sub
Private Function IsInCircle(ByVal X As Long, ByVal Y As Long) As Boolean
Dim R As Long
If width / 8 <= height / 2 Then
R = width / 8
Else
R = height / 2
End If
If (X - width / 8) ^ 2 + (Y - height / 2) ^ 2 < R ^ 2 Then
IsInCircle = True
Else
IsInCircle = False
End If
End Function
Public Property Set Picture(newp As StdPicture)
Set m_Picture = newp
DrawNor
DoDraw 255
Pmove = False
PropertyChanged "Picture"
End Property
Public Property Get Picture() As StdPicture
Set Picture = m_Picture
End Property
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Set Picture = PropBag.ReadProperty("Picture", m_Picture)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "Picture", m_Picture
End Sub
以下是实例和工程源代码文件
通过网盘分享的文件：淡入淡出.rar
链接: https://pan.baidu.com/s/1Cdka4DjZUIZj88eaacHx3A?pwd=1234 提取码: 1234
这个是控件实现淡入淡出的button效果 图中程序效果，以及程序可以百度网盘下载，不是源码，是程序文件
通过网盘分享的文件：WinAMP(1).rar
链接: https://pan.baidu.com/s/1Y_z--BQxpaeXF8erupYZRg?pwd=1234 提取码: 1234
页:
[1]