ListToArray() ListToArray(srcList List
As
String,dstArray()
As
String)
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:ListToArray
'设计者:wnight88
'功 能:将列表转化为数组
''''''''''''''''''''''''''''''''''''''''''''''''
Dim i As Integer
i = 0
ForAll tempValue In srcList
If tempValue <> "" Then
ReDim Preserve dstArray(i)
dstArray(i) = tempValue
i = i + 1
End If
End ForAll
Exit sub
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的子程序(ListToArray)成功执行完毕!"
Else
Msgbox "tools.txt中的子程序(ListToArray)出错..出错行数为:" & Cstr
(Erl) & "行!错误原因为:" & Error
End If
End Sub
ArrayToList() ArrayToList(srcArray As Variant,dstList List As String)
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:ArrayToList
'设计者:wnight88
'功 能:将数组转换为列表
''''''''''''''''''''''''''''''''''''''''''''''''
Dim i As Integer
i = 0
ForAll tempValue In srcArray
If tempValue <> "" Then
dstList(i) = tempValue
i = i + 1
End If
End ForAll
Exit sub
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的子程序(ArrayToList)成功执行完毕!"
Else
Msgbox "tools.txt中的子程序(ArrayToList)出错..出错行数为:" & Cstr
(Erl) & "行!错误原因为:" & Error
End If
End Sub
getFilePath() getFilePath()
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:getFilePath
'设计者:wnight88
'功 能:获取当前数据库路径,前后不带"/"和"\"
''''''''''''''''''''''''''''''''''''''''''''''''
Dim s As New NotesSession
Dim db As NotesDatabase
Dim FilePath As String
Set db = s.CurrentDatabase
Msgbox Len(db.FilePath) - Len(db.FilePath) - 1
FilePath = Left(db.FilePath, Len(db.FilePath) - Len(db.FileName) - 1)
getfilepath = filepath
Exit Function
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的函数(getFilePath)成功执行完毕!"
Else
Msgbox "tools.txt中的函数(getFilePath)出错..出错行数为:" & Cstr(Erl)
& "行!错误原因为:" & Error
End If
End Function
SplitString() SplitString( Byval srcString As String,Symbol As String,strArray() As String)
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:SplitString
'设计者:wnight88
'功 能:将字符串srcString以符号symbol拆分为数组strArray()
''''''''''''''''''''''''''''''''''''''''''''''''
Redim strArray(0) As String
Dim i As Integer
If Instr(srcString,Symbol) > 0 Then
srcString = srcString + Symbol
i = 0
Do While srcString <> ""
Redim Preserve strArray(i)
strArray(i) = Left(srcString, Instr(srcString,Symbol) - 1)
srcString = Right(srcString, Len(srcString) - Instr
(srcString,Symbol) - Len(Symbol) + 1)
i = i + 1
Loop
Else
strArray(0) = srcString
End If
Exit Sub
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的子程序(SplitString)成功执行完毕!"
Else
Msgbox "tools.txt中的子程序(SplitString)出错..出错行数为:" & Cstr
(Erl) & "行!错误原因为:" & Error
End If
End Sub
SortArray () SortArray (SortMe As Variant) As Variant
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:SortArray
'设计者:wnight88
'功 能:用冒泡排序法排序数组
''''''''''''''''''''''''''''''''''''''''''''''''
Dim currentItem As Integer
Dim nextItem As Integer
Dim tmp_element As Variant
For CurrentItem = 0 To UBound(SortMe)
NextItem = CurrentItem
Do While NextItem > 0
If (SortMe(NextItem) > SortMe(NextItem - 1)) Then
Exit Do
Else
tmp_element = SortMe(NextItem)
SortMe(NextItem) = SortMe(NextItem-1)
SortMe(NextItem-1) = tmp_element
End If
NextItem=NextItem-1
Loop
Next
SortArray = SortMe
Exit Function
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的函数(SortArray)成功执行完毕!"
Else
Msgbox "tools.txt中的函数(SortArray)出错..出错行数为:" & Cstr(Erl) &
"行!错误原因为:" & Error
End If
End Function
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:ListToArray
'设计者:wnight88
'功 能:将列表转化为数组
''''''''''''''''''''''''''''''''''''''''''''''''
Dim i As Integer
i = 0
ForAll tempValue In srcList
If tempValue <> "" Then
ReDim Preserve dstArray(i)
dstArray(i) = tempValue
i = i + 1
End If
End ForAll
Exit sub
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的子程序(ListToArray)成功执行完毕!"
Else
Msgbox "tools.txt中的子程序(ListToArray)出错..出错行数为:" & Cstr
(Erl) & "行!错误原因为:" & Error
End If
End Sub
ArrayToList() ArrayToList(srcArray As Variant,dstList List As String)
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:ArrayToList
'设计者:wnight88
'功 能:将数组转换为列表
''''''''''''''''''''''''''''''''''''''''''''''''
Dim i As Integer
i = 0
ForAll tempValue In srcArray
If tempValue <> "" Then
dstList(i) = tempValue
i = i + 1
End If
End ForAll
Exit sub
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的子程序(ArrayToList)成功执行完毕!"
Else
Msgbox "tools.txt中的子程序(ArrayToList)出错..出错行数为:" & Cstr
(Erl) & "行!错误原因为:" & Error
End If
End Sub
getFilePath() getFilePath()
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:getFilePath
'设计者:wnight88
'功 能:获取当前数据库路径,前后不带"/"和"\"
''''''''''''''''''''''''''''''''''''''''''''''''
Dim s As New NotesSession
Dim db As NotesDatabase
Dim FilePath As String
Set db = s.CurrentDatabase
Msgbox Len(db.FilePath) - Len(db.FilePath) - 1
FilePath = Left(db.FilePath, Len(db.FilePath) - Len(db.FileName) - 1)
getfilepath = filepath
Exit Function
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的函数(getFilePath)成功执行完毕!"
Else
Msgbox "tools.txt中的函数(getFilePath)出错..出错行数为:" & Cstr(Erl)
& "行!错误原因为:" & Error
End If
End Function
SplitString() SplitString( Byval srcString As String,Symbol As String,strArray() As String)
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:SplitString
'设计者:wnight88
'功 能:将字符串srcString以符号symbol拆分为数组strArray()
''''''''''''''''''''''''''''''''''''''''''''''''
Redim strArray(0) As String
Dim i As Integer
If Instr(srcString,Symbol) > 0 Then
srcString = srcString + Symbol
i = 0
Do While srcString <> ""
Redim Preserve strArray(i)
strArray(i) = Left(srcString, Instr(srcString,Symbol) - 1)
srcString = Right(srcString, Len(srcString) - Instr
(srcString,Symbol) - Len(Symbol) + 1)
i = i + 1
Loop
Else
strArray(0) = srcString
End If
Exit Sub
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的子程序(SplitString)成功执行完毕!"
Else
Msgbox "tools.txt中的子程序(SplitString)出错..出错行数为:" & Cstr
(Erl) & "行!错误原因为:" & Error
End If
End Sub
SortArray () SortArray (SortMe As Variant) As Variant
On Error Goto errmsg
''''''''''''''''''''''''''''''''''''''''''''''''
'程序名:SortArray
'设计者:wnight88
'功 能:用冒泡排序法排序数组
''''''''''''''''''''''''''''''''''''''''''''''''
Dim currentItem As Integer
Dim nextItem As Integer
Dim tmp_element As Variant
For CurrentItem = 0 To UBound(SortMe)
NextItem = CurrentItem
Do While NextItem > 0
If (SortMe(NextItem) > SortMe(NextItem - 1)) Then
Exit Do
Else
tmp_element = SortMe(NextItem)
SortMe(NextItem) = SortMe(NextItem-1)
SortMe(NextItem-1) = tmp_element
End If
NextItem=NextItem-1
Loop
Next
SortArray = SortMe
Exit Function
errmsg:
If Cstr(Erl) = "0" Then
Msgbox "tools.txt中的函数(SortArray)成功执行完毕!"
Else
Msgbox "tools.txt中的函数(SortArray)出错..出错行数为:" & Cstr(Erl) &
"行!错误原因为:" & Error
End If
End Function
转载于:https://blog.51cto.com/wnight88/344735