VB6 中常用自定义功能函数合集

 


'-------------------------------------------------------------------------------------------------------------
' 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, vbFromUnicode), 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, psFile, 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, "/")
        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, FileNameOnly, ".")
        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", vbExclamation, "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, FileNameOnly, ".") = 0
        Pos1 = InStr(iStartPos, FileNameOnly, ".")
        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", vbExclamation, "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, psFormat, "M"))
    nDay = sfVal(GetValue(psDateStr, psFormat, "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 ! ", vbExclamation, "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, 2), "0#")
        'TimeFormat = Format(vValue, "HHMM")
    Else
        TimeFormat = Format(Left(vValue, 2), "0#") & ":" & Format(Right(vValue, 2), "0#")
        'TimeFormat = Format(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, iLoop, 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 = Nothing
End Function

阅读更多
想对作者说点什么? 我来说一句

常用QTP函数合集

2011年12月21日 48KB 下载

没有更多推荐了,返回首页

加入CSDN,享受更精准的内容推荐,与500万程序员共同成长!
关闭
关闭