ccontrolflatter.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 = "cControlFlater"
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"
Implements ISubclass

Private Enum EDrawStyle
    FC_DRAWNORMAL = 0
    FC_DRAWRAISED = 1
    FC_DRAWPRESSED = 2
    FC_DRAWDISABLED = 3
End Enum
Private Enum ECmdType
    CT_GENERAL = 0
    CT_COMBOBOX = 1
    CT_COMMANDBUTTON = 2
    CT_SCROLLBAR = 3
End Enum

Private Const WM_COMMAND = &H111
Private Const WM_PAINT = &HF
Private Const WM_SETFOCUS = &H7
Private Const WM_KILLFOCUS = &H8
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_TIMER = &H113
Private Const WM_ENABLE = &HA

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXHSCROLL = 21
Private Const SM_CXHTHUMB = 10
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor 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 Const PS_SOLID = 0
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const CBS_DROPDOWN = &H2&
Private Const CBS_DROPDOWNLIST = &H3&
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, lpsz2 As Any) As Long
Private Const CBN_CLOSEUP = 8
Private Const CB_GETDROPPEDSTATE = &H157
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Const GW_CHILD = 5
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long

Private m_hWnd As Long
Private m_hWndEdit As Long
Private m_hWndParent As Long
Private m_bSubclass As Boolean
Private m_bMouseOver As Boolean
Private m_bMouseDown As Boolean
Private m_bFocus As Boolean
Private m_bDisabled  As Boolean
Private m_cType As ECmdType

Public Sub Attach(ByRef objthis As Object)
    Dim lhWnd As Long
    
    pRelease
    
    On Error Resume Next
    lhWnd = objthis.hwnd
    If (Err.Number <> 0) Then
        Err.Raise vbObjectError + 1048 + 1, App.EXEName & ".cFlatControl", "Incorrect control type passed to 'Attach' parameter - must be a control with a hWnd property."
        Exit Sub
    End If
    
    Select Case TypeName(objthis)
    Case "CommandButton"
        m_cType = CT_COMMANDBUTTON
    
    Case "ComboBox"
        m_cType = CT_COMBOBOX
        m_hWndParent = GetParent(lhWnd)
    
    Case "ImageCombo"
        m_cType = CT_COMBOBOX
        m_hWndParent = lhWnd
        lhWnd = FindWindowEx(lhWnd, 0&, "ComboBox", ByVal 0&)
    
    Case "OwnerDrawComboList" 'NOT TESTED YET!!!
        m_cType = CT_COMBOBOX
        m_hWndParent = lhWnd
    
    Case "HScrollBar"
        m_cType = CT_SCROLLBAR
    
    Case Else
        lStyle = GetWindowLong(lhWnd, GWL_STYLE)
        If ((lStyle And CBS_DROPDOWN) = CBS_DROPDOWN) Or ((lStyle And CBS_DROPDOWNLIST) = CBS_DROPDOWNLIST) Then
            m_cType = CT_COMBOBOX
            m_hWndParent = lhWnd
        Else
            m_cType = CT_GENERAL
            With objthis
                .Move .Left + 2 * Screen.TwipsPerPixelX, .Top + 2 * Screen.TwipsPerPixelY, .width - 4 * Screen.TwipsPerPixelX, .height - 4 * Screen.TwipsPerPixelY
            End With
            m_hWndParent = GetParent(lhWnd)
        End If
    End Select
    
    pAttach lhWnd
End Sub

Private Sub pAttach(ByRef hWndA As Long)
    Dim lStyle As Long
    
    m_hWnd = hWndA
    If (m_hWnd <> 0) Then
        lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
        If (lStyle And CBS_DROPDOWN) = CBS_DROPDOWN Then
            m_hWndEdit = GetWindow(m_hWnd, GW_CHILD)
        End If
        AttachMessage Me, m_hWnd, WM_PAINT
        AttachMessage Me, m_hWnd, WM_SETFOCUS
        AttachMessage Me, m_hWnd, WM_KILLFOCUS
        AttachMessage Me, m_hWnd, WM_MOUSEMOVE
        AttachMessage Me, m_hWnd, WM_LBUTTONDOWN
        AttachMessage Me, m_hWnd, WM_LBUTTONUP
        AttachMessage Me, m_hWnd, WM_TIMER
        AttachMessage Me, m_hWnd, WM_ENABLE
        If (m_hWndEdit <> 0) Then
            AttachMessage Me, m_hWndEdit, WM_SETFOCUS
            AttachMessage Me, m_hWndEdit, WM_KILLFOCUS
            AttachMessage Me, m_hWndEdit, WM_MOUSEMOVE
        End If
        If m_cType = CT_COMBOBOX Then
            AttachMessage Me, m_hWndParent, WM_COMMAND
        End If
        m_bSubclass = True
    End If
End Sub

Private Sub pRelease()
    If m_bSubclass Then
        DetachMessage Me, m_hWnd, WM_PAINT
        DetachMessage Me, m_hWnd, WM_SETFOCUS
        DetachMessage Me, m_hWnd, WM_KILLFOCUS
        DetachMessage Me, m_hWnd, WM_MOUSEMOVE
        DetachMessage Me, m_hWnd, WM_LBUTTONDOWN
        DetachMessage Me, m_hWnd, WM_LBUTTONUP
        DetachMessage Me, m_hWnd, WM_TIMER
        DetachMessage Me, m_hWnd, WM_ENABLE
        If (m_hWndEdit <> 0) Then
            DetachMessage Me, m_hWndEdit, WM_SETFOCUS
            DetachMessage Me, m_hWndEdit, WM_KILLFOCUS
            DetachMessage Me, m_hWndEdit, WM_MOUSEMOVE
        End If
        If m_cType = CT_COMBOBOX Then
            DetachMessage Me, m_hWndParent, WM_COMMAND
        End If
    End If
    m_hWnd = 0
    m_hWndEdit = 0
    m_hWndParent = 0
End Sub

Private Sub OnTimer(ByVal bCheckMouse As Boolean)
    Dim bOver As Boolean
    Dim rcItem As RECT
    Dim PT As POINTAPI
    Dim lhWnd As Long
    
    If bCheckMouse Then
        bOver = True
        GetCursorPos PT
        lhWnd = WindowFromPoint(PT.x, PT.y)
        If lhWnd <> m_hWnd And lhWnd <> m_hWndEdit Then
            bOver = False
        End If
    End If
    
    If Not bOver Then
        KillTimer m_hWnd, 1
        m_bMouseOver = False
        DrawMe
    End If
End Sub

Private Sub Class_Terminate()
    pRelease
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
    ' N鉶 remover este coment醨io
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
    If (CurrentMessage = WM_TIMER) Then
        ISubclass_MsgResponse = emrPostProcess
    Else
        ISubclass_MsgResponse = emrPreprocess
    End If
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case iMsg
    Case WM_COMMAND
        If (m_hWnd = lParam) Then
            Select Case wParam \ &H10000
            Case CBN_CLOSEUP
                DrawMe
            End Select
        End If
    Case WM_PAINT
        DrawMe
    Case WM_ENABLE
        m_bDisabled = (IsWindowEnabled(m_hWnd) = 0)
        DrawMe
    Case WM_SETFOCUS
        m_bFocus = True
        DrawMe
    Case WM_KILLFOCUS
        m_bFocus = False
        DrawMe