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


DevX Home    Today's Headlines   Articles Archive   Tip Bank   Forums   

Results 1 to 1 of 1

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

Threaded View

  1. #1
    Join Date
    Nov 2008
    Posts
    2

    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
    Last edited by JSpyder; 11-10-2008 at 10:10 PM. Reason: Minor corrections to documentation

Similar Threads

  1. Speaking of strings...
    By Harlow in forum .NET
    Replies: 246
    Last Post: 10-26-2002, 01:30 AM
  2. Will VB.NET be more stable than VB6?
    By Jason in forum .NET
    Replies: 125
    Last Post: 10-05-2002, 05:34 PM
  3. Quiz for MM
    By Patrick Troughton in forum .NET
    Replies: 187
    Last Post: 09-11-2002, 12:22 PM
  4. Replies: 1
    Last Post: 03-11-2002, 10:01 AM
  5. XML solution for session(s)
    By Sean in forum ASP.NET
    Replies: 1
    Last Post: 10-31-2000, 11:06 AM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
HTML5 Development Center
 
 
FAQ
Latest Articles
Java
.NET
XML
Database
Enterprise
Questions? Contact us.
C++
Web Development
Wireless
Latest Tips
Open Source


   Development Centers

   -- Android Development Center
   -- Cloud Development Project Center
   -- HTML5 Development Center
   -- Windows Mobile Development Center