'-------------------------------------------------------------------------------------------------------------
' 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