misc.bas

VB做滴邮件收发系统,喜欢的朋友可以下载看看学习参考哈

    GetInfo = Replace(strValue, " ", "")

Exit Function

error:
    GetInfo = ""

End Function

'Returns the Line that contains a String (reversed for speed reasons)*
Public Function RevfindLine(SearchStr As String, ByRef strlines() As String) As Long

  Dim Counter As Long
  Dim TmpLngt As Long
  Dim TmpString As String

    On Error GoTo error

    TmpLngt = UBound(strlines)
    Counter = TmpLngt

    Do
        Counter = Counter - 1

        TmpString = strlines(Counter + 1)

        If InStr(TmpString, SearchStr) > 0 Then
            RevfindLine = Counter + 1
            Exit Function
        End If

    Loop Until Counter = 0

error:
    RevfindLine = -1

End Function

'Checks if a string contains a special seperated word
Public Function InStrWord( _
                          ByRef Text As String, _
                          ByRef Word As String _
                          ) As Long

  'Deklarationen:

  Dim WordLen As Long
  Dim TextEnd As Long
  Dim OK As Boolean

    WordLen = Len(Word)
    If WordLen = 0 Then
        Exit Function
    End If

    TextEnd = Len(Text) - WordLen + 1

    InStrWord = InStr(1, Text, Word, vbTextCompare)
    Do While InStrWord

        If InStrWord = 1 Then
            OK = True
          Else
            OK = IsWordSep(Mid$(Text, InStrWord - 1, 1))
        End If

        'Ggf. Zeichen hinter dem Wort checken:
        If OK And (InStrWord < TextEnd) Then
            OK = IsWordSep(Mid$(Text, InStrWord + WordLen, 1))
        End If

        'Treffer zur點kgeben oder weitersuchen:
        If OK Then
            Exit Do
        End If

        InStrWord = InStr(InStrWord + WordLen, Text, Word, vbTextCompare)

    Loop

End Function

'Returns true if a char is a known seperator
Public Function IsWordSep(ByVal Char As String) As Boolean

    If Char = " " Or Char = vbCr Or Char = vbLf Or Char = vbTab Or Char = Chr$(34) Or Char = vbCrLf Or Char = "-" Then
        IsWordSep = True
    End If

End Function



'**************************************************************************************
'Replace function
'
'Author: unknown
'
'Desc:
'
'this functions are a lot faster than the original functions and usefull
'for VB5 User
''**************************************************************************************

Public Function Replace(ByRef Text As String, _
                        ByRef sOld As String, ByRef sNew As String, _
                        Optional ByVal Start As Long = 1, _
                        Optional ByVal Count As Long = 2147483647, _
                        Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
                        ) As String

    If LenB(sOld) Then

        If Compare = vbBinaryCompare Then
            ReplaceBin Replace, Text, Text, _
                       sOld, sNew, Start, Count
          Else
            ReplaceBin Replace, Text, LCase$(Text), _
                       LCase$(sOld), sNew, Start, Count
        End If

      Else 'Suchstring ist leer:
        Replace = Text
    End If

End Function

