cstring.cls

在线ZIP在线ZIP在线ZIP在线ZIP在线ZIP在线ZIP

End Sub

Public Sub TrimRight()
    RTrim m_szValue
End Sub

Public Function Find(Optional ByVal nStart As Long = 1, Optional ByVal szSubstr As String) As Long
    Find = InStr(nStart, m_szValue, szSubstr)
End Function

Public Function ReverseFind(ByVal szSubstr As String) As Long
    ReverseFind = InterfaceInStrRev(m_szValue, szSubstr)
End Function

Public Function FindOneOf(ByVal szCharSet As String) As Long
    If Not Len(m_szValue) > 0 Or Not Len(szCharSet) > 0 Then
        Exit Function
    End If
    
    Dim iPos As Long
    Dim i As Integer
    
    For i = 1 To Len(m_szValue)
        iPos = InStr(szCharSet, VBA.Mid(m_szValue, i, 1))
        If iPos <> 0 Then
            FindOneOf = iPos
            Exit Function
        End If
    Next
    
End Function

Public Sub AllocSysString(ByRef szString As String)
    szString = Space$(Length)
    
End Sub

Public Sub SetSysString(ByRef szString As String)
    szString = m_szValue
End Sub

Public Function Split(ByRef vBuf() As Variant, szDelim As String) As Long
    Split = InterfaceSplit(vBuf, m_szValue, szDelim)
End Function

Public Function GetParameter(ByVal szFormat As String, ByVal nRef As Integer) As String
    'This function doesn't fully work. If you want to fix it and post it, go ahead. Just remember
    'who wrote it originally =)
    
    Dim szTemp As String
    Dim nPos As Integer
    Dim thing As Variant
    Dim szBuf()
    nPos = 1
    szTemp = m_szValue
    
    If Not m_szValue Like szFormat Then Exit Function
    
    If VBA.Left(szFormat, 1) = "*" Then szFormat = " " & szFormat
    
    InterfaceSplit szBuf, szFormat, "*"
    
    For Each thing In szBuf
        szTemp = InterfaceReplace(szTemp, (thing), Chr(255) & Chr(1))
    Next
    
    InterfaceSplit szBuf, szTemp, Chr(255) & Chr(1)
    
    If nRef - 1 < LBound(szBuf) Or nRef - 1 > UBound(szBuf) Then Exit Function
    
    GetParameter = szBuf(nRef - 1)
    
    
End Function


Public Sub Sprintf(DefString As String, ParamArray TheVals() As Variant)


