Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ownrdclb/cshsort.cls

Visual Basic class definition | 1998-01-28 | 11.0 KB | 329 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cShellSort"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

' =================================================================
' Class:    cShellSort
' Author:   SPM, PACG
' Date:     1 Feb 1997
'
' Shell sorts a variant array according to a given
' column, using numeric, string or date type, ascending
' or descending.
'
' =================================================================
Public Enum ESSTypeConstants
    CCLSortNumeric = 1
    CCLSortString = 2
    CCLSortDate = 4
End Enum
Public Enum ESSOrderCOnstants
    CCLOrderAscending = 1
    CCLOrderDescending = 2
End Enum

Private m_iSortColumn() As Integer
Private m_eSortOrder() As ESSOrderCOnstants
Private m_eSortType() As ESSTypeConstants
Private m_iSortIndexCount As Integer
Private m_iLastSortIndex As Integer
Public Sub Clear()
    m_iSortIndexCount = 0
    Erase m_iSortColumn
    Erase m_eSortOrder
    Erase m_eSortType
End Sub
Property Get LastSortIndex() As Integer
    LastSortIndex = m_iLastSortIndex
End Property
Property Let LastSortIndex( _
        ByVal iLastSortIndex As Integer _
    )
    m_iLastSortIndex = iLastSortIndex
End Property
Property Let SortCOlumn( _
        ByVal iSortIndex As Integer, _
        ByVal iSortColumn As Integer _
    )
    If (pbValidSortIndex(iSortIndex)) Then
        m_iSortColumn(iSortIndex) = iSortColumn
    End If
End Property
Property Get SortCOlumn( _
        ByVal iSortIndex As Integer _
    ) As Integer
    SortCOlumn = m_iSortColumn(iSortIndex)
End Property
Property Let SortOrder( _
        ByVal iSortIndex As Integer, _
        ByVal iSortOrder As ESSOrderCOnstants _
    )
    If (pbValidSortIndex(iSortIndex)) Then
        m_eSortOrder(iSortIndex) = iSortOrder
    End If
End Property
Property Get SortOrder( _
        ByVal iSortIndex As Integer _
    ) As ESSOrderCOnstants
    SortOrder = m_eSortOrder(iSortIndex)
End Property
Property Get SortType( _
        ByVal iSortIndex As Integer _
    ) As ESSTypeConstants
    SortType = m_eSortType(iSortIndex)
End Property
Property Let SortType( _
        ByVal iSortIndex As Integer, _
        ByVal eSortType As ESSTypeConstants _
    )
    If (pbValidSortIndex(iSortIndex)) Then
        m_eSortType(iSortIndex) = eSortType
    End If
End Property
Private Function pbValidSortIndex( _
        ByVal iSortIndex As Integer _
    ) As Boolean
    If (iSortIndex > 0) And (iSortIndex < 4) Then
        If (iSortIndex > m_iSortIndexCount) Then
            m_iSortIndexCount = iSortIndex
            ReDim Preserve m_iSortColumn(1 To m_iSortIndexCount) As Integer
            ReDim Preserve m_eSortOrder(1 To m_iSortIndexCount) As ESSOrderCOnstants
            ReDim Preserve m_eSortType(1 To m_iSortIndexCount) As ESSTypeConstants
        End If
        pbValidSortIndex = True
    Else
        Err.Raise vbObjectError + 1048 + 1, App.EXEName & ".cShellSort", "Invalid sort array index."
    End If
End Function

Public Sub SortItems( _
        ByRef vItems() As Variant _
    )
