VB6 Sorting - Dont know if anyone still has problems but this may be a solution

VB6 Sorting (AlpahNumeric, Numeric, Alpha, Date, Localized formats, anything)

VB6 - Sorting in VB6 Example of a correct sort
VB6 - Sorting using mCol Collection in a Class

Accurate for all data types

Assume the following was sorted - the correct sort for AlphaNumeric has always been an issue a result set should be as follows

e.g. 1,2,3,5,11,1B,1C,10,12,12RS1,15,80,100,A000,8190,B1290,S2389,100002

Although you normally get something like: 1,10,100,12,15,6,600,6001,7,8,900,90012,1001010

A UCase statement forces all text to upper in the sort - no conversion back is performed but it was desired over the default mixed case.

Code:

---

'
'This Sort uses the following methods and ideas
'
'The is a VB6 form with a Grid and you have an event HeadClick on the grid
'A result set or some data has been place in a collection as referenced in CRequests.cls (listed below)
'A Class module is created as or like CRequests.CLS with Add, Count, Item, Remove.
'Only Sort is displayed in this example not Add, Item, Remove, etc...
'A Module is created to hold the common Sort modSort.bas which contains all necessary references.
'
'
'
'So you need to end up with ...
'
'----- Your form with your grid and the grid head click event
'----- Your Class with your Sort and your implied collection
'
'              The collection is implied when you place
'
'
'                This at the top of your form "Private mMyRequests As New CRequests"
'              This at the top of your Class file "Private mCol As Collection"
'                This at the top of your class "Private mCol As Collection"
'               
'                And paste the modSort.bas listed below into modSort.bas
'
'===================================

'Place this in the following file in your form: NameOfYourForm.bas
'
'NameOfYourForm.bas
'
'
'It is assumed that you have a form with a grid and want to perform a Sort
'The following are in 3 parts
'

'Calling routine - a VB6 form with a grid named "grdRequestList"
'This is the head click event'
'The object mMyRequest is part of CRequests.cls Class file
'This class contains methods for Add, Remove, Count, Item - not included - only Sort
'
'
'
Private Sub grdRequestList_HeadClick(ByVal ColIndex As Integer)

1      mbHeadingClicked = True

2      If mMyRequests.Count = 0 Then GoTo ExitRoutine
4      miLastSortColIndex = ColIndex
5      mbaAscending(miLastSortColIndex) = Not mbaAscending(miLastSortColIndex)
6      Call mMyRequests.Sort(miLastSortColIndex, mbaAscending(miLastSortColIndex))
7      grdRequestList.ReBind

End Sub






'===================================
'Place this in the following file Crequests.cls
'
'Crequests.cls
'Crequests.cls
'
'This file is referenced in the grid head click call to the sort as listed above
'
'This class contains methods for Add, Remove, Count, Item, & Sort
'Only Sort is included here as the others are more along the lines normally followed
'
'Since this is all supposed to be part of one example you have to read from the beginning
'
'===================================
'
Private mCol As Collection

Public Function Sort(ByVal viClickedColumn As Integer, ByVal vbAscendingFlag As Boolean) As Collection

Const sPROCEDURE As String = "Sort"

Dim bColumnContainsItems As Boolean
Dim oOldCollection As Collection
Dim oItem As CDestructionRequest
Dim SortArray() As SortStruct
Dim iCnt, i, j  As Integer
Dim iBytes As Integer

1      If mCol.Count < 2 Then GoTo ExitRoutine
2      iCnt = mCol.Count
3      ReDim SortArray(1 To iCnt)
4      Set oItem = New CDestructionRequest
5      bColumnContainsItems = False

6      For i = 1 To iCnt
7          Set oItem = mCol.Item(i)
8          SortArray(i).Index = i
9          SortArray(i).value = vbNullString

10          With oItem

11              Select Case viClickedColumn
                    Case mDCOL_CUSTOMER_NUMBER
12                      SortArray(i).value = AddPaddingCharacters(gCUSTOMERCODE_L, .sCustomerNumber)
13                      SortArray(i).value = SortArray(i).value & ConvertToHex(10, .lDestructRequestId)
14                  Case mDCOL_REQUEST_STATUS
15                      SortArray(i).value = AddPaddingCharacters(gDESCRSHORT_L, .sRequestStatusDescr)
22                  Case mDCOL_AUTHORIZED_BY
23                      If .lRequestStatusId >= eDestructRequestStatus.edrsAuthorized Then
24                          SortArray(i).value = AddPaddingCharacters(gFULLNAME_L, .sAuthorizedByPersonnelName)
25                      End If

