bas_via1.bas

VB写的一个IDE开发环境,支持脚本运行,内置了一个简单的编译器,可以直接生成EXE.. 推荐下载!

Attribute VB_Name = "Bas_Via1"

Option Base 0
Option Compare Text
Private Const QTHRESH As Long = 7
Private Const MinLong As Long = &H80000000
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Sub SwapStrings(String1 As String, String2 As String)
    Static SwpVal As Long
    CopyMemory SwpVal, ByVal VarPtr(String1), 4
    CopyMemory ByVal VarPtr(String1), ByVal VarPtr(String2), 4
    CopyMemory ByVal VarPtr(String2), SwpVal, 4
End Sub
Private Sub SwapLong(a As Long, b As Long)
    Static c As Long
    c = a
    a = b
    b = c
End Sub
Public Sub SortStringArray(TheArray() As String, Optional LowerBound As Long = MinLong, Optional UpperBound As Long = MinLong)
    Dim f          As Long
    Dim g          As Long
    Dim h          As Long
    Dim i          As Long
    Dim j          As Long
    Dim s(1 To 64) As Long
    Dim t          As Long
    Dim swp        As String
    If LowerBound = MinLong Then f = LBound(TheArray) Else f = LowerBound
    If UpperBound = MinLong Then g = UBound(TheArray) Else g = UpperBound
    t = 0
    Do
        If g - f < QTHRESH Then
            For j = f + 1 To g
                CopyMemory ByVal VarPtr(swp), ByVal VarPtr(TheArray(j)), 4
                For i = j - 1 To f Step -1
                    If TheArray(i) <= swp Then Exit For
                    CopyMemory ByVal VarPtr(TheArray(i + 1)), ByVal VarPtr(TheArray(i)), 4
                Next i
                CopyMemory ByVal VarPtr(TheArray(i + 1)), ByVal VarPtr(swp), 4
            Next j
            If t = 0 Then Exit Do
            g = s(t)
            f = s(t - 1)
            t = t - 2
        Else
            h = (f + g) \ 2
            SwapStrings TheArray(h), TheArray(f + 1)
            If TheArray(f) > TheArray(g) Then SwapStrings TheArray(f), TheArray(g)
            If TheArray(f + 1) > TheArray(g) Then SwapStrings TheArray(f + 1), TheArray(g)
            If TheArray(f) > TheArray(f + 1) Then SwapStrings TheArray(f), TheArray(f + 1)
            i = f + 1
            j = g
            CopyMemory ByVal VarPtr(swp), ByVal VarPtr(TheArray(f + 1)), 4
            Do
                Do
                  i = i + 1
                Loop While TheArray(i) < swp
                Do
                    j = j - 1
                Loop While TheArray(j) > swp
                If j < i Then Exit Do
                SwapStrings TheArray(i), TheArray(j)
            Loop
            CopyMemory ByVal VarPtr(TheArray(f + 1)), ByVal VarPtr(TheArray(j)), 4
            CopyMemory ByVal VarPtr(TheArray(j)), ByVal VarPtr(swp), 4
            t = t + 2
            If g - i + 1 >= j - f Then
                s(t) = g
                s(t - 1) = i
                g = j - 1
            Else
                s(t) = j - 1
                s(t - 1) = f
                f = i
            End If
        End If
    Loop
    CopyMemory ByVal VarPtr(swp), 0&, 4
End Sub
Public Sub SortLongArray(TheArray() As Long, Optional LowerBound As Long = MinLong, Optional UpperBound As Long = MinLong)
    Dim f          As Long
    Dim g          As Long
    Dim h          As Long
    Dim i          As Long
    Dim j          As Long
    Dim s(1 To 64) As Long
    Dim t          As Long
    Dim swp        As Long
    If LowerBound = MinLong Then f = LBound(TheArray) Else f = LowerBound
    If UpperBound = MinLong Then g = UBound(TheArray) Else g = UpperBound
    t = 0
    Do
        If g - f < QTHRESH Then
            For j = f + 1 To g
                swp = TheArray(j)
                For i = j - 1 To f Step -1
                    If TheArray(i) <= swp Then Exit For
                    TheArray(i + 1) = TheArray(i)
                Next i
                TheArray(i + 1) = swp
            Next j
            If t = 0 Then Exit Do
            g = s(t)
            f = s(t - 1)
            t = t - 2
        Else
            h = (f + g) \ 2
            SwapLong TheArray(h), TheArray(f + 1)
            If TheArray(f) > TheArray(g) Then SwapLong TheArray(f), TheArray(g)
            If TheArray(f + 1) > TheArray(g) Then SwapLong TheArray(f + 1), TheArray(g)
            If TheArray(f) > TheArray(f + 1) Then SwapLong TheArray(f), TheArray(f + 1)
            i = f + 1
            j = g
            swp = TheArray(f + 1)
            Do
                Do
                  i = i + 1
                Loop While TheArray(i) < swp
                Do
                    j = j - 1
                Loop While TheArray(j) > swp
                If j < i Then Exit Do
                SwapLong TheArray(i), TheArray(j)
            Loop
            TheArray(f + 1) = TheArray(j)
            TheArray(j) = swp
            t = t + 2
            If g - i + 1 >= j - f Then
                s(t) = g
                s(t - 1) = i
                g = j - 1
            Else
                s(t) = j - 1
                s(t - 1) = f
                f = i
            End If
        End If
    Loop
