modshellsort.bas

很棒的网页音乐播放器,可以嵌入网页。界面很漂亮

Attribute VB_Name = "modShellSort"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/05/08
'描    述：另类自定义listview控件源码(支持真彩色图标)
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
'
'感谢您使用本站源码，如果方便的话请给于本站一点支持，谢谢。
'
'本站物品:
'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
'
'如果您给于本站一点支持，本站将更好的利用自身优势为您寻找您需要的代码!
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