Private Static Sub ReplaceBin(ByRef Result As String, _
                ByRef Text As String, ByRef Search As String, _
                ByRef sOld As String, ByRef sNew As String, _
                ByVal Start As Long, ByVal Count As Long _
                )

  Dim TextLen As Long
  Dim OldLen As Long
  Dim NewLen As Long
  Dim ReadPos As Long
  Dim WritePos As Long
  Dim CopyLen As Long
  Dim Buffer As String
  Dim BufferLen As Long
  Dim BufferPosNew As Long
  Dim BufferPosNext As Long

    'Ersten Treffer bestimmen:
    If Start < 2 Then
        Start = InStrB(Search, sOld)
      Else
        Start = InStrB(Start + Start - 1, Search, sOld)
    End If
    If Start Then

        OldLen = LenB(sOld)
        NewLen = LenB(sNew)
        Select Case NewLen
          Case OldLen 'einfaches 躡erschreiben:

            Result = Text
            For Count = 1 To Count
                MidB$(Result, Start) = sNew
                Start = InStrB(Start + OldLen, Search, sOld)
                If Start = 0 Then
                    Exit Sub
                End If
            Next Count
            Exit Sub

          Case Is < OldLen 'Ergebnis wird k黵zer:

            'Buffer initialisieren:
            TextLen = LenB(Text)
            If TextLen > BufferLen Then
                Buffer = Text
                BufferLen = TextLen
            End If

            'Ersetzen:
            ReadPos = 1
            WritePos = 1
            If NewLen Then

                'Einzuf黦enden Text beachten:
                For Count = 1 To Count
                    CopyLen = Start - ReadPos
                    If CopyLen Then
                        BufferPosNew = WritePos + CopyLen
                        MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
                        MidB$(Buffer, BufferPosNew) = sNew
                        WritePos = BufferPosNew + NewLen
                      Else
                        MidB$(Buffer, WritePos) = sNew
                        WritePos = WritePos + NewLen
                    End If
                    ReadPos = Start + OldLen
                    Start = InStrB(ReadPos, Search, sOld)
                    If Start = 0 Then
                        Exit For
                    End If
                Next Count

              Else

                'Einzuf黦enden Text ignorieren (weil leer):
                For Count = 1 To Count
                    CopyLen = Start - ReadPos
                    If CopyLen Then
                        MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
                        WritePos = WritePos + CopyLen
                    End If
                    ReadPos = Start + OldLen
                    Start = InStrB(ReadPos, Search, sOld)
                    If Start = 0 Then
                        Exit For
                    End If
                Next Count

            End If

            'Ergebnis zusammenbauen:
            If ReadPos > TextLen Then
                Result = LeftB$(Buffer, WritePos - 1)
              Else
                MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
                Result = LeftB$(Buffer, WritePos + LenB(Text) - ReadPos)
            End If
            Exit Sub

          Case Else 'Ergebnis wird l鋘ger:

            'Buffer initialisieren:
            TextLen = LenB(Text)
            BufferPosNew = TextLen + NewLen
            If BufferPosNew > BufferLen Then
                Buffer = Space$(BufferPosNew)
                BufferLen = LenB(Buffer)
            End If

            'Ersetzung:
            ReadPos = 1
            WritePos = 1
            For Count = 1 To Count
                CopyLen = Start - ReadPos
                If CopyLen Then
                    'Positionen berechnen:
                    BufferPosNew = WritePos + CopyLen
                    BufferPosNext = BufferPosNew + NewLen

                    'Ggf. Buffer vergr鲞ern:
                    If BufferPosNext > BufferLen Then
                        Buffer = Buffer & Space$(BufferPosNext)
                        BufferLen = LenB(Buffer)
                    End If

                    'String "patchen":
                    MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
                    MidB$(Buffer, BufferPosNew) = sNew
                  Else
                    'Position bestimmen:
                    BufferPosNext = WritePos + NewLen

                    'Ggf. Buffer vergr鲞ern:
                    If BufferPosNext > BufferLen Then
                        Buffer = Buffer & Space$(BufferPosNext)
                        BufferLen = LenB(Buffer)
                    End If

                    'String "patchen":
                    MidB$(Buffer, WritePos) = sNew
                End If
                WritePos = BufferPosNext
                ReadPos = Start + OldLen
                Start = InStrB(ReadPos, Search, sOld)
                If Start = 0 Then Exit For
            Next Count

            'Ergebnis zusammenbauen:
            If ReadPos > TextLen Then
                Result = LeftB$(Buffer, WritePos - 1)
              Else
                BufferPosNext = WritePos + TextLen - ReadPos
                If BufferPosNext < BufferLen Then
                    MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
                    Result = LeftB$(Buffer, BufferPosNext)
                  Else
                    Result = LeftB$(Buffer, WritePos - 1) & MidB$(Text, ReadPos)
                End If
            End If
            Exit Sub

        End Select

      Else
        Result = Text
    End If

End Sub

Public Sub MoveStringArray(Source() As String, dest() As String, firstEl As Long, lastEL As Long)

  Dim numBytes As Long


On Error GoTo error

    numBytes = (lastEL - firstEl + 1) * 4
    ' start with a fresh new array
    '(it clears all its descriptors)
    ReDim dest(0 To lastEL - firstEl) As String
    ' copy all the descriptors from source() to dest()
    CopyMemory ByVal VarPtr(dest(0)), _
               ByVal VarPtr(Source(firstEl)), numBytes
    ' manually clear all the descriptors in source()
    ZeroMemory ByVal VarPtr(Source(firstEl)), numBytes

error:
End Sub



':) Ulli's VB Code Formatter V2.12.7 (19.06.2002 23:13:06) 48 + 401 = 449 Lines