Dim DefLen As Integer, DefIdx As Integer
Dim CurIdx As Integer, WorkString As String
Dim CurVal As Integer, MaxVal As Integer
Dim CurFormat As String, ValCount As Integer
Dim xIndex As Integer, FoundV As Boolean, vType As Integer
Dim CurParm As String

    DefLen = Len(DefString)
    DefIdx = 1
    CurVal = 0
    MaxVal = UBound(TheVals) + 1
    ValCount = 0

    ' Check for equal number of 'flags' as values, raise an error if inequal

    Do
        CurIdx = InStr(DefIdx, DefString, "%")
        If CurIdx > 0 Then
            If VBA.Mid$(DefString, CurIdx + 1, 1) <> "%" Then ' don't count %%, will be converted to % later
                ValCount = ValCount + 1
                DefIdx = CurIdx + 1
            Else
                DefIdx = CurIdx + 2
            End If
        Else
            Exit Do
        End If
    Loop
    
    If ValCount <> MaxVal Then Err.Raise 450, , "Mismatch of parameters for string " & DefString & ".  Expected " & ValCount & " but received " & MaxVal & "."
       
    DefIdx = 1
    CurVal = 0
    ValCount = 0
    
    WorkString = ""
    
    Do
        CurIdx = InStr(DefIdx, DefString, "%")
        If CurIdx <> 0 Then
        ' First, get the variable identifier.  Scan from Defidx (the %) to EOL looking for the
        ' first occurance of s, d, l, or f
            FoundV = False
            vType = NONE
            xIndex = CurIdx + 1
            Do While FoundV = False
                If Not FoundV Then
                    CurParm = VBA.Mid$(DefString, xIndex, 1)
                    Select Case VBA.Mid$(DefString, xIndex, 1)
                        Case "%"
                            vType = CHARPERCENT
                            FoundV = True
                            CurIdx = CurIdx + 1
                            CurVal = xIndex + 2
                        Case "s"
                            vType = STRINGTYPE
                            FoundV = True
                            CurVal = xIndex + 1
                        Case "d"
                            vType = INTEGERTYPE
                            FoundV = True
                            CurVal = xIndex + 1
                        Case "l"
                            If VBA.Mid$(DefString, xIndex + 1, 1) = "d" Then
                                vType = LONGTYPE
                                FoundV = True
                                CurVal = xIndex + 2
                            Else
                                Err.Raise 93, , "Unrecognized pattern " & VBA.Mid$(DefString, xIndex - 1, 3) & " in " & DefString
                            End If
                        Case "f"
                            vType = FLOATTYPE
                            FoundV = True
                            CurVal = xIndex + 1
                    End Select
                End If
                If Not FoundV Then xIndex = xIndex + 1
            Loop
            If Not FoundV Then Err.Raise 93, , "Invalid % format in " & DefString
            CurParm = VBA.Mid$(DefString, CurIdx, CurVal - CurIdx) ' For debugging purposes
            
            If vType = CHARPERCENT Then
                WorkString = WorkString & VBA.Mid$(DefString, DefIdx, CurIdx - DefIdx)
                CurVal = CurVal - 1
            Else
                CurFormat = BuildFormat(CurParm, vType)
                WorkString = WorkString & VBA.Mid$(DefString, DefIdx, CurIdx - DefIdx) & Format$(TheVals(ValCount), CurFormat)
                ValCount = ValCount + 1
            End If
            DefIdx = CurVal
        Else
            WorkString = WorkString & VBA.Right$(DefString, Len(DefString) - DefIdx + 1)
            Exit Do
        End If
    Loop
    m_szValue = TreatBackSlash(WorkString)
End Sub


'********************************************************
'Utility Functions
'********************************************************

Private Function BuildFormat(Parm As String, DataType As Integer) As String
    Dim Prefix As String, TmpFmt As String

    If DataType = LONGTYPE Then Prefix = VBA.Mid$(Parm, 2, Len(Parm) - 3) Else Prefix = VBA.Mid$(Parm, 2, Len(Parm) - 2)

    Select Case InStr(Prefix, ".")
        Case 0, Len(Prefix)
            If VBA.Left$(Prefix, 1) = "0" Then TmpFmt = String(CInt(Prefix), "0") Else TmpFmt = "#"
        Case 1
            If VBA.Mid$(Prefix, 2, 1) = "0" Then TmpFmt = "#." & String(CInt(VBA.Right$(Prefix, 2)), "0") Else TmpFmt = "#.#"
        Case Else
            If VBA.Left$(Prefix, 1) = "0" Then TmpFmt = String(CInt(VBA.Left$(Prefix, InStr(Prefix, "."))), "0") & "." Else TmpFmt = "#."
            If VBA.Mid$(Prefix, InStr(Prefix, ".") + 1, 1) = "0" Then TmpFmt = TmpFmt & String(CInt(VBA.Right$(Prefix, InStr(Prefix, ".") - 1)), "0") Else TmpFmt = TmpFmt & "#"
    End Select

    BuildFormat = TreatBackSlash(TmpFmt)
End Function

Private Function TreatBackSlash(sLine As String) As String
      TreatBackSlash = sLine
      TreatBackSlash = InterfaceReplace(TreatBackSlash, "\n", vbCrLf)
      TreatBackSlash = InterfaceReplace(TreatBackSlash, "\r", vbCr)
      TreatBackSlash = InterfaceReplace(TreatBackSlash, "\t", vbTab)
      TreatBackSlash = InterfaceReplace(TreatBackSlash, "\b", vbBack)
      TreatBackSlash = InterfaceReplace(TreatBackSlash, "\0", vbNullString)
      TreatBackSlash = InterfaceReplace(TreatBackSlash, "\\", "\")
         
End Function

'If you have VB6, the proceeding functions are unnecessary
Private Function InterfaceReplace(ByVal strMain As String, strFind As String, strReplace As String) As String
    Dim lngSpot As Long, lngNewSpot As Long, strLeft As String
    Dim strRight As String, strNew As String
    lngSpot& = InStr(LCase(strMain$), LCase(strFind$))
    lngNewSpot& = lngSpot&
    Do
        If lngNewSpot& > 0& Then
            strLeft$ = VBA.Left(strMain$, lngNewSpot& - 1)
            If lngSpot& + Len(strFind$) <= Len(strMain$) Then
                strRight$ = VBA.Right(strMain$, Len(strMain$) - lngNewSpot& - Len(strFind$) + 1)
            Else
                strRight = ""
            End If
            strNew$ = strLeft$ & strReplace$ & strRight$
            strMain$ = strNew$
        Else
            strNew$ = strMain$
        End If
        lngSpot& = lngNewSpot& + Len(strReplace$)
        If lngSpot& > 0 Then
            lngNewSpot& = InStr(lngSpot&, LCase(strMain$), LCase(strFind$))
        End If
    Loop Until lngNewSpot& < 1
    InterfaceReplace$ = strNew$
End Function

Private Function InterfaceInStrRev(Optional Start, Optional String1, Optional String2)

Dim lngLastPos As Long, lngPos As Long, lngStartChar As Long
Dim strString As String
Dim strSearchString$


  'check to see if String2 is missing. If yes, then
  'the start argument wasn't given so automatically
  'give it the value of the length of String1.
  If IsMissing(String2) Then
    lngStartChar& = Len(Start)
    strString$ = CStr(Start)
    strSearchString$ = CStr(String1)
  Else
    lngStartChar& = CLng(Start)
    strString$ = CStr(String1)
    strSearchString$ = CStr(String2)
  End If

'if the string can't be found then exit
If InStr(strString$, strSearchString$) = 0 Then Exit Function

'loop through the text until lngPos is bigger than Start or equal to 0.
'then return the character position prior to that.

 Do
   DoEvents
   lngPos& = InStr(lngLastPos& + 1, strString$, strSearchString$)
   If lngPos& > lngStartChar& Or lngPos& = 0 Then Exit Do
   lngLastPos& = lngPos&
 Loop

InterfaceInStrRev = lngLastPos&

End Function

Private Function InterfaceSplit(vBuf() As Variant, sIn As String, sDel As String) As Long
    Dim i As Integer, x As Integer, s As Integer, t As Integer
    i = 0: s = 1: t = 1: x = 0
    ReDim tArr(0) As Variant


    If InStr(1, sIn, sDel) <> 0 Then
        Do
            ReDim Preserve tArr(0 To x) As Variant
            tArr(i) = VBA.Mid(sIn, t, InStr(s, sIn, sDel) - t)
            t = InStr(s, sIn, sDel) + Len(sDel)
            s = t
            If tArr(i) <> "" Then i = i + 1
            x = x + 1
        Loop Until InStr(s, sIn, sDel) = 0
        ReDim Preserve tArr(0 To x) As Variant
        tArr(i) = VBA.Mid(sIn, t, Len(sIn) - t + 1)
    Else
        tArr(0) = sIn
    End If
    For i = LBound(tArr) To UBound(tArr)
        ReDim Preserve vBuf(0 To UBound(tArr)) As Variant
        vBuf(i) = tArr(i)
    Next
    InterfaceSplit = UBound(tArr)
End Function