VERSION 5.00
Begin 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 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
|Archiver|小黑屋|技术宅的结界
( 滇ICP备16008837号 )|网站地图
发表于 
