objhd.cls

套打程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ObjHd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

'保持属性值的局部变量(局部复制)
Private mvarHdID As Integer
Private mvarObjCtl As Object
Private mvarnState As Integer

'Old Color
'Private Const DefaultColor = &H800000
'Private Const LockedColor = vbRed
'Private Const CurrentColor = vbBlue
'Private Const CurLockColor = LockedColor + CurrentColor

'nState
Public Property Let nState(ByVal vData As Integer)
    mvarnState = vData
    If Not mvarObjCtl Is Nothing Then
        With mvarObjCtl
            Select Case mvarnState
                Case -2: .Picture = g_ActFrm.ImgCurLock.Picture
                Case -1: .Picture = g_ActFrm.ImgLock.Picture
                Case 1: .Picture = g_ActFrm.ImgCur.Picture
                Case Else: .Picture = g_ActFrm.ImgAct.Picture
'                Case -2: .BackColor = CurLockColor
'                Case -1: .BackColor = LockedColor
'                Case 1: .BackColor = CurrentColor
'                Case Else: .BackColor = DefaultColor
            End Select
            .MousePointer = IIf(mvarnState < 0, vbDefault, GetPointType(Val(.Tag)))
       End With
    End If
End Property
Public Property Get nState() As Integer
    nState = mvarnState
End Property

'HdID
Public Property Let HdID(ByVal vData As Integer)
    mvarHdID = vData
End Property
Public Property Get HdID() As Integer
    HdID = mvarHdID
End Property

'ObjCtl
Public Property Set ObjCtl(ByVal vData As Object)
    Set mvarObjCtl = vData
End Property
Public Property Get ObjCtl() As Object
    Set ObjCtl = mvarObjCtl
End Property

'Move
Public Sub Move(Left As Single, Top As Single)
    mvarObjCtl.Move Left, Top
End Sub

'OnMouseDown
Public Sub OnMouseDown(obj As ObjDraw, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call obj.OnStartSize(mvarHdID, Button, Shift, X, Y)
End Sub

'OnMouseMove
Public Sub OnMouseMove(obj As ObjDraw, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call obj.OnSizing(Button, Shift, X, Y)
End Sub

'OnMouseUp
Public Sub OnMouseUp(obj As ObjDraw, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call obj.OnEndSize(Button, Shift, X, Y)
End Sub

'GetPointType
Private Function GetPointType(tmpidx As Integer) As Integer
    Select Case tmpidx
        'Top Left
        Case 1: GetPointType = vbSizeNWSE
        'Top center
        Case 2: GetPointType = vbSizeNS
        'Top right
        Case 3: GetPointType = vbSizeNESW
        'Center right
        Case 4: GetPointType = vbSizeWE
        'Bottom Right
        Case 5: GetPointType = vbSizeNWSE
        'Bottom center
        Case 6: GetPointType = vbSizeNS
        'Bottom left
        Case 7: GetPointType = vbSizeNESW
        'Center left
        Case 8: GetPointType = vbSizeWE
        'Default
        Case Else: GetPointType = vbDefault
    End Select
End Function