auxmoney - Geld leihen für das Studiumauxmoney - Geld leihen für das Studium

auxmoney - Geld leihen für den Umzugauxmoney - Geld leihen für den Umzug

String-Ersetzung mit Replace

String-Ersetzung mit 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, "&", "&amp;"
ReplaceDo HTMLEncode, """", "&quot;"
ReplaceDo HTMLEncode, "<", "&lt;"
ReplaceDo HTMLEncode, ">", "&gt;"
'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: Nichts 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

Mehr Tipps: Titel aus HTML-Datei auslesen

Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt