clsadvancededit.cls

一款Grid表格控件源代码,非常棒.不下你一定会后悔

        .HiliteColor = &HCCCCCC
        .ThemeStyle = m_eThemeStyle
        If (m_lThemeColor > -1) Then
            .ThemeColor = m_lThemeColor
        End If
        If (m_lOffsetColor > -1) Then
            .HiliteColor = m_lOffsetColor
        End If
        .Create m_lHostHwnd, 282, 225, 64, 22, ecsCommandButton
        .Text = "Close"
    End With

    If (lImlHwnd > -1) Then
        Set m_cLbIcon = New clsODControl
        With m_cLbIcon
            .Name = "lblCellIcon"
            .BorderStyle ecbsNone
            .AutoBackColor = True
            .Create m_lHostHwnd, 189, 129, 21, 13, ecsLabel
            .Text = "Cell Icon"
            .AutoSize = True
        End With
        
        Set m_cPbDisplay = New clsODControl
        With m_cPbDisplay
            .Name = ""
            .BorderStyle ecbsThin
            .BackColor = vbWhite
            .Create m_lHostHwnd, 189, 141, 40, 34, ecsPictureBox
            '/* load current icon
            If (lIcnIndex > -1) Then
                EditLoadPicture lIcnIndex
            End If
        End With

        Set m_cBtScrollUp = New clsODControl
        With m_cBtScrollUp
            .Name = "cmdScrollUp"
            .HiliteColor = &HCCCCCC
            .ThemeStyle = m_eThemeStyle
            If (m_lThemeColor > -1) Then
                .ThemeColor = m_lThemeColor
            End If
            If (m_lOffsetColor > -1) Then
                .HiliteColor = m_lOffsetColor
            End If
            .Create m_lHostHwnd, 234, 141, 16, 16, ecsCommandButton
            .Text = Chr$(43)
        End With
        
        Set m_cBtScrollDwn = New clsODControl
        With m_cBtScrollDwn
            .Name = "cmdScrollDown"
            .HiliteColor = &HCCCCCC
            .ThemeStyle = m_eThemeStyle
            If (m_lThemeColor > -1) Then
                .ThemeColor = m_lThemeColor
            End If
            If (m_lOffsetColor > -1) Then
                .HiliteColor = m_lOffsetColor
            End If
            .Create m_lHostHwnd, 234, 160, 16, 16, ecsCommandButton
            .Text = Chr$(150)
        End With
    End If
    
    ComboAddColors
    ComboAddFonts
    
End Sub

Private Sub EditLoadPicture(ByVal lIcnIndex As Long)
'/* load icon into picturebox

Dim lWidth      As Long
Dim lHeight     As Long
Dim lImgCount   As Long

    If Not (m_lImlHwnd = -1) Then
        '/* get image count
        lImgCount = ImageList_GetImageCount(m_lImlHwnd)
        If (lIcnIndex > (lImgCount - 1)) Then
            m_lIconIndex = (lImgCount - 1)
        ElseIf m_lIconIndex < 0 Then
            m_lIconIndex = 0
        Else
            m_lIconIndex = lIcnIndex
        End If
        '/* clean up
        If Not (m_lhIcon = 0) Then
            EditDestroyIcon
        End If
        '/* create the icon copy
        m_lhIcon = ImageList_GetIcon(m_lImlHwnd, m_lIconIndex, 0&)
        If (m_lhIcon > 0) Then
            '/* get icon size
            ImageList_GetIconSize m_lImlHwnd, lWidth, lHeight
            '/* load to picturebox
            m_cPbDisplay.PictureBoxLoadImage m_lhIcon, m_eImageType, lWidth, lHeight
        End If
    End If

End Sub

Private Sub EditDestroyIcon()
'/* destroy icon copy

    If Not (m_lhIcon = 0) Then
        DestroyIcon m_lhIcon
        m_lhIcon = 0
    End If

End Sub

Private Sub ComboAddFonts()
'/* add font list and icons

Dim lCt     As Long
Dim lHdc    As Long
Dim lTtHnd  As Long
Dim lRtHnd  As Long
Dim vFont   As Variant

    '/* get system icon handles
    lRtHnd = SystemIconHandle(".FON", eisSmallIcon)
    lTtHnd = SystemIconHandle(".TTF", eisSmallIcon)
    With m_cCbFontSelect
        '/* init ods imagelist
        .InitListBoxIml 14, 14
        '/* add the icons
        .ImlListBoxAddIcon lRtHnd
        .ImlListBoxAddIcon lTtHnd
    End With
    '/* get the system fonts list
    lHdc = GetDC(m_lParentHwnd)
    vFont = EnumSystemFonts(lHdc)
    ReleaseDC m_lParentHwnd, lHdc
    '/* add font list to combo
    For lCt = 0 To UBound(vFont, 2)
        Select Case vFont(1, lCt)
        Case 0, 1
            m_cCbFontSelect.AddItem vFont(0, lCt), 0
        Case Else
            m_cCbFontSelect.AddItem vFont(0, lCt), 1
        End Select
    Next lCt
    
End Sub

Private Sub ComboAddColors()
'/* load combo color list

Dim lCt     As Long
Dim sColor  As String
Dim sClr()  As String

On Error Resume Next

    '/* split color const
    sColor = CLRYELLOW & CLRMAGENTA & CLRCYAN & CLRBLUE & CLRRED & CLRGREEN & CLRGREY
    sClr = Split(sColor, Chr$(32))
    '/* add to lists
    For lCt = 0 To UBound(sClr)
        m_cCbBackColor.AddItem sClr(lCt), , CLng(sClr(lCt))
        m_cCbFontColor.AddItem sClr(lCt), , CLng(sClr(lCt))
    Next lCt