End Sub
Public Sub SortStringIndexArray(TheArray() As String, TheIndex() As Long, Optional LowerBound As Long = MinLong, Optional UpperBound As Long = MinLong)
    Dim f          As Long
    Dim g          As Long
    Dim h          As Long
    Dim i          As Long
    Dim j          As Long
    Dim s(1 To 64) As Long
    Dim t          As Long
    Dim swp        As String
    Dim indxt      As Long
    If LowerBound = MinLong Then f = LBound(TheIndex) Else f = LowerBound
    If UpperBound = MinLong Then g = UBound(TheIndex) Else g = UpperBound
    t = 0
    Do
        If g - f < QTHRESH Then
            For j = f + 1 To g
                indxt = TheIndex(j)
                CopyMemory ByVal VarPtr(swp), ByVal VarPtr(TheArray(indxt)), 4
                For i = j - 1 To f Step -1
                    If TheArray(TheIndex(i)) <= swp Then Exit For
                    TheIndex(i + 1) = TheIndex(i)
                Next i
                TheIndex(i + 1) = indxt
            Next j
            If t = 0 Then Exit Do
            g = s(t)
            f = s(t - 1)
            t = t - 2
        Else
            h = (f + g) \ 2
            SwapLong TheIndex(h), TheIndex(f + 1)
            If TheArray(TheIndex(f)) > TheArray(TheIndex(g)) Then SwapLong TheIndex(f), TheIndex(g)
            If TheArray(TheIndex(f + 1)) > TheArray(TheIndex(g)) Then SwapLong TheIndex(f + 1), TheIndex(g)
            If TheArray(TheIndex(f)) > TheArray(TheIndex(f + 1)) Then SwapLong TheIndex(f), TheIndex(f + 1)
            i = f + 1
            j = g
            indxt = TheIndex(f + 1)
            CopyMemory ByVal VarPtr(swp), ByVal VarPtr(TheArray(indxt)), 4
            Do
                Do
                  i = i + 1
                Loop While TheArray(TheIndex(i)) < swp
                Do
                    j = j - 1
                Loop While TheArray(TheIndex(j)) > swp
                If j < i Then Exit Do
                SwapLong TheIndex(i), TheIndex(j)
            Loop
            TheIndex(f + 1) = TheIndex(j)
            TheIndex(j) = indxt
            t = t + 2
            If g - i + 1 >= j - f Then
                s(t) = g
                s(t - 1) = i
                g = j - 1
            Else
                s(t) = j - 1
                s(t - 1) = f
                f = i
            End If
        End If
    Loop
    CopyMemory ByVal VarPtr(swp), 0&, 4
End Sub
Public Sub SortLongIndexArray(TheArray() As Long, TheIndex() As Long, Optional LowerBound As Long = MinLong, Optional UpperBound As Long = MinLong)
    Dim f          As Long
    Dim g          As Long
    Dim h          As Long
    Dim i          As Long
    Dim j          As Long
    Dim s(1 To 64) As Long
    Dim t          As Long
    Dim swp        As Long
    Dim indxt      As Long
    If LowerBound = MinLong Then f = LBound(TheIndex) Else f = LowerBound
    If UpperBound = MinLong Then g = UBound(TheIndex) Else g = UpperBound
    t = 0
    Do
        If g - f < QTHRESH Then
            For j = f + 1 To g
                indxt = TheIndex(j)
                swp = TheArray(indxt)
                For i = j - 1 To f Step -1
                    If TheArray(TheIndex(i)) <= swp Then Exit For
                    TheIndex(i + 1) = TheIndex(i)
                Next i
                TheIndex(i + 1) = indxt
            Next j
            If t = 0 Then Exit Do
            g = s(t)
            f = s(t - 1)
            t = t - 2
        Else
            h = (f + g) \ 2
            SwapLong TheIndex(h), TheIndex(f + 1)
            If TheArray(TheIndex(f)) > TheArray(TheIndex(g)) Then SwapLong TheIndex(f), TheIndex(g)
            If TheArray(TheIndex(f + 1)) > TheArray(TheIndex(g)) Then SwapLong TheIndex(f + 1), TheIndex(g)
            If TheArray(TheIndex(f)) > TheArray(TheIndex(f + 1)) Then SwapLong TheIndex(f), TheIndex(f + 1)
            i = f + 1
            j = g
            indxt = TheIndex(f + 1)
            swp = TheArray(indxt)
            Do
                Do
                  i = i + 1
                Loop While TheArray(TheIndex(i)) < swp
                Do
                    j = j - 1
                Loop While TheArray(TheIndex(j)) > swp
                If j < i Then Exit Do
                SwapLong TheIndex(i), TheIndex(j)
            Loop
            TheIndex(f + 1) = TheIndex(j)
            TheIndex(j) = indxt
            t = t + 2
            If g - i + 1 >= j - f Then
                s(t) = g
                s(t - 1) = i
                g = j - 1
            Else
                s(t) = j - 1
                s(t - 1) = f
                f = i
            End If
        End If
    Loop
End Sub