Rubrik: Variablen/Strings · String-Operationen | VB-Versionen: VB4, VB5, VB6 | 07.08.01 |
Blitzschnelle Replace-Funktion (auch für VB6) Eine Replace-Funktion, die schneller ist als die seit VB6 eingebaute... und korrekter | ||
Autor: Jost Schwider | Bewertung: | Views: 42.729 |
www.vb-tec.de | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | 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