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

最新推荐文章于 2024-07-31 18:03:48 发布

DJ2008

最新推荐文章于 2024-07-31 18:03:48 发布

阅读量4.3k

点赞数 1

分类专栏：技术相关 .Net VB + VBA 文章标签： vb function string integer file path

本文链接：https://blog.csdn.net/DJ2008/article/details/5639748

版权

技术相关同时被 3 个专栏收录

130 篇文章 1 订阅

订阅专栏

.Net

113 篇文章 0 订阅

订阅专栏

VB + VBA

20 篇文章 0 订阅

订阅专栏

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