commandbutton.ctl

诛仙特征码工具源码VB 诛仙特征码工具源码VB

VERSION 5.00
Begin VB.UserControl UserControl1 
   BackStyle       =   0  '透明
   ClientHeight    =   780
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3255
   ScaleHeight     =   780
   ScaleWidth      =   3255
   Begin VB.Timer TimerJs 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   60
      Top             =   450
   End
   Begin VB.Label LaCaPtion 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Caption"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   255
      Left            =   2010
      TabIndex        =   0
      Top             =   210
      Width           =   1245
   End
   Begin VB.Image Ima 
      Height          =   330
      Left            =   0
      Picture         =   "CommandButton.ctx":0000
      Top             =   0
      Width           =   1260
   End
End
Attribute VB_Name = "UserControl1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
'获得鼠标所在窗口的句柄
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'获得当前鼠标座标
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RPicture
    Down As Picture
    Up As Picture
    Move As Picture
    Disabled As Picture
End Type


Private IsOver As Boolean '判断是否有按下的按钮

Public Event RMouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)    '声明按下事件
Public Event RMouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)  '声明单击事件
Public Event RMouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event RMouseLeave()      '声明离开事件
Public Event Click()       '声明单击事件
Dim RPic As RPicture





Private Sub LaCaPtion_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ' 判断是否按下
If Button = 1 Then
  Ima.Picture = RPic.Down
  RaiseEvent RMouseDown(Button, Shift, X, Y)    '摔出单击事件
End If
 IsOver = True    '有按下的按钮
End Sub



Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call LaCaPtion_MouseDown(Button, Shift, X, Y)
End Sub

Private Sub Ima1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call LaCaPtion_MouseDown(Button, Shift, X, Y)
End Sub


Private Sub LaCaPtion_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) '判断是否有移动
If Button < 2 Then
   If IsOver = False Then  '没有按下事件时
       Ima.Picture = RPic.Move
       TimerJs.Enabled = True
       RaiseEvent RMouseMove(Button, Shift, X, Y)
    End If
End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call LaCaPtion_MouseMove(Button, Shift, X, Y)
End Sub
Private Sub Ima1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
   Call LaCaPtion_MouseMove(Button, Shift, X, Y)
End Sub




Private Sub LaCaPtion_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) ' 判断是否弹起
If Button = 1 Then
  Ima.Picture = RPic.Up
  RaiseEvent RMouseUp(Button, Shift, X, Y) '摔出弹起事件
  RaiseEvent Click '摔出单击事件
End If
IsOver = False '没有按下的按钮
End Sub

Private Sub Ima1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call LaCaPtion_MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Call LaCaPtion_MouseUp(Button, Shift, X, Y)
End Sub




Private Sub TimerJs_Timer()  ' 监视鼠标是否离开控件
  If Not isMouseOver Then    '鼠标离开离开控件时
        TimerJs.Enabled = False
        IsOver = False        '没有按下的按钮
        RaiseEvent RMouseLeave     '摔出离开事件
        Ima.Picture = RPic.Up
  End If
End Sub

Private Sub UserControl_Initialize()
   Ima.Left = 0
   Ima.Top = 0
   LaCaPtion.Left = 0
   LaHeight
End Sub


Private Sub UserControl_Resize()
 Ima.Picture = RPic.Up
 UserControl.Width = Ima.Width
 UserControl.Height = Ima.Height
 LaCaPtion.Width = Ima.Width
 LaHeight
End Sub




'kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk


Private Function LaHeight() As Integer     '让文字垂直居中
   LaCaPtion.Height = LaCaPtion.FontSize * 21.666667
   LaCaPtion.Top = (Ima.Height - LaCaPtion.Height) \ 2
End Function

Private Function isMouseOver() As Boolean  '鼠标是否在控件上
Dim pt As POINTAPI
    GetCursorPos pt
    isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hwnd)
End Function


'dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd




Public Property Get ForeColor() As OLE_COLOR '文字颜色
    ForeColor = LaCaPtion.ForeColor
End Property

