hkd.ctl

该程序是思路是经过专门的顾问专家集十年的经验设计

VERSION 5.00
Begin VB.UserControl HKD 
   Appearance      =   0  'Flat
   BackColor       =   &H8000000B&
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.Shape Shape1 
      BorderStyle     =   0  'Transparent
      Height          =   1005
      Left            =   0
      Top             =   0
      Width           =   1470
   End
   Begin VB.Image Image3 
      Height          =   360
      Left            =   615
      Top             =   2085
      Visible         =   0   'False
      Width           =   390
   End
   Begin VB.Image Image2 
      Height          =   450
      Left            =   390
      Top             =   1260
      Visible         =   0   'False
      Width           =   300
   End
   Begin VB.Line linLeft 
      BorderColor     =   &H00FFFFFF&
      X1              =   2490
      X2              =   2490
      Y1              =   570
      Y2              =   1260
   End
   Begin VB.Line linTop 
      BorderColor     =   &H00FFFFFF&
      X1              =   2505
      X2              =   4110
      Y1              =   540
      Y2              =   540
   End
   Begin VB.Line linButton 
      BorderColor     =   &H00808080&
      X1              =   2490
      X2              =   4125
      Y1              =   1275
      Y2              =   1275
   End
   Begin VB.Line linRight 
      BorderColor     =   &H00808080&
      X1              =   4095
      X2              =   4095
      Y1              =   540
      Y2              =   1290
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label1"
      Height          =   180
      Left            =   705
      TabIndex        =   0
      Top             =   195
      Width           =   540
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   150
      Top             =   60
      Width           =   480
   End
End
Attribute VB_Name = "HKD"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Enum hkState
    ncNoCapture
    ncDownState
    ncUpState
End Enum             '枚举使用的类型

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Dim YN As Boolean
Dim CtrState As hkState
Public Event MouseDown(ByVal Button As Integer, ByVal Shift As Integer)
Public Event MouseUp(ByVal Button As Integer, ByVal Shift As Integer)
Public Event MouseMove(ByVal Button As Integer, ByVal Shift As Integer)
Public Event MouseExit(ByVal Button As Integer, ByVal Shift As Integer)
'缺省属性值:
Const m_def_CapLeft = 700
Const m_def_CapTop = 200
'属性变量:
Dim mBackA As OLE_COLOR
Dim mBackB As OLE_COLOR
Dim mBackC As OLE_COLOR
Dim mBsy As Integer
Dim TF As Boolean


Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseMove(Button, Shift, X, Y)
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call UserControl_MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Initialize()
      YN = False
      TF = False
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then
    UserControl.BackColor = mBackC
    RaiseEvent MouseDown(Button, Shift)
        State = ncDownState
        YN = False
End If
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim X1 As Single, Y1 As Single
X1 = X - ScaleLeft
Y1 = Y - ScaleTop
If Not TF Then
    SetCapture hwnd
    TF = True
End If
If (X1 >= 0 And X1 < ScaleWidth And Y1 >= 0 And Y1 < ScaleHeight) Then
If YN Then Exit Sub
    If Image2.Picture <> 0 Then Image1.Picture = Image2.Picture
    If Button = 1 Then
    UserControl.BackColor = mBackC
    State = ncDownState
    Else
    Shape1.BorderStyle = 0
     UserControl.BackColor = mBackB
     State = ncUpState
    End If
    RaiseEvent MouseMove(Button, Shift)
    YN = True
Else
    If Button = 1 Then
        If Image2.Picture <> 0 Then Image1.Picture = Image3.Picture
            Shape1.BorderStyle = 0
            UserControl.BackColor = mBackB 'mBackB
            State = ncUpState
        Else
            UserControl.BackColor = mBackA
            Image1.Picture = Image3.Picture
            ReleaseCapture
            TF = False
            RaiseEvent MouseExit(Button, Shift)
            State = ncNoCapture
            Shape1.BorderStyle = mBsy
       End If
       YN = False
End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim X1 As Single, Y1 As Single
X1 = X - ScaleLeft
Y1 = Y - ScaleTop
TF = False
If (X1 >= 0 And X1 < ScaleWidth And Y1 >= 0 And Y1 < ScaleHeight) Then
     If Button = 2 Then Exit Sub
  RaiseEvent MouseUp(Button, Shift)
    UserControl.BackColor = mBackB
    State = ncUpState
    SetCapture UserControl.hwnd
Else
    UserControl.BackColor = mBackA
     ReleaseCapture
    State = ncNoCapture
    Shape1.BorderStyle = mBsy
    YN = False
