vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Erstellen von dynamischen Kontextmen?s - wann immer Sie sie brauchen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Variablen/Strings · String-Operationen   |   VB-Versionen: VB4, VB5, VB607.08.01
Blitzschnelle Replace-Funktion (auch für VB6)

Eine Replace-Funktion, die schneller ist als die seit VB6 eingebaute... und korrekter

Autor:   Jost SchwiderBewertung:     [ Jetzt bewerten ]Views:  38.924 
www.vb-tec.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Eine wichtige Operation der Datenverarbeitung ist die Text-Ersetzung, welche in einer Zeichenkette (Text) alle Vorkommen eines bestimmten Strings (sOld) durch einen anderen String (sNew) ersetzt. Optional kann die Anzahl der Ersetzungen (Count), der gewünschte Vergleichsmodus (Compare, s.a. VB-Hilfe zur InStr-Funktion) sowie die Start-Position (führt in VB6 zu fehlerhaften Ergebnissen) angegeben werden.

Man beachte, dass diese Funktion deutlich schneller als die seit VB6 eingebaute Funktion ist, da keine Zeichenketten-Operationen verwendet werden, sondern ausschließlich das wenig bekannte Mid$-Statement. Ausserdem wird die Compare-Option vbTextCompare besonders effizient umgesetzt.

Die hier gezeigte Routine ist 100%ig Aufruf-kompatibel zu der in VB6 (bis natürlich auf den unsinnigen Start-Parameter-Bug in VB6).

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
 
  ' (c) Jost Schwider, VB-Tec.de
  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

Die oben gezeigte Funktion übernimmt die Verwaltung der Parameter und ggf. der Umsetzung der Groß-/Kleinschreibung. Die eigentliche Arbeit findet in folgender Prozedur statt:

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 _
  )
 
  ' (c) Jost Schwider, VB-Tec.de
  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 Überschreiben:
 
        Result = Text
        For Count = 1 To Count
          ' String "patchen":
          MidB$(Result, Start) = sNew
 
          ' Position aktualisieren:
          Start = InStrB(Start + OldLen, Search, sOld)
          If Start = 0 Then Exit Sub
        Next Count
        Exit Sub
 
      Case Is < OldLen ' Ergebnis wird kürzer:
 
        ' Buffer initialisieren:
        TextLen = LenB(Text)
        If TextLen > BufferLen Then
          Buffer = Text
          BufferLen = TextLen
        End If
 
        ' Ersetzen:
        ReadPos = 1
        WritePos = 1
        For Count = 1 To Count
          ' String "patchen":
          CopyLen = Start - ReadPos
          BufferPosNew = WritePos + CopyLen
          MidB$(Buffer, WritePos) = MidB$(Text, ReadPos _
            , CopyLen)
          MidB$(Buffer, BufferPosNew) = sNew
 
          ' Positionen aktualisieren:
          WritePos = BufferPosNew + NewLen
          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
          MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
          Result = LeftB$(Buffer, WritePos + _
            LenB(Text) - ReadPos)
        End If
        Exit Sub
 
     Case Else ' Ergebnis wird länger:
 
        ' 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
          ' Positionen berechnen:
          CopyLen = Start - ReadPos
          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
 
          ' Positionen aktualisieren:
          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 ' Kein Treffer:
    Result = Text
  End If
End Sub

Dieser Tipp wurde bereits 38.924 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel