| Replace |
|
|
| Eine der wichtigsten Operationen der Datenverarbeitung ist die |
| Text-Ersetzung, welche in einer Zeichenkette alle Vorkommen |
| eines bestimmten Strings (strOld) durch einen anderen String |
| (strNew) ersetzt. |
| Optional kann die Anzahl der Ersetzungen (Count) und der gewünschte |
| Vergleichsmodus (Compare) angegeben werden. |
|
| Beispiele: |
| Nur kleine "n" durch "M" ersetzen: |
| strNew = Replace(strOld, "n", "M") |
|
| Alle "n" und "N" durch "M" ersetzen: |
| strNew = Replace(strOld, "n", "M", Compare:=vbTextCompare) |
|
| In strOld "Newline" durch HTML-Tag ersetzen: |
| ReplaceDo strOld, vbNewLine, "<br>" |
| |
|
| Diese Funktion kodiert einen Text derart, dass er innerhalb von HTML-Tags stehen kann: |
| Function HTMLEncode(ByRef Text As String) As String |
| Dim i As Long |
| Dim Char As Integer |
|
| 'HTML-Spezies ersetzen: |
| HTMLEncode = Text |
| ReplaceDo HTMLEncode, "&", "&" |
| ReplaceDo HTMLEncode, """", """ |
| ReplaceDo HTMLEncode, "<", "<" |
| ReplaceDo HTMLEncode, ">", ">" |
|
| 'Sonderzeichen durch Asc-Code ersetzen: |
| For i = Len(HTMLEncode) To 1 Step -1 |
| Char = Asc(Mid$(HTMLEncode, i, 1)) |
| Select Case Char: |
| Case Is < 32, Is >= 160 |
| HTMLEncode = Left$(HTMLEncode, i - 1) _ |
| & "&#" & Char & ";" & Mid$(HTMLEncode, i + 1) |
| End Select |
| Next i |
| End Function |
| |
|
| 'Diese Funktion übernimmt die Verwaltung der Parameter und ggf. der |
| 'Umsetzung der Groß-/Kleinschreibung: |
| Public Function Replace(ByRef Text As String, _ |
| ByRef strOld As String, ByRef strNew As String, _ |
| Optional ByVal Start As Long = 1, _ |
| Optional ByVal Count As Long = 2147483647, _ |
| Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String |
| |
| If LenB(strOld) = 0 Then |
| 'Suchstring ist leer: |
| Replace = Text |
| ElseIf ContainsOnly0(strOld) Then |
| 'Unicode-Problem, also kein LenB und co. verwenden: |
| ReplaceBin0 Replace, Text, Text, strOld, strNew, Start, Count |
| ElseIf Compare = vbBinaryCompare Then |
| 'Groß-/Kleinschreibung unterscheiden: |
| ReplaceBin Replace, Text, Text, strOld, strNew, Start, Count |
| Else |
| 'Groß-/Kleinschreibung ignorieren: |
| ReplaceBin Replace, Text, LCase$(Text), LCase$(strOld), strNew, Start, Count |
| End If |
| End Function |
| |
|
| 'In dieser Prozedur muss keine Rückgabevariable verwaltet werden: |
| Sub ReplaceDo(ByRef Text As String, _ |
| ByRef strOld As String, ByRef strNew As String, _ |
| Optional ByVal Start As Long = 1, _ |
| Optional ByVal Count As Long = 2147483647, _ |
| Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) |
|
| If LenB(strOld) = 0 Then |
| 'Suchstring ist leer: Nix machen! |
| ElseIf ContainsOnly0(strOld) Then |
| 'Unicode-Problem, also kein LenB und co. verwenden: |
| ReplaceBin0 Text, Text, Text, strOld, strNew, Start, Count |
| ElseIf Compare = vbBinaryCompare Then |
| 'Groß/Kleinschreibung unterscheiden: |
| If InStr(Start, Text, strOld, vbBinaryCompare) Then _ |
| ReplaceBin Text, Text, Text, strOld, strNew, Start, Count |
| Else |
| 'Groß/Kleinschreibung ignorieren: |
| If InStr(Start, Text, strOld, vbTextCompare) Then _ |
| ReplaceBin Text, Text, LCase$(Text), LCase$(strOld), strNew, Start, Count |
| End If |
| End Sub |
| |
|
| 'Kleine Hilfsfunktion wegen der Unicode-Problematik: |
| Function ContainsOnly0(ByRef s As String) As Boolean |
| Dim i As Long |
| For i = 1 To Len(s) |
| If Asc(Mid$(s, i, 1)) Then Exit Function |
| Next i |
| ContainsOnly0 = True |
| End Function |
| |
|
| '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 strOld As String, ByRef strNew 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, strOld) |
| Else |
| Start = InStrB(Start + Start - 1, Search, strOld) |
| End If |
| If Start Then |
|
| OldLen = LenB(strOld) |
| NewLen = LenB(strNew) |
| Select Case NewLen |
|
| 'einfaches Überschreiben: |
| Case OldLen |
| Result = Text |
| For Count = 1 To Count |
| MidB$(Result, Start) = strNew |
| Start = InStrB(Start + OldLen, Search, strOld) |
| If Start = 0 Then Exit Sub |
| Next Count |
| Exit Sub |
| |
| 'Ergebnis wird kürzer: |
| Case Is < OldLen |
| 'Buffer initialisieren: |
| TextLen = LenB(Text) |
| If TextLen > BufferLen Then |
| Buffer = Text |
| BufferLen = TextLen |
| End If |
| |
| 'Ersetzen: |
| ReadPos = 1 |
| WritePos = 1 |
| If NewLen Then |
| |
| 'Einzufügenden 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) = strNew |
| WritePos = BufferPosNew + NewLen |
| Else |
| MidB$(Buffer, WritePos) = strNew |
| WritePos = WritePos + NewLen |
| End If |
| ReadPos = Start + OldLen |
| Start = InStrB(ReadPos, Search, strOld) |
| If Start = 0 Then Exit For |
| Next Count |
| |
| Else |
| |
| 'Einzufügenden 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, strOld) |
| If Start = 0 Then Exit For |
| 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 |
| |
| 'Ergebnis wird länger: |
| Case Else |
| '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) = strNew |
| 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) = strNew |
| End If |
| WritePos = BufferPosNext |
| ReadPos = Start + OldLen |
| Start = InStrB(ReadPos, Search, strOld) |
| 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 |
|
| 'Kein Treffer: |
| Else |
| Result = Text |
| End If |
| End Sub |
| |
|
| 'Die gleiche Routine nochmal, allerdings mit den etwas langsameren |
| 'String-Funktionen (d.h. Len statt LenB, InStr statt InStrB u.ä.): |
| Private Static Sub ReplaceBin0(ByRef Result As String, _ |
| ByRef Text As String, ByRef Search As String, _ |
| ByRef strOld As String, ByRef strNew 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 = InStr(Search, strOld) |
| Else |
| Start = InStr(Start, Search, strOld) |
| End If |
|
| If Start Then |
| OldLen = Len(strOld) |
| NewLen = Len(strNew) |
| Select Case NewLen |
|
| 'einfaches Überschreiben: |
| Case OldLen |
| Result = Text |
| For Count = 1 To Count |
| Mid$(Result, Start) = strNew |
| Start = InStr(Start + OldLen, Search, strOld) |
| If Start = 0 Then Exit Sub |
| Next Count |
| Exit Sub |
| |
| 'Ergebnis wird kürzer: |
| Case Is < OldLen |
| 'Buffer initialisieren: |
| TextLen = Len(Text) |
| If TextLen > BufferLen Then |
| Buffer = Text |
| BufferLen = TextLen |
| End If |
| |
| 'Ersetzen: |
| ReadPos = 1 |
| WritePos = 1 |
| If NewLen Then |
| |
| 'Einzufügenden Text beachten: |
| For Count = 1 To Count |
| CopyLen = Start - ReadPos |
| If CopyLen Then |
| BufferPosNew = WritePos + CopyLen |
| Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen) |
| Mid$(Buffer, BufferPosNew) = strNew |
| WritePos = BufferPosNew + NewLen |
| Else |
| Mid$(Buffer, WritePos) = strNew |
| WritePos = WritePos + NewLen |
| End If |
| ReadPos = Start + OldLen |
| Start = InStr(ReadPos, Search, strOld) |
| If Start = 0 Then Exit For |
| Next Count |
| |
| Else |
| |
| 'Einzufügenden Text ignorieren (weil leer): |
| For Count = 1 To Count |
| CopyLen = Start - ReadPos |
| If CopyLen Then |
| Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen) |
| WritePos = WritePos + CopyLen |
| End If |
| ReadPos = Start + OldLen |
| Start = InStr(ReadPos, Search, strOld) |
| If Start = 0 Then Exit For |
| Next Count |
| |
| End If |
| |
| 'Ergebnis zusammenbauen: |
| If ReadPos > TextLen Then |
| Result = Left$(Buffer, WritePos - 1) |
| Else |
| Mid$(Buffer, WritePos) = Mid$(Text, ReadPos) |
| Result = Left$(Buffer, WritePos + Len(Text) - ReadPos) |
| End If |
| Exit Sub |
| |
| 'Ergebnis wird länger: |
| Case Else |
| 'Buffer initialisieren: |
| TextLen = Len(Text) |
| BufferPosNew = TextLen + NewLen |
| If BufferPosNew > BufferLen Then |
| Buffer = Space$(BufferPosNew) |
| BufferLen = Len(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 = Len(Buffer) |
| End If |
| |
| 'String "patchen": |
| Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen) |
| Mid$(Buffer, BufferPosNew) = strNew |
| Else |
| 'Position bestimmen: |
| BufferPosNext = WritePos + NewLen |
| |
| 'Ggf. Buffer vergrößern: |
| If BufferPosNext > BufferLen Then |
| Buffer = Buffer & Space$(BufferPosNext) |
| BufferLen = Len(Buffer) |
| End If |
| |
| 'String "patchen": |
| Mid$(Buffer, WritePos) = strNew |
| End If |
| WritePos = BufferPosNext |
| ReadPos = Start + OldLen |
| Start = InStr(ReadPos, Search, strOld) |
| If Start = 0 Then Exit For |
| Next Count |
| |
| 'Ergebnis zusammenbauen: |
| If ReadPos > TextLen Then |
| Result = Left$(Buffer, WritePos - 1) |
| Else |
| BufferPosNext = WritePos + TextLen - ReadPos |
| If BufferPosNext < BufferLen Then |
| Mid$(Buffer, WritePos) = Mid$(Text, ReadPos) |
| Result = Left$(Buffer, BufferPosNext) |
| Else |
| Result = Left$(Buffer, WritePos - 1) & Mid$(Text, ReadPos) |
| End If |
| End If |
| Exit Sub |
| |
| End Select |
|
| 'Kein Treffer: |
| Else |
| Result = Text |
| End If |
| End Sub |
|
zurück