- '
- '数值与数组操作'
- Option Explicit
- '
- '
- '数值快速排序(从小到大)
- '函数:NumSortAZ
- '参数:Myarray Double数组,L 数组的左边界,R 数组右边界.
- '返回值:无
- '例子:
- Public Sub NumSortAZ(ByRef Myarray, l As Long, R As Long)
- Dim I As Long, J As Long, A As Long
- Dim TmpX As Variant, TmpA As Variant
- I = l: J = R: TmpX = Myarray((l + R) / 2)
- While (I <= J)
- While (Myarray(I) < TmpX And I < R)
- I = I + 1
- Wend
- While (TmpX < Myarray(J) And J > l)
- J = J - 1
- Wend
- If (I <= J) Then
- TmpA = Myarray(I)
- Myarray(I) = Myarray(J)
- Myarray(J) = TmpA
- I = I + 1: J = J - 1
- End If
- Wend
- If (l < J) Then Call NumSortAZ(Myarray, l, J)
- If (I < R) Then Call NumSortAZ(Myarray, I, R)
- End Sub
- '
- '数值快速排序(从大到小)
- '函数:NumSortZA
- '参数:Myarray Double数组,L 数组的左边界,R 数组右边界.
- '返回值:无
- '例子:
- Public Sub NumSortZA(ByRef Myarray, l As Long, R As Long)
- Dim I As Long, J As Long, A As Long
- Dim LT As Long, RT As Long
- Dim TmpX As Variant, TmpA As Variant
- I = l: J = R: TmpX = Myarray((l + R) / 2)
- While (I <= J)
- While (Myarray(I) > TmpX And I < R)
- I = I + 1
- Wend
- While (TmpX > Myarray(J) And J > l)
- J = J - 1
- Wend
- If (I <= J) Then
- TmpA = Myarray(I)
- Myarray(I) = Myarray(J)
- Myarray(J) = TmpA
- I = I + 1: J = J - 1
- End If
- Wend
- If (l < J) Then Call NumSortZA(Myarray, l, J)
- If (I < R) Then Call NumSortZA(Myarray, I, R)
- End Sub
- '
- '字符串快速排序(从大到小)
- '函数:StrSortZA
- '参数:sArr String数组,L 数组的左边界,R 数组右边界.
- '返回值:无
- '例子:
- Public Sub StrSortZA(ByRef sArr() As String, First As Long, Last As Long)
- Dim vSplit As String, vT As String
- Dim I As Long, J As Long, iRand As Long
- If First < Last Then
- If Last - First = 1 Then
- If sArr(First) < sArr(Last) Then
- vT = sArr(First): sArr(First) = sArr(Last): sArr(Last) = vT
- End If
- Else
- iRand = Int(First + (Rnd * (Last - First + 1)))
- vT = sArr(Last): sArr(Last) = sArr(iRand): sArr(iRand) = vT
- vSplit = sArr(Last)
- Do
- I = First: J = Last
- Do While (I < J) And (sArr(I) >= vSplit)
- I = I + 1
- Loop
- Do While (J > I) And (sArr(J) <= vSplit)
- J = J - 1
- Loop
- If I < J Then
- vT = sArr(I): sArr(I) = sArr(J): sArr(J) = vT
- End If
- Loop While I < J
- vT = sArr(I): sArr(I) = sArr(Last): sArr(Last) = vT
- If (I - First) < (Last - I) Then
- StrSortZA sArr(), First, I - 1
- StrSortZA sArr(), I + 1, Last
- Else
- StrSortZA sArr(), I + 1, Last
- StrSortZA sArr(), First, I - 1
- End If
- End If
- End If
- End Sub
- '
- '字符串快速排序(从小到大)
- '函数:StrSortAZ
- '参数:sArr String数组,First 数组的左边界,Last 数组右边界.
- '返回值:无
- '例子:
- Public Sub StrSortAZ(ByRef sArr() As String, First As Long, Last As Long)
- Dim vSplit As String, vT As String
- Dim I As Long, J As Long, iRand As Long
- If First < Last Then
- If Last - First = 1 Then
- If sArr(First) > sArr(Last) Then
- vT = sArr(First): sArr(First) = sArr(Last): sArr(Last) = vT
- End If
- Else
- iRand = Int(First + (Rnd * (Last - First + 1)))
- vT = sArr(Last): sArr(Last) = sArr(iRand): sArr(iRand) = vT
- vSplit = sArr(Last)
- Do
- I = First: J = Last
- Do While (I < J) And (sArr(I) <= vSplit)
- I = I + 1
- Loop
- Do While (J > I) And (sArr(J) >= vSplit)
- J = J - 1
- Loop
- If I < J Then
- vT = sArr(I): sArr(I) = sArr(J): sArr(J) = vT
- End If
- Loop While I < J
- vT = sArr(I): sArr(I) = sArr(Last): sArr(Last) = vT
- If (I - First) < (Last - I) Then
- StrSortAZ sArr(), First, I - 1
- StrSortAZ sArr(), I + 1, Last
- Else
- StrSortAZ sArr(), I + 1, Last
- StrSortAZ sArr(), First, I - 1
- End If
- End If
- End If
- End Sub
- '
- '有序数的快速查找(A->Z),非递归法
- '函数:NumFind
- '参数:Myarray Double数组,L 数组的左边界,R 数组右边界.FNumber 要查找的数据.
- '返回值:找到,则返回下标,否则,返回-1
- '例子:
- Public Function NumFind(ByRef Myarray, FNumber As Variant) As Long
- Dim K As Long, I As Long
- Dim L1 As Long, R1 As Long
- Dim l As Long, R As Long
- l = LBound(Myarray): R = UBound(Myarray)
- NextLoop:
- K = (l + R) Mod 2
- If K = 1 Then '中点
- I = (l + R + 1) / 2
- Else
- I = (l + R) / 2
- End If
- If Myarray(I) <> FNumber Then
- If Myarray(I) > FNumber Then
- L1 = l: R1 = I
- Else
- L1 = I: R1 = R
- End If
- If (R1 - L1) = 1 Then '第一个和最后一个
- If Myarray(L1) = FNumber Then
- NumFind = L1
- ElseIf Myarray(R1) = FNumber Then
- NumFind = R1
- Else
- NumFind = -1 '没有发现
- End If
- Else
- l = L1: R = R1
- GoTo NextLoop
- End If
- Else
- NumFind = I
- End If
- End Function
- '
- '有序字符串的快速查找,非递归法
- '函数:StrFind
- '参数:Myarray String数组,L 数组的左边界,R 数组右边界.Fstr 要查找的字符串.
- '返回值:找到,则返回下标,否则,返回-1
- '例子:
- Public Function StrFind(ByRef Myarray() As String, l As Long, R As Long, Fstr As String) As Long
- Dim K As Long, I As Long
- Dim L1 As Long, R1 As Long
- NextLoop:
- K = (l + R) Mod 2
- If K = 0 Then
- If Myarray(0) = Fstr Then
- StrFind = 0
- Else
- StrFind = -1
- End If
- Exit Function
- End If
- If K = 1 Then '中点
- I = (l + R + 1) / 2
- Else
- I = (l + R) / 2
- End If
- If Myarray(I) <> Fstr Then
- If Myarray(I) > Fstr Then
- L1 = l: R1 = I
- Else
- L1 = I: R1 = R
- End If
- If (R1 - L1) = 1 Then '第一个和最后一个
- If Myarray(L1) = Fstr Then
- StrFind = L1
- ElseIf Myarray(R1) = Fstr Then
- StrFind = R1
- Else
- StrFind = -1 '没有发现
- End If
- Else
- l = L1: R = R1
- GoTo NextLoop
- End If
- Else
- StrFind = I
- End If
- End Function
- Private Sub Class_Initialize()
- Dim T As New ClsRev
- Call T.GetIniVal
- Set T = Nothing
- End Sub
- '
- '数组是否已经初始化.
- '函数:ArrEmpty
- '参数:MyArr 数组名称.
- '返回值:TRUE 已经初始化,FALSE 未初始化.
- '例子:
- Public Function ArrEmpty(ByRef MyArr) As Boolean
- Dim K As Long
- On Error Resume Next
- K = UBound(MyArr)
- ArrEmpty = (Err.Number = 0)
- Err.Clear
- End Function
- '.
- '数组的某个数组ID是否存在.
- '函数:ArrBeing
- '参数:MyArr 数组名称.ID 数组下标.
- '返回值:TRUE 存在,FALSE 不存在.
- '例子:
- Public Function ArrBeing(ByRef MyArr, id As Long) As Boolean
- Dim K As Variant
- On Error Resume Next
- K = MyArr(id)
- ArrBeing = (Err.Number = 0)
- Err.Clear
- End Function
- '
- '计算用户输入的表达式
- '函数:MathCal
- '参数:CalStr 一个数学表达式,如:23*45/9
- '返回值:String,(如果成功,则返回计算结果,错误则返回 "0")
- '例子:
- Public Function MathCal(CalStr As String) As String
- Dim Mscr As New ScriptControl
- Dim ReVal As String
- On Error Resume Next
- Mscr.Language = "VBScript"
- ReVal = Mscr.Eval(CalStr)
- If Err.Number = 0 Then
- MathCal = ReVal
- Else
- MathCal = 0
- End If
- Set Mscr = Nothing
- End Function
- '
- '取某年某月的从周第日期
- '函数:timeMweekDate
- '参数:sYear 年,sMonth 月,sWeek 从第周开始, eWeek 从第周结束
- '返回值:Date 数组.(0) 开始日期,(1) 结束日期
- '例子: Dim T() As Date
- ' T = timeMweekDate(2004, 1, 1, 4)
- ' Text1 = T(0) & ":" & T(1)
- Private Function timeMweekDate(sYear As Long, sMonth As Long, sWeek As Long, eWeek As Long) As Date()
- Dim StarDate As Date
- Dim EndDate As Date
- Dim NextDate As Date
- Dim TmpDate As Date
- Dim DltDate As Date
- Dim RetuVal(1) As Date
- Dim DateArr(10, 1) As Date '保存各周的开始结束日期.
- Dim Wid As Long
- Dim A As Long
- StarDate = sYear & "/" & sMonth & "/1" '今月开始的日期.
- NextDate = DateAdd("M", 1, StarDate) '下月开始日期.
- EndDate = DateAdd("D", -1, NextDate) '今月月未日期.
- DltDate = StarDate
- While DltDate <= EndDate
- If DltDate = StarDate Or DltDate = EndDate Or Weekday(DltDate) = 1 Then
- DateArr(Wid, 0) = DltDate
- End If
- If DltDate = EndDate Or Weekday(DltDate) = 7 Then
- DateArr(Wid, 1) = DltDate
- Wid = Wid + 1
- End If
- DltDate = DateAdd("d", 1, DltDate)
- Wend
- If eWeek > Wid Then eWeek = Wid '如果超出本范围,则以月底计算
- RetuVal(0) = DateArr(sWeek - 1, 0)
- RetuVal(1) = DateArr(eWeek - 1, 1)
- timeMweekDate = RetuVal
- End Function
VB对数字/字符数组的快速排序.查找.
最新推荐文章于 2022-01-24 18:04:08 发布