End If
'YN = False
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
State = PropBag.ReadProperty("State", ncNoCapture)
    Label1.Caption = PropBag.ReadProperty("Caption", "Label1")
        Set Image1.Picture = PropBag.ReadProperty("PictureA", Nothing)
        Set Image3.Picture = PropBag.ReadProperty("PictureA", Nothing)
    linTop.BorderWidth = PropBag.ReadProperty("Bold", 1)
    linLeft.BorderWidth = PropBag.ReadProperty("Bold", 1)
    linButton.BorderWidth = PropBag.ReadProperty("Bold", 1)
    linRight.BorderWidth = PropBag.ReadProperty("Bold", 1)
    Label1.Left = PropBag.ReadProperty("CapLeft", m_def_CapLeft)
    Label1.Top = PropBag.ReadProperty("CapTop", m_def_CapTop)
    Image1.Left = PropBag.ReadProperty("ImgLeft", 60)
    Image1.Top = PropBag.ReadProperty("ImgTop", 60)
    Set Image2.Picture = PropBag.ReadProperty("PictrueB", Nothing)
    Set Picture = PropBag.ReadProperty("BackPicture", Nothing)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Label1.Enabled = PropBag.ReadProperty("Enabled", True)
    mBackB = PropBag.ReadProperty("BackB", &H87CDFC)
    mBackA = PropBag.ReadProperty("BackColor", &H8000000F)
    mBackC = PropBag.ReadProperty("BackC", &HDDDDDD)
    Shape1.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
    mBsy = PropBag.ReadProperty("BorderStyle", 0)
    Shape1.BorderColor = PropBag.ReadProperty("BackS", &H80000012)
End Sub
Private Sub UserControl_Resize()
    State = State
   Shape1.Height = Height
   Shape1.Width = Width
    linTop.X1 = ScaleLeft
    linTop.X2 = ScaleLeft + ScaleWidth - ScaleX(1, vbPixels)
    linTop.Y1 = ScaleTop
    linTop.Y2 = ScaleTop
    linLeft.X1 = ScaleLeft
    linLeft.X2 = ScaleLeft
    linLeft.Y1 = ScaleTop
    linLeft.Y2 = ScaleTop + ScaleHeight - ScaleY(1, vbPixels)
    linButton.X1 = ScaleLeft
    linButton.X2 = ScaleLeft + ScaleWidth - ScaleX(1, vbPixels)
    linButton.Y1 = ScaleTop + ScaleHeight - ScaleY(1, vbPixels)
    linButton.Y2 = ScaleTop + ScaleHeight - ScaleY(1, vbPixels)
    linRight.X1 = ScaleLeft + ScaleWidth - ScaleX(1, vbPixels)
    linRight.X2 = ScaleLeft + ScaleWidth - ScaleX(1, vbPixels)
    linRight.Y1 = ScaleTop
    linRight.Y2 = ScaleTop + ScaleHeight - ScaleY(1, vbPixels)

End Sub
Public Property Let State(Statenew As hkState)
CtrState = Statenew
If Statenew = ncNoCapture Then
    linTop.Visible = False
    linLeft.Visible = False
    linButton.Visible = False
    linRight.Visible = False
Else
    If Statenew = ncDownState Then
        linTop.BorderColor = &H808080
        linLeft.BorderColor = &H808080
        linButton.BorderColor = &HFFFFFF
        linRight.BorderColor = &HFFFFFF
    Else
        linTop.BorderColor = &HFFFFFF
        linLeft.BorderColor = &HFFFFFF
        linButton.BorderColor = &H808080
        linRight.BorderColor = &H808080
    End If
    linTop.Visible = True
    linLeft.Visible = True
    linButton.Visible = True
    linRight.Visible = True
End If
PropertyChanged "State"
End Property
Public Property Get State() As hkState
State = CtrState
End Property

Private Sub UserControl_Show()
     If Me.BorderStyle <> 0 Then
   Shape1.Height = Height
   Shape1.Width = Width
   End If

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "State", CtrState, ncNoCapture
    Call PropBag.WriteProperty("Caption", Label1.Caption, "Label1")
    Call PropBag.WriteProperty("PictureA", Image1.Picture, Nothing)
    Call PropBag.WriteProperty("Bold", linTop.BorderWidth, 1)
    Call PropBag.WriteProperty("CapLeft", Label1.Left, m_def_CapLeft)
    Call PropBag.WriteProperty("CapTop", Label1.Top, m_def_CapTop)
    Call PropBag.WriteProperty("ImgLeft", Image1.Left, 60)
    Call PropBag.WriteProperty("ImgTop", Image1.Top, 60)
    Call PropBag.WriteProperty("PictrueB", Image2.Picture, Nothing)
    Call PropBag.WriteProperty("BackPicture", Picture, Nothing)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("Enabled", Label1.Enabled, True)
    Call PropBag.WriteProperty("BackB", mBackB, &H87CDFC)
    Call PropBag.WriteProperty("BackC", mBackC, &HDDDDDD)
    Call PropBag.WriteProperty("BorderStyle", Shape1.BorderStyle, 0)
    Call PropBag.WriteProperty("BackS", Shape1.BorderColor, &HFFFFFF)