On Error GoTo 0

End Sub

Private Function ComboExtendedColors() As Long
'/* launch color dialog

Dim lRet        As Long
Dim lCust()    As Long

    ReDim lCust(15)
    lCust(0) = &HFFFFFF
    lRet = ShowColorDialog(m_lParentHwnd, &HFFFFFF, lCust, 1)
    If Not (lRet = -1) Then
        ComboExtendedColors = lRet
    End If

End Function

Private Sub CreateWindow()
'/* create api window

Dim lTTStyle As Long
Dim sTitle   As String

    '/* style constants
    lTTStyle = WS_CLIPSIBLINGS Or WS_SYSMENU Or HDS_FLAT Or WS_CLIPCHILDREN
    sTitle = "Advanced Edit"
    '/* create tool/header window
    If m_bIsNt Then
        m_lHostHwnd = CreateWindowExW(WS_EX_TOOLWINDOW, StrPtr("SysHeader32"), StrPtr(sTitle), lTTStyle, _
            0&, 0&, 0&, 0&, m_lParentHwnd, 0, App.hInstance, ByVal 0&)
    Else
        m_lHostHwnd = CreateWindowExA(WS_EX_TOOLWINDOW, "SysHeader32", sTitle, lTTStyle, _
            0&, 0&, 0&, 0&, m_lParentHwnd, 0, App.hInstance, ByVal 0&)
    End If

End Sub

Private Function CompatabilityCheck() As Boolean
'/* nt version check

Dim tVer As VERSIONINFO

    tVer.dwOSVersionInfoSize = Len(tVer)
    GetVersionEx tVer
    If tVer.dwMajorVersion >= 5 Then
        CompatabilityCheck = True
    End If

End Function

Private Sub SetPosition(ByVal lHwnd As Long, _
                        ByRef tRect As RECT)

'/* show window

    If Not (m_lHostHwnd = 0) Then
        With tRect
            SetWindowPos lHwnd, 0&, .Left, .Top, .Right, .bottom, SWP_SHOWWINDOW
        End With
    End If

End Sub

Private Sub Attach()
'/* attach subclasser

    If Not (m_lHostHwnd = 0) Then
        Set m_cHostSubclass = New GXMSubclass
        With m_cHostSubclass
            .Subclass m_lHostHwnd, Me
            .AddMessage m_lHostHwnd, WM_CLOSE, MSG_AFTER
        End With
    End If
    
End Sub

Private Sub Detach()
'/* detach subclasser

    If Not m_cHostSubclass Is Nothing Then
        With m_cHostSubclass
            .DeleteMessage m_lHostHwnd, WM_CLOSE, MSG_AFTER
            .UnSubclass m_lHostHwnd
        End With
        Set m_cHostSubclass = Nothing
    End If
    
End Sub

Private Sub GXISubclass_WndProc(ByVal bBefore As Boolean, _
                                bHandled As Boolean, _
                                lReturn As Long, _
                                ByVal lHwnd As Long, _
                                ByVal uMsg As eMsg, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long, _
                                lParamUser As Long)
    
    '/* signal window termination to parent
    If (uMsg = WM_CLOSE) Then
        RaiseEvent DestroyMe
    End If
    
End Sub


'> Cleanup
'>>>>>>>>>>>>>>>>
Private Sub DestroyHost()
'/* destroy host window

    '/* detach subclasser
    Detach
    '/* destroy window
    If Not m_lHostHwnd = 0 Then
        DestroyWindow m_lHostHwnd
        m_lHostHwnd = 0
        m_bShowing = False
    End If
    
End Sub

Public Sub DestroyEditBox()
'/* cleanup
    
    EditDestroyIcon
    If Not m_cTxEditBox Is Nothing Then Set m_cTxEditBox = Nothing
    If Not m_cTxSize Is Nothing Then Set m_cTxSize = Nothing
    
    If Not m_cPbDisplay Is Nothing Then Set m_cPbDisplay = Nothing
    
    If Not m_cCbBackColor Is Nothing Then Set m_cCbBackColor = Nothing
    If Not m_cCbFontSelect Is Nothing Then Set m_cCbFontSelect = Nothing
    If Not m_cCbFontColor Is Nothing Then Set m_cCbFontColor = Nothing
    
    If Not m_cBtFontBold Is Nothing Then Set m_cBtFontBold = Nothing
    If Not m_cBtFontItalic Is Nothing Then Set m_cBtFontItalic = Nothing
    If Not m_cBtFontStrike Is Nothing Then Set m_cBtFontStrike = Nothing
    If Not m_cBtFontUnderline Is Nothing Then Set m_cBtFontUnderline = Nothing
    If Not m_cBtClose Is Nothing Then Set m_cBtClose = Nothing
    If Not m_cBtSave Is Nothing Then Set m_cBtSave = Nothing
    If Not m_cBtScrollUp Is Nothing Then Set m_cBtScrollUp = Nothing
    If Not m_cBtScrollDwn Is Nothing Then Set m_cBtScrollDwn = Nothing
    
    If Not m_cLbIcon Is Nothing Then Set m_cLbIcon = Nothing
    If Not m_cLbFontSelect Is Nothing Then Set m_cLbFontSelect = Nothing
    If Not m_cLbFontColor Is Nothing Then Set m_cLbFontColor = Nothing
    If Not m_cLbBackColor Is Nothing Then Set m_cLbBackColor = Nothing
    If Not m_cLbSize Is Nothing Then Set m_cLbSize = Nothing
    If Not m_oFont Is Nothing Then Set m_oFont = Nothing
    DestroyHost

End Sub

Private Sub Class_Terminate()
    DestroyEditBox
End Sub