26                  Case mDCOL_REQUESTED_DATE
27                      SortArray(i).value = Format$(.sRequestedDate, goIMDateFormat.sISODateFormat)
28                  Case mDCOL_PICKPICKUP_DATE
29                      SortArray(i).value = Format$(.sCompletedDate, goIMDateFormat.sISODateFormat)
30                  Case Else
31                      Err.Raise gINTERNAL, , ""
32              End Select

33              If Len(Trim(SortArray(i).value)) > 0 Then
34                  bColumnContainsItems = True
35              End If

36          End With

37      Next

        'Only sort if there were items in the column else do nothing and exit
        'There may be artifacts left from the last Sort we want to ignore
        'If we do not do this some sorting will result although all we have are null string
38      If bColumnContainsItems Then
            'mcol is implied in the call used to this Sort as its part of the class
39          Set oOldCollection = mCol
40          Set mCol = New Collection
41          iBytes = VarPtr(SortArray(2)) - VarPtr(SortArray(1))
42          ShellSort VarPtr(SortArray(1)), iCnt, iBytes, AddressOf CompareSortStruct, CLng(vbAscendingFlag)
            'While our shell sort returns the array as sorted by Hex we use the index into our collection
            'in order to perform the Sort so no conversion back is necessary
43          For i = 1 To iCnt
44              Set oItem = oOldCollection.Item(SortArray(i).Index)
45              Add CStr(oItem.lDestructRequestId), oItem
46          Next i

47      End If

    ExitRoutine:

End Function






'===================================
'Place this in the following file modSort.bas
'
'modSort.bas
'modSort.bas

'
'This file takes the string passed in from the calling form which calls the .Sort routine in the Class
'and passes the collection as an implicit part of the class - the base collection available to the form
'
'Since this is all supposed to be part of one example you have to read from the beginning
'
'===================================

Option Explicit

Public Type CustByIDType
    ID As Long
    Code As String
End Type

Public Type SortStruct
    Index As Integer
    value As Variant
End Type


Declare Sub CopyMemoryByVal Lib "kernel32" Alias "RtlMoveMemory" (ByVal dest As Long, ByVal Source As Long, _
            ByVal numBytes As Long)

Declare Function CompareValues Lib "user32" Alias "CallWindowProcA" (ByVal CompareFunc As Long, ByVal FIRST As Long, _
            ByVal SECOND As Long, DescendingFlag As Long, ByVal unused2 As Long) As Integer


Sub ShellSort(ByVal arrPtr As Long, ByVal numEls As Long, ByVal elSize As Integer, ByVal compProcAddr As Long, _
        Optional AscendingFlag As Boolean = True)

Dim dist As Long
Dim distBytes As Long
Dim valuePtr As Long
Dim bufPtr As Long
Dim ptr As Long
Dim ptr2 As Long

1      ReDim Buffer(elSize - 1) As Byte

2      bufPtr = VarPtr(Buffer(0))
3      Do
4          dist = dist * 3 + 1
5      Loop Until dist > numEls

        'shell sort - using pointers
6      Do
7          dist = dist \ 3
8          distBytes = dist * elSize
9          For valuePtr = arrPtr + distBytes To arrPtr + (numEls - 1) * elSize Step elSize
10              If CompareValues(compProcAddr, valuePtr - distBytes, valuePtr, CLng(AscendingFlag), 0) > 0 Then
11                  CopyMemoryByVal bufPtr, valuePtr, elSize
12                  ptr = valuePtr
13                  ptr2 = ptr - distBytes
14                  Do
15                      CopyMemoryByVal ptr, ptr2, elSize
16                      ptr = ptr2
17                      ptr2 = ptr2 - distBytes
18                      If ptr2 < arrPtr Then Exit Do
19                  Loop While CompareValues(compProcAddr, ptr2, bufPtr, CLng(AscendingFlag), 0) > 0
20                  CopyMemoryByVal ptr, bufPtr, elSize
21              End If
22          Next
23      Loop Until dist = 1

End Sub




Public Function AddPaddingCharacters(ByVal iObjectLength As Integer, _
                    ByVal sSortValue As String, _
                    Optional ByVal iSortType As Integer) As String

Dim sOurPaddedReturnString As String
Dim lAsciiPaddingValue As Long

        lAsciiPaddingValue = 32 ' Space
        If (Not IsNumeric(sSortValue)) Then
            sOurPaddedReturnString = RTrim((sSortValue)) & String(iObjectLength - Len(RTrim((sSortValue))), Chr(lAsciiPaddingValue))
        Else
            sOurPaddedReturnString = String(iObjectLength - Len(LTrim((sSortValue))), Chr(lAsciiPaddingValue)) & LTrim((sSortValue))
        End If

        'UCase might introduce what seems like an error with upper and lowercase but was selected over results ending up with
        'all upper letters at in the beginning and lowercase all at the end
        AddPaddingCharacters = UCase(sOurPaddedReturnString)


End Function

---