End Sub

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Label1,Label1,-1,Caption
Public Property Get Caption() As String
    Caption = Label1.Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
    Label1.Caption() = New_Caption
    PropertyChanged "Caption"
End Property
'
Public Property Get PictureA() As Picture
    Set PictureA = Image1.Picture
End Property
'
Public Property Set PictureA(ByVal New_Picture As Picture)
    Set Image1.Picture = New_Picture
    PropertyChanged "PictureA"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=linHilite1,linHilite1,-1,BorderWidth
Public Property Get Bold() As Integer
    Bold = linTop.BorderWidth
End Property

Public Property Let Bold(ByVal New_Bold As Integer)
    linTop.BorderWidth() = New_Bold
    linLeft.BorderWidth() = New_Bold
    linButton.BorderWidth() = New_Bold
    linRight.BorderWidth() = New_Bold
    PropertyChanged "Bold"
End Property

Public Property Get CapLeft() As Variant
    CapLeft = Label1.Left
End Property

Public Property Let CapLeft(ByVal New_CapLeft As Variant)
    Label1.Left = New_CapLeft
    PropertyChanged "CapLeft"
End Property

Public Property Get CapTop() As Variant
    CapTop = Label1.Top
End Property

Public Property Let CapTop(ByVal New_CapTop As Variant)
    Label1.Top = New_CapTop
    PropertyChanged "CapTop"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    Label1.Left = m_def_CapLeft
    Label1.Top = m_def_CapTop
End Sub
Public Property Get ImgLeft() As Variant
    ImgLeft = Image1.Left
End Property

Public Property Let ImgLeft(ByVal New_ImgLeft As Variant)
    Image1.Left = New_ImgLeft
    PropertyChanged "ImgLeft"
End Property
Public Property Get ImgTop() As Variant
    ImgTop = Image1.Top
End Property

Public Property Let ImgTop(ByVal New_ImgTop As Variant)
    Image1.Top = New_ImgTop
    PropertyChanged "ImgTop"
End Property
Public Property Get PictrueB() As Picture
Attribute PictrueB.VB_Description = "返回/设置控件中显示的图形。"
    Set PictrueB = Image2.Picture
End Property

Public Property Set PictrueB(ByVal New_PictrueB As Picture)
    Set Image2.Picture = New_PictrueB
    PropertyChanged "PictrueB"
End Property
Public Property Get BackPicture() As Picture
    Set BackPicture = UserControl.Picture
End Property

Public Property Set BackPicture(ByVal New_BackPicture As Picture)
    Set UserControl.Picture = New_BackPicture
    PropertyChanged "BackPicture"
End Property
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    mBackA = New_BackColor
    PropertyChanged "BackColor"
End Property

Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "返回/设置一个值，决定一个对象是否响应用户生成事件。"
    Enabled = Label1.Enabled
    
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    Label1.Enabled() = New_Enabled
    UserControl.Enabled = New_Enabled
    PropertyChanged "Enabled"
End Property

Public Property Get BackB() As OLE_COLOR
Attribute BackB.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackB = mBackB
End Property

Public Property Let BackB(ByVal New_BackB As OLE_COLOR)
    mBackB = New_BackB
    PropertyChanged "BackB"
End Property
Public Property Get BackC() As OLE_COLOR
    BackC = mBackC
End Property

Public Property Let BackC(ByVal New_BackC As OLE_COLOR)
    mBackC = New_BackC
    PropertyChanged "BackC"
End Property

Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "返回/设置对象的边框样式。"
    BorderStyle = Shape1.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    Shape1.BorderStyle() = New_BorderStyle
    mBsy = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property
'
'注意！不要删除或修改下列被注释的行！
'MappingInfo=Shape1,Shape1,-1,BorderColor
Public Property Get BackS() As OLE_COLOR
Attribute BackS.VB_Description = "返回/设置对象的边框颜色。"
    BackS = Shape1.BorderColor
End Property

Public Property Let BackS(ByVal New_BackS As OLE_COLOR)
    Shape1.BorderColor() = New_BackS
    PropertyChanged "BackS"
End Property