|
'-------------------------------------------------------------------------------------------------------------
' Secure Function : sfTrim
'-------------------------------------------------------------------------------------------------------------
Public Function sfTrim(ByVal strP As Variant) As String
On Error Resume Next
If IsNull(strP) Then
sfTrim = ""
Else
sfTrim = Trim$(strP)
End If
On Error GoTo 0
End Function
'-------------------------------------------------------------------------------------------------------------
' Secure Function : sfSQLStr
'-------------------------------------------------------------------------------------------------------------
Public Function sfSQLStr(ByVal strP As Variant) As String
On Error Resume Next
sfSQLStr = sfTrim(strP)
If InStr(sfSQLStr,"'") > 0 Then sfSQLStr = Replace(sfSQLStr,"'","''")
On Error GoTo 0
End Function
'-------------------------------------------------------------------------------------------------------------
' Secure Function : sfLen
'-------------------------------------------------------------------------------------------------------------
Public Function sfLen(ByVal strP As Variant) As Long
On Error Resume Next
sfLen = Len(sfTrim(strP))
On Error GoTo 0
End Function
'-------------------------------------------------------------------------------------------------------------
' Secure Function : sfVal
'-------------------------------------------------------------------------------------------------------------
Public Function sfVal(ByVal strP As Variant) As Double
On Error Resume Next
sfVal = Val(sfTrim(strP))
On Error GoTo 0
End Function
'------------------------------------------------------
'函数名称 : substr
'功 能 : 从一字串中截取部分字串,相当於mid(),但可用於中文
'参数说名 : tstr 字串
' start 起始位置
' leng 截取长度
'返 回 值 : 字串
'
'------------------------------------------------------
Public Function SubStr(ByVal tstr As String,start As Integer,Optional leng As Variant) As String
Dim tmpstr As String
If IsMissing(leng) Then
tmpstr = StrConv(MidB(StrConv(tstr,vbFromUnicode),start),vbUnicode)
Else
tmpstr = StrConv(MidB(StrConv(tstr,start,leng),vbUnicode)
End If
SubStr = tmpstr
End Function
'------------------------------------------------------
'函数名称 : strlen
'功 能 : 取得字串的长度,相当於len(),但可用於中文
'参数说名 : tstr 字串
'
'返 回 值 : integer
'------------------------------------------------------
Public Function Strlen(ByVal tstr As String) As Integer
Strlen = LenB(StrConv(tstr,vbUnicode))
End Function
'------------------------------------------------------
'函数名称 : strleft
'功 能 : 从左端开始,截取部份字串,相当於left(),但可用於中文
'参数说名 : str5 字串
' len5 待截取的长度
'返 回 值 : string
'------------------------------------------------------
Public Function StrLeft(ByVal str5 As String,ByVal len5 As Long) As String
Dim tmpstr As String
tmpstr = StrConv(str5,vbUnicode)
tmpstr = LeftB(tmpstr,len5)
StrLeft = StrConv(tmpstr,vbUnicode)
End Function
'------------------------------------------------------
'函数名称 : strright
'功 能 : 从右端开始,相当於right(),但可用於中文
'参数说名 : str5 字串
' len5 待截取的长度
'返 回 值 : string
'------------------------------------------------------
Public Function StrRight(ByVal str5 As String,ByVal len5 As Long) As String
Dim tmpstr As String
tmpstr = StrConv(str5,vbUnicode)
tmpstr = RightB(tmpstr,len5)
StrRight = StrConv(tmpstr,vbUnicode)
End Function
'------------------------------------------------------
'函数名称 : ischinese
'功 能 : 判断某一字符是否为中文
'参数说名 : asciiv 字符的ascii值
'
'返 回 值 : boolean
'------------------------------------------------------
Public Function isChinese(ByVal asciiv As Integer) As Boolean
If Len(Hex$(asciiv)) > 2 Then
isChinese = True
Else
isChinese = False
End If
End Function
'-----------------------------------------------------------------------------------------
' only entry numeric character
' *** ByRef ***
'-----------------------------------------------------------------------------------------
Public Function OnlyNum(ByRef KeyAscii As Integer) As Boolean
If (KeyAscii < 48 And KeyAscii <> 46) Or KeyAscii > 57 Then _
If KeyAscii <> 13 And KeyAscii <> 8 Then KeyAscii = 7
End Function
'-----------------------------------------------------------------------------------------
' Turn to Upper Case
' *** ByRef ***
'-----------------------------------------------------------------------------------------
Public Sub AllUcase(ByRef KeyAscii As Integer)
If KeyAscii > 96 And KeyAscii < 123 Then KeyAscii = KeyAscii - 32
End Sub
'-----------------------------------------------------------------------------------------
' Get path
'-----------------------------------------------------------------------------------------
Public Function GetPath(ByVal psFile As String) As String
Dim sP As String
Dim iPos As Integer,iLop As Integer
sP = "/"
iLop = InStr(1,psFile,sP)
Do While iLop > 0
iPos = iLop
iLop = InStr(iPos + 1,sP)
Loop
iLop = Len(psFile)
GetPath = Mid(psFile,1,iPos)
End Function
'-----------------------------------------------------------------------------------------
' Whether exist specifial file on one path
'-----------------------------------------------------------------------------------------
Public Function FileExistsWithDir(ByVal Filename As String) As Boolean
Dim File_Name As String
File_Name = Dir$(Filename)
FileExistsWithDir = (File_Name <> "")
End Function
'-----------------------------------------------------------------------------------------
' Whether exist duplicate file
'-----------------------------------------------------------------------------------------
Function ChkDupFile(CHKFileName As String) As Boolean
Dim File_Exists As Boolean
If Len(Trim(CHKFileName)) > 0 Then
File_Exists = FileExistsWithDir(Trim(CHKFileName))
If File_Exists Then
ChkDupFile = True
Else
ChkDupFile = False
End If
Else
ChkDupFile = False
End If
End Function
'-----------------------------------------------------------------------------------------
' Get File Name base on String (File & Path)
'-----------------------------------------------------------------------------------------
Function GetFileNameOnly(ByVal WholeFilePath As String) As String
On Error GoTo GetFilename_ERR
Dim Pos As Integer
Dim Pos1 As Integer
GetFileNameOnly = ""
Pos = Len(WholeFilePath)
Do While Not InStr(1,WholeFilePath,"/") = 0
Pos = Len(WholeFilePath)
Pos1 = InStr(1,"/")
WholeFilePath = Right(WholeFilePath,Pos - Pos1)
Loop
GetFileNameOnly = WholeFilePath
GoTo GetFilename_Exit
GetFilename_ERR:
MsgBox "Get File Name Error",vbExclamation,"CheckFile"
GetFilename_Exit:
End Function
'-----------------------------------------------------------------------------------------
' Get File Name base on String (File & Path)
'-----------------------------------------------------------------------------------------
Function GetFileName_Main(ByVal FileNameOnly As String) As String
On Error GoTo GetFilename_ERR
Dim iStartPos As Integer
Dim Pos1 As Integer
GetFileName_Main = FileNameOnly
iStartPos = 1
Pos1 = 0
Do While Not InStr(iStartPos,FileNameOnly,".") = 0
Pos1 = InStr(iStartPos,".")
iStartPos = Pos1 + 1
Loop
If Pos1 > 1 Then
GetFileName_Main = Left(FileNameOnly,Pos1 - 1)
End If
GetFilename_ERR:
If Err.Number <> 0 Then MsgBox "Get File Name Error","GetFileName_Main"
End Function
'-----------------------------------------------------------------------------------------
' Get File Name base on String (File & Path)
'-----------------------------------------------------------------------------------------
Function GetFileName_Ext(ByVal FileNameOnly As String) As String
On Error GoTo GetFilename_ERR
Dim iStartPos As Integer
Dim Pos1 As Integer
GetFileName_Ext = ""
iStartPos = 1
Pos1 = 0
Do While Not InStr(iStartPos,".")
iStartPos = Pos1 + 1
Loop
If Pos1 > 1 Then
GetFileName_Ext = Mid(FileNameOnly,Pos1 + 1)
End If
GetFilename_ERR:
If Err.Number <> 0 Then MsgBox "Get File Name Error","GetFileName_Ext"
End Function
'-----------------------------------------------------------------------------------------
' Delay time
'-----------------------------------------------------------------------------------------
Public Sub Delay(Times As Integer)
Dim i As Integer
For i = 1 To Times
DoEvents
Next i
End Sub
'-----------------------------------------------------------------------------------------
' '将一个结果集中的数据拷贝到另一结果集中去
''考虑调用前利用事物控制,若函数失败则自己回滚
'-----------------------------------------------------------------------------------------
Public Function CopyRstToRst(ByVal SourceRst As ADODB.RecordSet,_
ByRef DestationRst As ADODB.RecordSet,_
Optional ByVal bNotSameName As Boolean) As Boolean
On Error GoTo ErrHandle
Dim Fld As ADODB.Field
Dim iCursorType As ADODB.CursorTypeEnum
Dim i As Integer
Dim iFldNumS As Integer
Dim iFldNumD As Integer
Dim iMin As Integer
iCursorType = GetRstCursorType(SourceRst)
'''若能移到第一条记录处，就 MoveFirst
If iCursorType <> adOpenForwardOnly Then
If Not SourceRst.BOF Then SourceRst.MoveFirst
End If
If Not bNotSameName Then '''字段名一定要相同
Do While Not SourceRst.EOF
DestationRst.AddNew
For Each Fld In DestationRst.Fields
DestationRst.Fields(Fld.Name).Value = SourceRst(Fld.Name)
Next
DestationRst.Update
SourceRst.MoveNext
Loop
Else
iFldNumS = SourceRst.Fields.Count - 1
iFldNumD = DestationRst.Fields.Count - 1
If iFldNumS >= iFldNumD Then
iMin = iFldNumD
Else
iMin = iFldNumS
End If
Do While Not SourceRst.EOF
DestationRst.AddNew
For i = 0 To iMin
DestationRst.Fields(i).Value = SourceRst.Fields(i).Value
Next
DestationRst.Update
SourceRst.MoveNext
Loop
End If
CopyRstToRst = True
Exit_function:
Exit Function
ErrHandle:
CopyRstToRst = False
Err.Raise vbObjectError + 100,Err.Description
Resume Exit_function
End Function
'-----------------------------------------------------------------------------------------
' Get RecordSet Cursor Type
'-----------------------------------------------------------------------------------------
Public Function GetRstCursorType(ByVal Rst As ADODB.RecordSet) As ADODB.CursorTypeEnum
GetRstCursorType = Rst.CursorType
End Function
'-----------------------------------------------------------------------------------------
' Format date & Time
'-----------------------------------------------------------------------------------------
Public Function DateTimeFormat(InDate) '*** Don't declare the data type
DateTimeFormat = Format(InDate,"dd MMM yyyy hh:mm:ss")
End Function
'-----------------------------------------------------------------------------------------
' Format date
'-----------------------------------------------------------------------------------------
Public Function DateFormat(InDate) '*** Don't declare the data type
DateFormat = Format(InDate,"dd MMM yyyy")
End Function
'-----------------------------------------------------------------------------------------
'Purpose : 根据指定的格式，将指定的字串转入日期值
'Note : 分别取得对应的年月日的值，再将其组合为日期
' Y / M / D 分别对应年、月、日
'-----------------------------------------------------------------------------------------
Public Function GetDate(ByVal psDateStr,ByVal psFormat As String) As Date
On Error GoTo errGetDate
Dim nYear As Long
Dim nMonth As Long
Dim nDay As Long
nYear = sfVal(GetValue(psDateStr,psFormat,"Y"))
nMonth = sfVal(GetValue(psDateStr,"M"))
nDay = sfVal(GetValue(psDateStr,"D"))
If nYear = 0 Or nMonth = 0 Or nDay = 0 Or nMonth > 12 Or nDay > 31 Then
GetDate = 0
Else
GetDate = DateSerial(nYear,nMonth,nDay)
End If
errGetDate:
If Err.Number <> 0 Then
MsgBox "读取日期值出错，请检查！" & vbCr & _
Err.Description,vbOKOnly + vbExclamation,"警告："
GetDate = 0
End If
End Function
'-----------------------------------------------------------------------------------------
'Purpose : 根据原始字串，及格式化字串，取得格式化字串中对应的年月日
' Y / M / D 分别对应年、月、日
'-----------------------------------------------------------------------------------------
Private Function GetValue(ByVal psStr As String,ByVal psFormat As String,ByVal psFormatChar As String) As String
Dim nStart As Long
Dim nLength As Long
Dim nLoop As Long
Dim nCount As Long
psStr = sfTrim(psStr)
psFormat = UCase(sfTrim(psFormat))
' 取得第一个位置
nStart = InStr(psFormat,psFormatChar)
If nStart = 0 Then
GetValue = ""
Exit Function
End If
' 取得长度
nLength = 1
nCount = sfLen(psStr)
For nLoop = nStart + 1 To nCount
If Mid(psFormat,nLoop,1) = psFormatChar Then
nLength = nLength + 1
Else
Exit For
End If
Next
' 取得值
GetValue = Mid(psStr,nStart,nLength)
End Function
'-----------------------------------------------------------------------------------------
' SetFreeRst
'-----------------------------------------------------------------------------------------
Public Sub SetFreeRst(ByRef Rst As ADODB.RecordSet)
If Not Rst Is Nothing Then
If Rst.State <> adStateClosed Then Rst.Close
Set Rst = Nothing
End If
End Sub
'-----------------------------------------------------------------------------------------
' InitRst
'-----------------------------------------------------------------------------------------
Public Sub ReInitRst(ByRef Rst As ADODB.RecordSet)
If Not Rst Is Nothing Then
If Rst.State <> adStateClosed Then Rst.Close
Set Rst = Nothing
End If
Set Rst = New ADODB.RecordSet
End Sub
'-----------------------------------------------------------------------------------------
'Get a ADODB.Recordset
'Return Value : True (Successful)
' False (Failed)
'-----------------------------------------------------------------------------------------
Public Function CreateRst(ByVal SQL As String,_
ByRef Rst As ADODB.RecordSet,_
Optional ByVal iCursorType As ADODB.CursorTypeEnum = adOpenForwardOnly,_
Optional ByVal iLockType As ADODB.LockTypeEnum = adLockReadOnly,_
Optional ByVal adoCn As ADODB.Connection) As Boolean
On Error GoTo ErrHandle
CreateRst = False
If Not Rst Is Nothing Then
If Rst.State <> adStateClosed Then Rst.Close
End If
If Rst Is Nothing Then
Set Rst = New ADODB.RecordSet
End If
Rst.Open SQL,adoCn,iCursorType,iLockType
CreateRst = True
Exit Function
ErrHandle:
MsgBox "Create recordset faile ! ","CreateRst"
End Function
'-----------------------------------------------------------------------------------------
' Convert Time format : HH:MM <=> HHMM
'-----------------------------------------------------------------------------------------
Public Function TimeFormat(ByVal vValue As Variant,Optional bNoSign As Boolean = False) As String
vValue = sfTrim(vValue)
If sfLen(vValue) = 0 Then Exit Function
If bNoSign Then
TimeFormat = Format(Left(vValue,2),"0#") & Format(Right(vValue,"0#")
'TimeFormat = Format(vValue,"HHMM")
Else
TimeFormat = Format(Left(vValue,"0#") & ":" & Format(Right(vValue,"0#:##")
End If
End Function
'-----------------------------------------------------------------------------------------
' calculate Minutes according to two time value
'-----------------------------------------------------------------------------------------
Public Function getMinutes(ByVal sFrTime As String,ByVal sToTime As String) As Long
Dim iHourFr As Long
Dim iHourTo As Long
Dim iMinuteFr As Long
Dim iMinuteTo As Long
iHourFr = Left(sFrTime,2)
iMinuteFr = Right(sFrTime,2)
iHourTo = Left(sToTime,2)
iMinuteTo = Right(sToTime,2)
getMinutes = iHourTo * 60 + iMinuteTo - (iHourFr * 60 + iMinuteFr)
End Function
'-----------------------------------------------------------------------------------------
' 取得当前程序和版本号
' Format : VX.Y.Z
' Sample : V1.2.1
'-----------------------------------------------------------------------------------------
Public Function getAppVersion() As String
getAppVersion = "V" & App.Major & "." & App.Minor & "." & App.Revision
End Function
'-----------------------------------------------------------------------------------------
' 得出字串的实际长度，但可用于中英文混合
'-----------------------------------------------------------------------------------------
Public Function CELen(ByVal strVal As String) As Long
Dim iLoop As Long
Dim iLen As Long
Dim iStrLen As Long
Dim sChar As String
strVal = Trim(strVal)
iStrLen = Len(strVal)
iLen = 0
For iLoop = 1 To iStrLen
sChar = Mid(strVal,iLoop,1)
If Len(Hex(Asc(sChar))) > 2 Then
iLen = iLen + 2
Else
iLen = iLen + 1
End If
Next iLoop
CELen = iLen
End Function
'-----------------------------------------------------------------------------------------
' 得出字串的左边的几个字，可用于中英文
'-----------------------------------------------------------------------------------------
Public Function CELeft(ByVal strVal As String,ByVal nLength As Long) As String
Dim iLoop As Long
Dim iLen As Long
Dim iStrLen As Long
Dim sChar As String
strVal = Trim(strVal)
iStrLen = Len(strVal)
iLen = 0
For iLoop = 1 To iStrLen
sChar = Mid(strVal,1)
If Len(Hex(Asc(sChar))) > 2 Then
iLen = iLen + 2
Else
iLen = iLen + 1
End If
If iLen > nLength Then Exit For
Next iLoop
CELeft = Left(strVal,iLoop - 1)
End Function
'-----------------------------------------------------------------------------------------
' 根据字段的内部类型，确认其为何种大类：数字、日期、字串
'-----------------------------------------------------------------------------------------
Public Function FieldTypeCategory(ByVal adtype As Integer) As String
Select Case adtype
Case adBigInt,_
adBinary,_
adBoolean,_
adCurrency,_
adDecimal,_
adDouble,_
adInteger,_
adLongVarBinary,_
adNumeric,_
adSingle,_
adSmallInt,_
adTinyInt,_
adUnsignedBigInt,_
adUnsignedInt,_
adUnsignedSmallInt,_
adUnsignedTinyInt,_
adVarBinary
FieldTypeCategory = "N"
Case adDate,_
adDBDate,_
adDBTime,_
adDBTimeStamp
FieldTypeCategory = "D"
Case Else
FieldTypeCategory = "S"
End Select
End Function
'-----------------------------------------------------------------------------------------
' 取得一个临时文件名，包括完整的路径名及名件名
'-----------------------------------------------------------------------------------------
Public Function getTempFileFullName(Optional ByVal psExtName As String = "") As String
getTempFileFullName = ""
Dim fso,tempfile
Set fso = CreateObject("Scripting.FileSystemObject")
Dim tfolder,tname
Const TemporaryFolder = 2
Set tfolder = fso.GetSpecialFolder(TemporaryFolder)
tname = fso.GetTempName
getTempFileFullName = sfTrim(tfolder & "/" & tname) & psExtName Set fso = NothingEnd Function （编辑：李大同）
【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
|
