Attribute VB_Name = "modShellSort"
'****************************************************************************
'人人為我，我為人人
'枕善居漢化收藏整理
'發(fā)布日期：2007/05/08
'描    述：另類自定義listview控件源碼(支持真彩色圖標(biāo))
'網(wǎng)    站：http://www.Mndsoft.com/  (VB6源碼博客)
'網(wǎng)    站：http://www.VbDnet.com/   (VB.NET源碼博客,主要基于.NET2005)
'e-mail  ：Mndsoft@163.com
'e-mail  ：Mndsoft@126.com
'OICQ    ：88382850
'          如果您有新的好的代碼別忘記給枕善居哦!
'****************************************************************************
'
'感謝您使用本站源碼，如果方便的話請(qǐng)給于本站一點(diǎn)支持，謝謝。
'
'本站物品:
'700MB容量的VB.NET源碼光盤(38元包快遞)
'支持支付寶交易:http://auction1.taobao.com/auction/0/item_detail-0db1-a8aba972995270433643e99d2e4ac592.jhtml
'也可以銀行匯款：http://www.mndsoft.com/sale/yh.png
'
'USB電腦遙控器 源碼光盤
'支持支付寶交易:http://auction1.taobao.com/auction/0/item_detail-0db1-dd4a9c3f6a5785231091b01d54af01fd.jhtml
'也可以銀行匯款：http://www.mndsoft.com/sale/yh.png
'
'如果您給于本站一點(diǎn)支持，本站將更好的利用自身優(yōu)勢(shì)為您尋找您需要的代碼!
Option Explicit

Public Enum eCompareResult
    crLess = -1&
    crEqual = 0&
    crGreater = 1&
End Enum

'VB lacks any support for procedure calling using an address, but the good ol'
'CallWindowProc will do just fine!
Private Declare Function CompareValues Lib "user32" Alias "CallWindowProcA" ( _
                            ByVal CompareFunc As Long, _
                            ByVal First As Long, _
                            ByVal Second As Long, _
                            ByVal unused1 As Long, _
                            ByVal unused2 As Long _
                         ) As eCompareResult

'General purpose CopyMemory, but optimized for our purposes using byval longs
'since we are working with pointers
Private Declare Sub CopyMemoryByVal Lib "kernel32" Alias "RtlMoveMemory" ( _
                        ByVal Dst As Long, _
                        ByVal Src As Long, _
                        ByVal ByteCount As Long _
                    )

Public Sub ShellSortAny(ByVal piArrPtr As Long, ByVal piElementCount As Long, ByVal piBytesPerElement As Integer, ByVal piCompareProcAddr As Long)
    Dim liDist          As Long
    Dim liDistBytes     As Long
    Dim liValuePtr      As Long
    Dim liBufferPtr     As Long
    Dim liPtr           As Long
    Dim liPtr2          As Long
    Dim liLastValuePtr  As Long
    
    Dim lyBuffer()      As Byte
    
    'Dim our buffer for enough bytes to hold one element
    ReDim lyBuffer(0 To piBytesPerElement - 1) As Byte
    'Get the pointer to the first element
    liBufferPtr = VarPtr(lyBuffer(0))

    'Find the initial value for liDist
    Do
        liDist = liDist + liDist + liDist + 1&
    Loop Until liDist > piElementCount
    
    'get the last valid pointer
    liLastValuePtr = piArrPtr + piElementCount * piBytesPerElement - piBytesPerElement
    
    Do
        'Reduce liDist by two thirds
        liDist = liDist \ 3
        'Get the number of bytes
        liDistBytes = liDist * piBytesPerElement
        
        'Loop through each pointer in our current section
        For liValuePtr = piArrPtr + liDistBytes To liLastValuePtr Step piBytesPerElement
            'Compare the current value with the immediately previous value, to see if they're in the correct order
            If CompareValues(piCompareProcAddr, liValuePtr - liDistBytes, liValuePtr, 0&, 0&) = crGreater Then
                'If the wrong order, then copy the current value to the buffer
                CopyMemoryByVal liBufferPtr, liValuePtr, piBytesPerElement
                'Set our temp pointer to the current value
                liPtr = liValuePtr
                'Set the other temp pointer to the beginning of the section
                liPtr2 = liPtr - liDistBytes
                
                Do
                    'Copy the first value to the current value
                    CopyMemoryByVal liPtr, liPtr2, piBytesPerElement
                    'Adjust the pointers
                    liPtr = liPtr2
                    liPtr2 = liPtr2 - liDistBytes
                    'Make sure we're in-bounds
                    If liPtr2 < piArrPtr Then Exit Do
                    'Keep going as long as we're in order
                Loop While CompareValues(piCompareProcAddr, liPtr2, liBufferPtr, 0&, 0&) = crGreater
                'put the buffered value back in
                CopyMemoryByVal liPtr, liBufferPtr, piBytesPerElement
            End If
        Next
    Loop Until liDist = 1&
End Sub