Public Property Let ForeColor(ForeColor As OLE_COLOR)
    LaCaPtion.ForeColor = ForeColor
    PropertyChanged "ForeColor"
End Property


Public Property Get Font() As Font '字体设定
    Set Font = LaCaPtion.Font
End Property

Public Property Set Font(ByRef newFont As Font)
    Set LaCaPtion.Font = newFont
    PropertyChanged "FONT"
End Property



Public Property Get PictureDown() As Picture '按下时的图片
    Set PictureDown = RPic.Down
End Property

Public Property Set PictureDown(ByVal PictureDown As Picture)
    Set RPic.Down = PictureDown
    PropertyChanged "PictureDown"
    Ima.Picture = RPic.Up
End Property


Public Property Get PictureUp() As Picture '弹起时的图片
    Set PictureUp = RPic.Up
End Property

Public Property Set PictureUp(ByVal PictureUp As Picture)
    Set RPic.Up = PictureUp
    PropertyChanged "PictureUp"
    Ima.Picture = RPic.Up
End Property


Public Property Get PicDisabled() As Picture '不可用时的图片
    Set PicDisabled = RPic.Disabled
End Property

Public Property Set PicDisabled(ByVal PicDisabled As Picture)
    Set RPic.Disabled = PicDisabled
    PropertyChanged "PicDisabled"
    Ima.Picture = RPic.Up
End Property


Public Property Get PictureMove() As Picture  '移动时的图片
    Set PictureMove = RPic.Move
End Property

Public Property Set PictureMove(ByVal PictureMove As Picture)
    Set RPic.Move = PictureMove
    PropertyChanged "PictureMove"
    Ima.Picture = RPic.Up
End Property


Public Property Get Enabled() As Boolean '控件是否可用
    Let Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal Enabled As Boolean)
    Let UserControl.Enabled = Enabled
    PropertyChanged "Enabled"
    If Enabled = True Then
      Ima.Picture = RPic.Up
    Else
      Ima.Picture = RPic.Disabled
    End If
End Property



Public Property Get Caption() As String '文本
    Let Caption = LaCaPtion.Caption
End Property

Public Property Let Caption(ByVal Caption As String)
    Let LaCaPtion.Caption = Caption
    PropertyChanged "Caption"
End Property


'保存数据
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    With PropBag
        Call .WriteProperty("Enabled", UserControl.Enabled, True) '是否可用
        Call .WriteProperty("PictureMove", RPic.Move)  '移动时的图片
        Call .WriteProperty("PictureUp", RPic.Up)     '弹起时的图片
        Call .WriteProperty("PictureDown", RPic.Down)  '按下时的图片
        Call .WriteProperty("PictureDisabled", RPic.Disabled)  '不可用时的图片
        Call .WriteProperty("Font", LaCaPtion.Font)          '字体
        Call .WriteProperty("ForeColor", LaCaPtion.ForeColor) '文字颜色
        Call .WriteProperty("Caption", LaCaPtion.Caption) '文本
    End With
End Sub

'读取数据
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    With PropBag
        UserControl.Enabled = .ReadProperty("Enabled", True)   '是否可用
     Set RPic.Move = .ReadProperty("PictureMove", Ima.Picture)   '移动时的图片
     Set RPic.Up = .ReadProperty("PictureUp", Ima.Picture)    '弹起时的图片
     Set RPic.Down = .ReadProperty("PictureDown", Ima.Picture)   '按下时的图片
     Set RPic.Disabled = .ReadProperty("PictureDisabled", Ima.Picture)   '不可用时的图片
        LaCaPtion.Font = .ReadProperty("Font", "宋体")                  '字体
        LaCaPtion.ForeColor = .ReadProperty("ForeColor", RGB(255, 255, 255)) '文字颜色
        LaCaPtion.Caption = .ReadProperty("Caption", "Caption") '文本
    End With
End Sub


Public Sub CsF()
If UserControl.Enabled Then Ima.Picture = RPic.Up Else Ima.Picture = RPic.Disabled
End Sub