Dim iSwapIndex As Integer
Dim iIncrement As Integer
Dim iMainLoop As Integer
Dim iSubLoop As Integer
Dim vSortItem() As Variant
Dim iItemCount As Integer
Dim iCol As Integer
Dim iColumns As Integer

    iColumns = UBound(vItems, 1)
    iItemCount = UBound(vItems, 2)

    ' Shell sort the list:
    ' ========================================================
    ' Implementation of Shell Sort algorithm using
    ' + 1 * 3 increment.
    ' ========================================================
    ' Prepare swap space storage:
    ReDim vSortItems(1 To iColumns)
    ' Get inital shell sort increment
    If (iItemCount > 1) Then
        iIncrement = piGetSuitableShellSortInitialIncrement(iItemCount)
        Do Until iIncrement < 1
            For iMainLoop = iIncrement + 1 To iItemCount
                ' Store iMainLoop in vSortItems():
                For iCol = 1 To iColumns
                    vSortItems(iCol) = vItems(iCol, iMainLoop)
                Next iCol
                ' Loop form MainLoop-Increment to 0
                For iSubLoop = (iMainLoop - iIncrement) To 1 Step -iIncrement
                    If (pbGreater(vItems(), vSortItems, iSubLoop)) Then
                        Exit For
                    End If
                    For iCol = 1 To iColumns
                        vItems(iCol, (iSubLoop + iIncrement)) = vItems(iCol, iSubLoop)
                    Next iCol
                Next iSubLoop
                For iCol = 1 To iColumns
                    vItems(iCol, (iSubLoop + iIncrement)) = vSortItems(iCol)
                Next iCol
            Next iMainLoop
            ' Get next shell sort increment value:
            iIncrement = iIncrement - 1
            iIncrement = iIncrement \ 3
        Loop
    Else
        ' For only two items just check whether the second should
        ' be swapped with the first:
        If (iItemCount > 1) Then
            If (pbGreater(vItems(), vSortItems, iSubLoop)) Then
                For iCol = 0 To iColumns
                    vSortItems(iCol) = vItems(iCol, 0)
                    vItems(iCol, 0) = vItems(iCol, 1)
                Next iCol
                For iCol = 0 To iColumns
                    vItems(iCol, 1) = vSortItems(iCol)
                Next iCol
            End If
        End If
    End If
    'm_iLastSortIndex = m_iSortColumn

End Sub
Public Sub SortGridItems( _
        ByRef vItems() As Variant, _
        ByRef bEnable() As Boolean _
    )
Dim iSwapIndex As Integer
Dim iIncrement As Integer
Dim iMainLoop As Integer
Dim iSubLoop As Integer
Dim vSortItem() As Variant
Dim bEnableItems() As Boolean
Dim iItemCount As Integer
Dim iCol As Integer
Dim iColumns As Integer

    iColumns = UBound(vItems, 1)
    iItemCount = UBound(vItems, 2)

    ' Shell sort the list:
    ' ========================================================
    ' Implementation of Shell Sort algorithm using
    ' + 1 * 3 increment.
    ' ========================================================
    ' Prepare swap space storage:
    ReDim vSortItems(1 To iColumns) As Variant
    ReDim bEnableItems(1 To iColumns) As Boolean
    ' Get inital shell sort increment
    If (iItemCount > 1) Then
        iIncrement = piGetSuitableShellSortInitialIncrement(iItemCount)
        Do Until iIncrement < 1
            For iMainLoop = iIncrement + 1 To iItemCount
                ' Store iMainLoop in vSortItems():
                For iCol = 1 To iColumns
                    vSortItems(iCol) = vItems(iCol, iMainLoop)
                    bEnableItems(iCol) = bEnable(iCol, iMainLoop)
                Next iCol
                ' Loop from MainLoop-Increment to 0
                For iSubLoop = (iMainLoop - iIncrement) To 1 Step -iIncrement
                    If (pbGreater(vItems(), vSortItems, iSubLoop)) Then
                        Exit For
                    End If
                    For iCol = 1 To iColumns
                        vItems(iCol, (iSubLoop + iIncrement)) = vItems(iCol, iSubLoop)
                        bEnable(iCol, (iSubLoop + iIncrement)) = bEnable(iCol, iSubLoop)
                    Next iCol
                Next iSubLoop
                For iCol = 1 To iColumns
                    vItems(iCol, (iSubLoop + iIncrement)) = vSortItems(iCol)
                    bEnable(iCol, (iSubLoop + iIncrement)) = bEnableItems(iCol)
                Next iCol
            Next iMainLoop
            ' Get next shell sort increment value:
            iIncrement = iIncrement - 1
            iIncrement = iIncrement \ 3
        Loop
    Else
        ' For only two items just check whether the second should
        ' be swapped with the first:
        If (iItemCount > 1) Then
            If (pbGreater(vItems(), vSortItems, iSubLoop)) Then
                For iCol = 1 To iColumns
                    vSortItems(iCol) = vItems(iCol, 0)
                    vItems(iCol, 0) = vItems(iCol, 1)
                    bEnableItems(iCol) = bEnable(iCol, 0)
                    bEnable(iCol, 0) = bEnable(iCol, 1)
                Next iCol
                For iCol = 1 To iColumns
                    vItems(iCol, 1) = vSortItems(iCol)
                    bEnable(iCol, 1) = bEnableItems(iCol)
                Next iCol
            End If
        End If
    End If
    'm_iLastSortIndex = m_iSortColumn

End Sub

Private Function pbGreater( _
        ByRef vItems() As Variant, _
        ByRef vSortItems As Variant, _
        ByVal iSubLoop As Integer _
    ) As Boolean
Dim iSortIndex As Integer
Dim bIsEqual As Boolean
Dim bR As Boolean

    For iSortIndex = 1 To m_iSortIndexCount
        bR = pbIsGreater(vSortItems(m_iSortColumn(iSortIndex)), vItems(m_iSortColumn(iSortIndex), iSubLoop), iSortIndex, bIsEqual)
        If (iSortIndex < m_iSortIndexCount) And bIsEqual Then
            ' Must go to the next one
        Else
            pbGreater = bR
            Exit For
        End If
    Next iSortIndex

End Function
Private Function pbIsGreater( _
        ByRef vSortItem As Variant, _
        ByRef vItem As Variant, _
        ByVal iSortIndex As Integer, _
        ByRef bIsEqual As Boolean _
    ) As Boolean
Dim vR As Variant
Dim lR As Long

    Select Case m_eSortType(iSortIndex)
    Case CCLSortNumeric
        vR = Val(vSortItem - vItem)
        bIsEqual = (vR = 0)
        If (m_eSortOrder(iSortIndex) = CCLOrderAscending) Then
            pbIsGreater = (vR >= 0)
        Else
            pbIsGreater = (vR <= 0)
        End If
    Case CCLSortString
        lR = StrComp(vSortItem, vItem)
        bIsEqual = (lR = 0)
        If (m_eSortOrder(iSortIndex) = CCLOrderAscending) Then
            pbIsGreater = (lR > -1)
        Else
            pbIsGreater = (lR < 1)
        End If
    Case CCLSortDate
        bIsEqual = (vSortItem = vItem)
        If Not (bIsEqual) Then
            If (m_eSortOrder(iSortIndex) = CCLOrderAscending) Then
                pbIsGreater = (vSortItem >= vItem)
            Else
                pbIsGreater = (vItem >= vSortItem)
            End If
        Else
            pbIsGreater = True
        End If
    End Select

End Function
Private Function piGetSuitableShellSortInitialIncrement( _
        iSortSize As Integer _
    ) As Integer
' ==============================================================
' Part of the implementation of Shell Sort algorithm using
' + 1 * 3 increment strategy.  This function returns the
' largest increment based on +1*3 which is less than the
' sort size.
' ==============================================================
Dim iRet As Integer
Dim iLastRet As Integer
    iLastRet = 1
    iRet = 1
    Do While iRet < iSortSize
        iLastRet = iRet
        iRet = iRet * 3 + 1
    Loop
    piGetSuitableShellSortInitialIncrement = iLastRet
End Function