infobase: EDV - MS-Access
Zeichenketten
Anzahl und Vorkommen
Quelle: dmt
Datum: 04.2006
ANZAHL VORKOMMEN ZEICHEN IN ZEICHENKETTE:
Die folgende Funktion ermittelt die Anzahl des Vorkommens eines Zeichens in einer gegebenen Zeichenkette:
Neu hinzugekommen ist die Akzeptanz von "" für den Parameter sZeichen.
Dadurch konnte eine Endlosschleife ausgelöst werden, jetzt wird die Anzahl aller Zeichen zurückgegeben.
Function CountInStr(sString As String, sZeichen As String) As Long
On Error GoTo err_CountInStr
Dim p As Long, x As Long
If sZeichen = "" Then
CountInStr = Len(sString)
Exit Function
End If
Do
p = InStr(p + 1, sString, sZeichen)
If p > 0 Then
x = x + 1
Else
Exit Do
End If
Loop
CountInStr = x
Exit Function
err_CountInStr:
Fehler "CountInStr"
Exit Function
End Function
* * * *
Davon lassen sich auch schöne Funktionen ableiten -> ANZAHL von WÖRTERN in einer ZEICHENKETTE:
Function SumWordsInStr (sString As String) As Integer
On Error GoTo err_SumWordsInStr
SumWordsInStr = CountInStr(sString, " ") + 1
Exit Function
err_SumWordsInStr:
Fehler "SumWordsInStr"
Exit Function
End Function
* * * *
Und als Krönung dann: Lies das n-te WORT aus einer ZEICHENKETTE aus !
Function GetWordFromStr (iWord As Integer, sString As String) As String
On Error GoTo err_GetWordFromStr
Dim s As String
Dim iSumWords As Integer, iAnzBlanks As Integer, iPos1 As Integer, iPos2 As Integer
iSumWords = CountWordsInStr(sString)
If iWord < 1 Or iWord > iSumWords Then
'Beep
'MsgBox "Ungültiger Parameter '" & i & "' für Wortnummer !", 16, "GetWordFromStr"
GetWordFromStr = ""
Else
If iWord = 1 Then ' erstes Wort
If iWord = iSumWords Then
s = sString
Else
s = Left$(sString, InStr(sString, " ") - 1)
End If
ElseIf iWord = iSumWords Then ' letztes Wort bei n>1 Wörtern
s = Right$(sString, Len(sString) - LastInStr(sString, " "))
Else
iPos1 = InStrX(sString, " ", iWord - 1)
iPos2 = InStrX(sString, " ", iWord)
s = Mid$(sString, iPos1 + 1, iPos2 - iPos1 - 1)
End If
GetWordFromStr = s
End If
Exit Function
err_GetWordFromStr:
Fehler "GetWordFromStr"
Exit Function
End Function
* * * *
Aufgrund seiner Gekapseltheit trotz der Kürze schon wieder kryptisch ist:
Function GetLastWordFromString (sString As String) As String
On Error GoTo err_GetLastWordFromString
GetLastWordFromString = GetWordFromStr(CountWordsInStr(sString), sString)
Exit Function
err_GetLastWordFromString:
Fehler "GetLastWordFromString"
Exit Function
End Function
auswerten
Quelle: dmt
Datum: 03.2004
POSITION des n-ten ZEICHEN in ZEICHENKETTE:
Direkt abgeleitet vom vorigen Beispiel ist InStrX. Es ermittelt die Position des n-ten Vorkommens eines Zeichens in einer Zeichenkette. Kommen weniger als n Zeichen in der Zeichenkette vor, wird 0 als 'ungültiger Wert' zurückgegeben.
Function InStrX (sString As String, sZeichen As String, iNr As Integer) As Integer
On Error GoTo err_InstrX
Dim p As Integer, x As Integer, iLastPos As Integer
Do
p = InStr(p + 1, sString, sZeichen)
If p > 0 And iNr > x Then
x = x + 1
iLastPos = p
Else
Exit Do
End If
Loop
If iNr > x Then
InStrX = 0
Else
InStrX = iLastPos
End If
Exit Function
err_InstrX:
Fehler "InstrX"
Exit Function
End Function
* * * *
LETZTES VORKOMMEN ZEICHEN IN ZEICHENKETTE:
LastInStr ermittelt die Position des letzten Vorkommens eines Zeichens in einer gegebenen Zeichenkette:
Function LastInStr (sString As String, sZeichen As String) As Integer
On Error GoTo err_LastInStr
Dim p As Integer, x As Integer
Do
p = InStr(p + 1, sString, sZeichen)
If p > 0 Then
x = p
Else
Exit Do
End If
Loop
LastInStr = x
Exit Function
err_LastInStr:
Fehler "LastInStr"
Exit Function
End Function
* * * *
Ermitteln des WHERE-KRITERIUMS eines Sql-Statements, um z.B. ein DLookup-Kriterium zu bilden:
Function Get_WhereCrit (sSqlStatement As String) As String
On Error GoTo err_Get_WhereCrit
Dim iPos As Integer
Const W = "WHERE "
iPos = InStr(sSqlStatement, W)
If iPos > 0 Then
Get_WhereCrit = Mid$(sSqlStatement, iPos + Len(W))
End If
Exit Function
err_Get_WhereCrit:
Fehler "Get_WhereCrit"
Exit Function
End Function
* * * *
Text und darin enthaltene Sonderzeichen in einer Schleife durchlaufen:
Bei Wunsch, in html-Dateien enthaltene Tags aus zu lesen, liefert folgende Routine der Reihe nach entsprechende Teil-Abschnitte:
Obendrein wird eine jeweils neu gefundene Zeichenkette einer Variablen angefügt, die außerhalb der Routine vereinbart wurde.
Somit können Neu-Vorkommen anhand schneller String-Vergleiche durch geführt werden, obwohl die gefundenen Daten z.B. in einer Tabelle landen, in der man die Vergleiche per jeweils einzelnem DLookup hätte abchecken müssen.
Beispiel für das Ermitteln von tags:
Do
' Tag-Start und -Ende-Positionen ermitteln
p1 = InStr(p2 + 1, s, TAGBEGINN)
If p1 = 0 Then Exit Do
p2 = InStr(p1 + 1, s, TAGENDE)
' Neu-Vorkommen prüfen und evtl. Daten in Tabelle speichern
sTag = Mid$(s, p1, p2 - p1 + 1)
If InStr(sFoundTags, sTag) = 0 Then ' aha, ein neuer
sFoundTags = sFoundTags & " " & sTag
Debug.Print sTag
End If
Loop
Beispiel für das Zeilen-bezogene Zerlegen von Text:
Do ' Zeilen auslesen
' Startposition ermitteln
If p2 = 0 Then
p1 = 1
Else
p1 = p2 + 2
End If
' Ende-Position ermitteln, Abbruch oder Datei öffnen
p2 = InStr(p1 + 1, sContent, vbCrLf)
If p2 = 0 Then Exit Do
s = Mid$(sContent, p1, p2 - p1)
Loop
sContent enthält den Text, s den Inhalt der einzelnen Zeilen.
* * * *
SAMMELN von STICHWÖRTERN und WÖRTERN allgemein:
GatherKeywords ist typisches Utility für den Bereich der Literatur-Recherche u.ä.
In diesem Beispiel dient es dazu, parallel zur keyword-Liste einer Haupt-Index-Html-Datei (hier der Parameter vKeywords) die keyword-Listen untergeordneter html-Dateien (deren keyword-Daten hier in einem Recordset zur Verfügung stehen) hinzu zu fügen.
Die Routine kann die Unterlisten in einzelne Begriffe (auch zusammengesetzte) zerlegen und für jeden gefundenen Begriff prüfen, ob er in der übergeordneten Keyword-Liste oder in der anwachsenden Unterlisten-Ansammlung bereits enthalten ist.
Private Function GatherKeywords(vKeywords As Variant) As String
On Error GoTo err_GatherKeywords
Dim RS As Recordset, v As Variant, v2 As Variant, vGather As Variant, iPos1 As Integer, iPos2 As Integer
Set RS = Me!UF_Bildbeschreibungen.Form.RecordsetClone
RS.MoveFirst
Do While Not RS.EOF
v = RS("Keywords")
If Not IsNull(v) Then
GoSub split_GatherKeywords
End If
RS.MoveNext
Loop
If Right$(Trim(vKeywords), 1) <> "," And Len(vGather) > 0 Then
vKeywords = vKeywords & ", "
End If
v = vKeywords & vGather
Set RS = Nothing
GatherKeywords = CStr(v)
Exit Function
split_GatherKeywords:
' der abzuklappernde String wird auf jeden Fall von Kommata umrahmt, um die Paarbildung zu erleichtern
iPos1 = 1
If Left$(v, 1) <> "," Then v = "," & v
If Right$(v, 1) <> "," Then v = v & ","
Do While iPos1 < Len(v)
iPos1 = InStr(iPos1, v, ",") + 1
If iPos1 >= Len(v) Then Exit Do
If iPos1 = 0 Then
Exit Do
Else
iPos2 = InStr(iPos1, v, ",") - 1
If iPos2 = 0 Then
Exit Do
Else
v2 = Trim$(Mid(v, iPos1, iPos2 - iPos1 + 1))
If InStr(vKeywords, v2) = False And InStr(vGather, v2) = False Then
If Len(vGather) > 0 Then vGather = vGather & ", "
vGather = vGather & v2
End If
iPos1 = iPos2
End If
End If
Loop
Return
err_GatherKeywords:
Fehler "GatherKeywords"
Exit Function
End Function
GatherWords sammelt ebenfalls verschiedene Wörter.
Es ist im Kern simpler und kann durch Parameter-Steuerung vielseitig eingesetzt werden, bis hin zur Sortierung der gebildeten Textdaten:
Function GatherWords (s As String, sSeparator_vorher As String, sSeparator_nachher As String, iSort As Integer) As String
On Error GoTo err_GatherWords
Dim sListe As String, sWert As String, sSeparator As String
Dim iPos As Integer, iPosStart As Integer, i As Integer
ReDim arr(1024) As String
Dim i1%, i2%, Wert1, Wert2
i = 0
iPosStart = 1
Do
iPos = InStr(iPosStart, s, sSeparator_vorher)
If iPos > 0 Then
sWert = Trim$(Mid$(s, iPosStart, iPos - iPosStart))
If InStr(sListe, sWert) = 0 Then
arr(i) = sWert
' Debug.Print sWert
i = i + 1
sListe = sListe & sSeparator_nachher & sWert
End If
iPosStart = iPos + 1
Else
sWert = Trim$(Mid$(s, iPosStart))
If InStr(sListe, sWert) = 0 Then
arr(i) = sWert
' Debug.Print sWert
i = i + 1
sListe = sListe & sSeparator_nachher & sWert
End If
Exit Do
End If
Loop
' **** überflüssiges, erstes sSeparator_nachher entfernen ****
If Len(sListe) > 0 Then
If Left$(sListe, 1) = sSeparator_nachher Then
sListe = Mid$(sListe, 2)
End If
End If
' **** sListe enthält jetzt die neue Distinct-Liste und arr das Array-Pendant ****
If iSort = True Then
ReDim Preserve arr(i)
' **** Array sortieren ****
For i1% = 0 To UBound(arr) - 1
For i2% = i1% + 1 To UBound(arr) - 1
Wert1 = arr(i1%)
Wert2 = arr(i2%)
If Wert2 < Wert1 Then
arr(i1%) = Wert2
arr(i2%) = Wert1
End If
Next i2%
Next i1%
' **** Liste neu erzeugen ****
sListe = ""
For i1% = 0 To UBound(arr) - 1
sListe = sListe & arr(i1%) & sSeparator_nachher
Next i1%
sListe = Left$(sListe, Len(sListe) - 1)
End If
GatherWords = sListe
Exit Function
err_GatherWords:
Fehler "GatherWords"
Exit Function
End Function
* * * *
Extrahiere einzelne Wörter:
Manchmal kommt es vor, daß aus einer Zeichenkette einige Wörter extrahiert werden müssen. Damit nicht jedesmal das Instr- und Mid-Rad neu erfunden werden muß, hier ein einfaches Code-Beispiel. Da die drei Segmente formal ähnlich sind, könnte man so etwas sogar im Rahmen einer iterativen Schleife abchecken; allerdings müßten dann die Variablenzuweisungen an das n-te Element einer Arrayvariablen erfolgen.
' **** Extrahiere die ersten drei Wörter ****
iPos1 = 1
iPos2 = InStr(iPos1, v, " ")
If iPos2 = 0 Then
s1 = v
Else
s1 = Mid$(v, iPos1, iPos2 - iPos1)
End If
iPos1 = iPos2 + 1
iPos2 = InStr(iPos1, v, " ")
If iPos2 <> 0 Then s2 = Mid$(v, iPos1, iPos2 - iPos1)
iPos1 = iPos2 + 1
iPos2 = InStr(iPos1, v, " ")
If iPos2 <> 0 Then s3 = Mid$(v, iPos1, iPos2 - iPos1)
Auf die Spitze getrieben müssen im konkreten Anwendungsfall noch ein paar Dinge mehr erledigt werden. Als Beispiel hier eine komplette Funktion:
Private Function Get_Where () As String
On Error GoTo err_Get_Where
Dim v As Variant
Dim iPos1 As Integer, iPos2 As Integer
Dim sWhere As String, sOrder As String
Dim s1 As String, s2 As String, s3 As String
v = Me!Adresse1
If IsNull(v) Then
sWhere = "Ort LIKE '*" & Left$(Me!Ort, 4) & "*'"
sOrder = " ORDER BY Strasse;"
Else
' **** Extrahiere die ersten drei Wörter ****
iPos1 = 1
iPos2 = InStr(iPos1, v, " ")
If iPos2 = 0 Then
s1 = v
Else
s1 = Mid$(v, iPos1, iPos2 - iPos1)
End If
iPos1 = iPos2 + 1
iPos2 = InStr(iPos1, v, " ")
If iPos2 > 0 Then
s2 = Mid$(v, iPos1, iPos2 - iPos1)
Else
s2 = Mid$(v, iPos1)
End If
iPos1 = iPos2 + 1
iPos2 = InStr(iPos1, v, " ")
If iPos2 <> 0 Then
s3 = Mid$(v, iPos1, iPos2 - iPos1)
Else
s3 = Mid$(v, iPos1)
End If
' **** doppelte ausblenden ****
If s1 = s2 Then s2 = ""
If s3 = s1 Or s3 = s2 Then s3 = ""
' **** einzelne Suchpattern bilden ****
If Len(s1) > 6 Then ' LIKE-Pattern nur
s1 = "Suchname LIKE '*" & Left$(s1, 6) & "*'" ' bei längeren Begriffen
Else
s1 = "Suchname LIKE '*" & s1 & "*'"
End If ' -> Anti-Tippfehler
If Len(s2) < 4 Then ' Artikel und Präpositionen
s2 = "" ' ausblenden
ElseIf Len(s2) > 6 Then ' LIKE-Pattern nur
s2 = "Suchname LIKE '*" & Left$(s2, 6) & "*'" ' bei längeren Begriffen
Else
s2 = "Suchname LIKE '*" & s2 & "*'"
End If ' -> Anti-Tippfehler
If Len(s3) < 4 Then ' Artikel und Präpositionen
s3 = "" ' ausblenden
ElseIf Len(s3) > 6 Then ' LIKE-Pattern nur
s3 = "Suchname LIKE '*" & Left$(s3, 6) & "*'" ' bei längeren Begriffen
Else
s3 = "Suchname LIKE '*" & s3 & "*'"
End If ' -> Anti-Tippfehler
' **** WHERE-Bedingung korrekt zusammenbauen ****
sWhere = s1
If Len(s2) > 0 Then
sWhere = sWhere & " OR " & s2
End If
If Len(s3) > 0 Then
sWhere = sWhere & " OR " & s3
End If
' ****
sOrder = " ORDER BY Suchname, Plz;"
End If
Get_Where = sWhere & sOrder
Exit Function
err_Get_Where:
Fehler "Get_Where"
Get_Where = "NULL"
Exit Function
End Function
Großschreibung, Kapitale
Quelle: dmt
Datum: 03.2004
CCASE:
wandelt als eigene Erweiterung der Lcase- und UCase-Funktionen eine Zeichenkette so um, daß das erste Zeichen ein Großbuchstabe ist und alle folgenden Kleinbuchstaben sind.
Function CCase (s As String) As String
' **** Nur erster Buchstabe als Großbuchstabe ****
On Error GoTo err_CCase
s = LCase(s)
CCase = UCase(Left$(s, 1)) & Right$(s, Len(s) - 1)
Exit Function
err_CCase:
Fehler "CCase"
Exit Function
End Function
* * * *
eine Variation ist SchreibeHauptwort:
Function SchreibeHauptwort (sText As Variant) As Variant
On Error GoTo err_SchreibeHauptwort
Dim s As String
If IsNull(sText) Then Exit Function
s = sText
Mid$(s, 1, 1) = UCase(Mid$(s, 1, 1))
SchreibeHauptwort = s
Exit Function
err_SchreibeHauptwort:
Fehler "SchreibeHauptwort"
Exit Function
End Function
leere Inhalte
Quelle: dmt
Datum: 03.2004
STRING / NULL:
Das leidige Problem mit String-Variablen, denen Werte von Formularfeldern zugewiesen werden, und die immer abfucken, wenn die Formularfelder leer = NULL sind, kann mit der folgenden Routine behoben werden.
Function StringNotNull (v As Variant) As String
On Error GoTo err_StringNotNull
If IsNull(v) Then
StringNotNull = ""
Else
StringNotNull = v
End If
Exit Function
err_StringNotNull:
Fehler "StringNotNull"
StringNotNull = ""
Exit Function
End Function
Sehr häßlich ist in diesem Zusammenhang auch die Tatsache, daß normale Textfelder, deren Inhalt gelöscht wird, den Wert NULL annehmen, Kombinationsfelder aber hingegen "", obwohl diese bei Initialisierung ebenfalls NULL sind.
HasValue gibt WAHR zurück, wenn einVariant-Wert (z.B. ein Steuerelement) von NULL verschieden und auch nicht "" ist.
Function HasValue (v As Variant) As Integer
If Not IsNull(v) Then
If v <> "" Then
HasValue = True
End If
End If
End Function
manipulieren
Quelle: dmt
Datum: 07.2006
ENTFERNE ZEICHEN AUS ZEICHENKETTE:
Mittlerweile stark vereinfacht durch ein simples:
ReplaceInString(Zeichenkette, Suchzeichen, "")
Function ClearStringFrom (s, c) As String
On Error GoTo err_ClearStringFrom
' **** Entferne aus s alle c ****
Dim iPos As Integer
Dim s0 As String, s1 As String, s2 As String
s0 = s
Do
iPos = InStr(s0, c)
If iPos = 0 Then Exit Do
s1 = Left$(s0, iPos - 1)
s2 = Right$(s0, Len(s0) - iPos - Len(c) + 1)
s0 = s1 + s2
Loop
ClearStringFrom = s0
Exit Function
err_ClearStringFrom:
Fehler "ClearStringFrom"
Exit Function
End Function
* * * *
ERSETZE ZEICHEN IN ZEICHENKETTE / REPLACEINSTRING():
Bißchen kryptisch, deckt aber alle Fälle ab und kann sogar ClearFromString ersetzen.
Mußte leider im Laufe der Jahre mehrfach nachgebessert werden, da in verschiedenen Fällen rekursive Effekte zu einem unendlichen Anschwellen der s0-Variablen geführt hatten.
Das Definieren von Option Compare Binary im bezogenen Modul ist jetzt nicht mehr nötig, um "ss"/"ß"-Problemen zu entgehen, aber evtl. in Sonderfällen dennoch ratsam. Obendrein kann z.B. in Access97 auch durch Verwendung von
InStr(Startposition, String1, String2, vbCompareBinary)
ein case-sensitiver Vergleich erreicht werden.
Beispiele für historische Fehlschläge:
- ReplaceInString("Sauerampfer","a","Sau") -> richtig: SSauuerSaumpfer
- ReplaceInString("MS-Access","ss","ß") -> richtig: MS-Acceß
- ReplaceInString("src='sau.gif'", "'", "''") -> richtig: src=''sau.gif''
- ferner krachte es mal, wenn ein Wort an erster Stelle stand und durch ""
ersetzt wurde.
Bei Bedarf kann auch ein optionaler Parameter iAktPos gesetzt werden.
So werden die Ersetzungs-Operationen erst ab einer gewünschten Stelle ausgeführt und die Unzulänglichkeiten von Mid$() elegant umgangen. Mid$ kann zwar gezielt Zeichen einer Zeichenkette austauschen, aber das nur überschreibend, und nicht einsetzend. Eine Funktion, die das komplett besser macht, muß erst noch geschrieben werden, aber ein aufgebohrtes ReplaceInString hilft dann schon viel.
Ach ja, bevor sich jemand wundert, was eine Funktion namens ReplaceInString() in meiner Sammlung überhaupt zu suchen hat: mir ist durchaus bekannt, daß neuere VisualBasic- und auch VBA-Versionen dafür eine eigene Funktion kennen, aber das gilt halt nicht für Access 2.0. Deswegen hier aus historischen Gründen:
Function ReplaceInString (s, c1 As String, c2 As String) As String
On Error GoTo err_ReplaceInString
' **** Ersetze in s alle c1 durch c2 ****
Dim iPos As Integer, iAktPos As Integer
Dim s0 As String, sL As String, sR As String
If IsNull(s) Then
ReplaceInString = ""
Exit Function
End If
If c1 = c2 Then
ReplaceInString = s
Exit Function
End If
s0 = s
iAktPos = 1
Do
iPos = InStr(iAktPos, s0, c1)
If iPos = 0 Then Exit Do ' nicht gefunden
sL = Left$(s0, iPos - 1)
sR = Right$(s0, Len(s0) - iPos - Len(c1) + 1)
s0 = sL & c2 & sR
iAktPos = Len(sL & c2) + 1
Loop
ReplaceInString = s0
Exit Function
err_ReplaceInString:
Fehler "ReplaceInString"
Exit Function
End Function
Sehr schön kommen dann auch im Rahmen professioneller Kapselungen Funktionen a'la:
Private Function EntferneDoppelteBlanks (v As Variant) As String
' **** evtl. eingeschlichene, doppelte Blanks durch einfache ersetzen ****
EntferneDoppelteBlanks = ReplaceInString(v, " ", " ")
End Function
, die sich wiederum auf eigene Routinen stützen und sehr kompakten und trotzdem aussagekräftigen Code ermöglichen.
Ebenfalls schön ist das Austauschen von Dateitypen unter Beibehaltung des Dateinamens:
ReplaceInString("test.jpg", Get_Filetype("test.jpg"), "htm")
, und es nimmt kein Ende mit dem Einsatz hilfreicher, gekapselter Funktionen:
In diesem Beispiel geht es darum, daß in einer Windows-Access-Umgebung erzeugte Texte, die z.B. für einen robots.txt einer Website in eine entsprechende Datei geschrieben werden sollen, immer einen DOS-like chr$(13)chr$(10)-Zeilenumbruch enthalten.
Echte UNIX-Dateien hingegen dürfen nur ein einfaches chr$(10)-Sonderzeichen als Zeilenumbruch enthalten (bei älteren MAC-Systemen sollten es einzelne chr$(13)-Zeichen sein. Neuere Apple-Systeme sind seit OS X bei den UNIX-kompatiblen Zeilenschaltungen angekommen.).
Das nach erfolgter Umwandlung korrekte Schreiben einer solchen Datei geht nur dann gut, wenn die Datei vorher gelöscht wird und danach per Binary geöffnet und mit put beschrieben wird.
Wenn die Datei nicht vorher gelöscht wird, dann würde ein Text, der kleiner als der bestehende Dateiinhalt ist, in den selbigen hineingeschrieben werden und Teile des ursprünglichen Inhaltes bleiben erhalten.
Das Schreiben per Random erzeugte eigenartige Sonderzeichen (in Doku erscheinen Hinweise zu Satzkennzeichen).
So, wie hier beschrieben, klappt's dann richtig:
' Wenn ja, wird die Datei UNIX-like geschrieben, von wegen der DOS-Line-Enders; Hallo Unix !
s = Nz(Me!robots_txt_content, "")
s = ReplaceInString(s, vbCrLf, Chr$(10))
' Das geht NUR im Binary-Modus, wenn die Datei vorher gelöscht wurde
Kill (sRobotsTextFile)
Open sRobotsTextFile For Binary As #FF
s = "# /robots.txt file for " & Me!URL & "/" & Chr$(10) & Chr$(10) & s & Chr$(10)
Put #FF, , s
Close #FF
* * * *
Die Funktion ClearFromHtml entfernt aus übergebenem STRING alle HTML-Tags und bewahrt Zeilenumbrüche bzw. ersetzt sie durch eine angegebene Zeichenkette.
Beispiele:
ClearFromHtml(RS("Beschreibung"), False, ", ")
bereitet einen Text für html-title- und description-meta-tag auf, indem alle html-Tags entfernt und Zeilenumbrüche durch ", " ersetzt werden.
ClearFromHtml(RS("Beschreibung"), True, "")
bereitet einen Text z.B. für das alt-Attribut des img-tags auf, indem alle html-Tags entfernt, aber Zeilenumbrüche belassen werden.
Function ClearFromHtml(vText As Variant, KeepCR As Boolean, sReplaceCRBy As String) As Variant
On Error GoTo err_ClearFromHtml
Dim v As Variant, iPos1 As Integer, iPos2 As Integer
If IsNull(vText) Then Exit Function
v = vText
iPos1 = 1
Do While iPos1 < Len(v)
iPos1 = InStr(iPos1, v, "<")
If iPos1 = 0 Then
Exit Do
Else
iPos2 = InStr(iPos1, v, ">")
If iPos2 = 0 Then
Exit Do
Else
v = ReplaceInString(v, Mid(v, iPos1, iPos2 - iPos1 + 1), "")
iPos1 = iPos2
End If
End If
Loop
If KeepCR = False Then
v = ReplaceInString(v, vbCrLf, sReplaceCRBy)
End If
ClearFromHtml = v
Exit Function
err_ClearFromHtml:
Fehler "ClearFromHtml"
Exit Function
End Function
* * * *
UMWANDLUNG von ASCII in ANSI:
Selbst ein (kleiner) Ansi-Ascii-Übersetzer kann so einfach realisiert werden (Option Compare Binary nicht vergessen, wegen 'ß'='ss' -> 'MS-Acceßs'):
Function Ansi2Ascii (v As Variant) As Variant
On Error GoTo err_Ansi2Ascii
Dim s As String
If Not IsNull(v) Then
s = v
s = ReplaceInString(s, Chr$(252), Chr$(129)) ' ü
s = ReplaceInString(s, Chr$(228), Chr$(132)) ' ä
s = ReplaceInString(s, Chr$(196), Chr$(142)) ' Ä
s = ReplaceInString(s, Chr$(246), Chr$(148)) ' ö
s = ReplaceInString(s, Chr$(214), Chr$(153)) ' Ö
s = ReplaceInString(s, Chr$(220), Chr$(154)) ' Ü
s = ReplaceInString(s, Chr$(223), Chr$(225)) ' ß
Ansi2Ascii = s
Else
Ansi2Ascii = Null
End If
Exit Function
err_Ansi2Ascii:
Fehler "Ansi2Ascii"
Exit Function
End Function
* * * *
AUFFÜLLEN von ZEICHENKETTEN mit einem gewünschten Zeichen:
Function Fill_with_character (vString As Variant, vFillChar As Variant, iLength As Integer) As String
On Error GoTo err_Fill_with_character
Fill_with_character = String$(iLength - Len(CStr(vString)), vFillChar) & vString
Exit Function
err_Fill_with_character:
Fehler "Fill_with_character"
Exit Function
End Function
suchen, finden & vergleichen
Quelle: dmt
Datum: 05.2006
Der Vergleich von Zeichenketten z.B. per SQL a'la 'LIKE "*...*"' geht zuweilen gründlich in die Hose, da einige Zeichen als Platzhalter benutzt werden können.
Die Access-Dokumentation schreib hierzu:
Symbol Beispiel Verwendung
* wa* findet was, war und warte*ar findet war, bar und klar.
Wie das MS-DOS-Stellvertreterzeichen *, kann dieses Sternchen einer beliebigen Anzahl Zeichen entsprechen. Im Gegensatz zu MS-DOS kann es jedoch für das erste oder letzte Zeichen einer Zeichenfolge verwendet werden.
? w?r findet war, wer und wir.
Wie das MS-DOS-Stellvertreterzeichen ? entspricht dieses Symbol einem beliebigen einzelnen Zeichen.
# 1#3 findet 103, 113, 123.
Entspricht einer beliebigen einzelnen Zahl.
[ ] w[ae]r findet war und wer, aber nicht wir.
Entspricht einem einzelnen Zeichen innerhalb der eckigen Klammern.
! w[!ae]r findet wir, aber nicht war und wer.
Entspricht einem einzelnen, beliebigen, nicht aufgelisteten Zeichen.
- b[a-c]d findet bad, bbd und bcd
Soweit, so gut. Jetzt wissen wir immerhin, warum auch der Suchen/Ersetzen-Dialog z.B. bei der Suche nach '##' zum erstbesten '00' springt, da hier wie beim Eingabeformat nach dem Vorkommen zweier aufeinander folgender Zahlen gesucht wird. Eigentlich toll, daß so was geht, aber wie kann ich denn nach dem Vorkommen eines '#' suchen ?
Warum aber ein WHERE Suchname LIKE "F *" auch Datensätze wie Fusel finden, bleibt ungeklärt. Ein WHERE LEFT$(Suchname,2)="F " beschränkt sich dann wirklich auf die Datensätze mit einem führenden "F ".
* * * *
Escape-Sequenzen für die Verwendung von Sonderzeichen in den Access-Bereichen SQL und Suche-Dialog:
Heftiges Testen mit allen möglichen Sonderzeichen führte meist zu gar nichts, bis ich auf die eigentliche abwegige Idee kam, Platzhalterzeichen zu 'kreuzen'. Und siehe da, ein '[#]' findet auf einmal auch ein enthaltenes '#'.
Entsprechend schlägt auch die Suche nach "*" oder "****" oder "* * * *" fehl, wenn nicht jedes * in eckige Klammern gesetzt gesetzt wird, also z.B. [*] [*] [*] [*].
Klar, daß sowas innerhalb von Access (2.0) auch noch unterschiedlich gehandhabt wird und z.B. bei der Verwendung von s. Sendkeys manche Zeichen in geschweifte Klammern gesetzt werden müssen.
* * * *
INSTR:
Instr dient dazu, das Vorhandensein eines Teilstrings innerhalb eines anderen zu überprüfen, und die entsprechende Position auszugeben. Enthält der zu suchende Teilstring ein '_', das bisher unter allen Betriebssystemen und Programmiersprachen ein legales Text-Unterteilungszeichen war, so geht die Sache schief !
WICHTIG ist in diesem Zusammenhang, daß ein solcher Vergleich manchmal case-sensitiv (die Fälle Großschreibung und Kleinschreibung unterscheidend) sein sollte.
Entweder in Modulen
Option Compare Binary
anstelle von
Option Compare Database
verwenden, oder
einen InStr-Vergleich (Access97) so durchführen:
If InStr(1, sFoundTags, sTag, vbBinaryCompare) = 0 Then
Schwieriger wird es, wenn der String-Vergleich innerhalb einer DAO (DataAccessObjects)-Anweisung erfolgen soll.
Da nützte trotz MS-Doku auch ein Option Compare Binary nichts, sondern nur folgende Anweisung:
RS.FindFirst "InStr(1, tag, '" & sTag & "', 0) > 0"
Ähnlich die Situation, wenn wir einen "genauen" Zeichenketten-Vergleich in SQL durchführen wollen:
SELECT tag
FROM tag_anal
WHERE InStr(1, tag, "", 0) > 0;
Der explizite Vergleich gegen ein benanntes Ergebnis "=0" oder ">0" ist AUF JEDEN FALL zu empfehlen, auch wenn das in reinem Basic "ohne" geht.
* * * *
SUCHEN VON ZEICHENKETTEN IN TEXTEN:
Eine Befehlsschaltfläche startet den Suchvorgang, bietet 'Weitersuchen' an und meldet auch ein negatives Ergebnis:
' **** Formular Textsuche ****
Dim SelBeginn as Integer
Dim SelLänge as Integer
' **** Listenfeld ListeTiere ****
Sub ListeTiere_DblClick (Cancel as Integer)
Forms!Textfeld1.Schreibtext.SetFocus
Forms!Textfeld1.Schreibtext.Text = Forms!Textfeld1.Schreibtext.Text & Forms!Textfeld1.ListeTiere.Value
End Sub
' **** Mehrzeiliges Textfeld ****
Sub SchreibText_GotFocus ()
Forms!Textfeld1.Schreibtext.SelStart = SelBeginn
Forms!Textfeld1.Schreibtext.SelLength = SelLänge
End Sub
Sub SchreibText_LostFocus ()
SelBeginn = Forms!Textfeld1.Schreibtext.SelStart
SelLänge = Forms!Textfeld1.Schreibtext.Sellength
End Sub
' **** Befehlsschaltfläche (Weiter-) Suchen ****
Sub Suchen_Click ()
Forms!Textfeld1.Schreibtext.SetFocus
neuerAnfang = Forms!Textfeld1.Schreibtext.SelStart + Forms!Textfeld1.Schreibtext.SelLength + 1
neueLänge = Len(Forms!Textfeld1.Schreibtext.Text) - neuerAnfang +1
Weiter$ = Mid$(Forms!Textfeld1.Schreibtext.Text,neuerAnfang,neueLänge)
Suchwort$ = Forms!Textfeld1.Suchtext.Value
Position% = InStr(Weiter$,Suchwort$)
If Position% then
Forms!Textfeld1.Schreibtext.SelStart = neuerAnfang + Position% - 2
Forms!Textfeld1.Schreibtext.SelLength = Len(Suchwort$)
Else
Msgbox "Suchwort existiert nicht !",64,"Suche"
End If
End Sub
trimmen
Quelle: dmt
Datum: 03.2004
TRIM:
Zumindest Rtrim$, wenn nicht alle Trim-Funktionen entfernen nicht nur angrenzende Leerzeichen von Zeichenketten, sondern auch chr$(0)-Zeichen, was natürlich nirgendwo dokumentiert ist.
TOTALTRIM:
entfernt überschüssige Zeilenumbrüche und Leerzeichen am Anfang und Ende eines Strings:
siehe auch die Schwarzenegger-Version von StringFromAPI !
Function TotalTrim(sString As String) As String
On Error GoTo err_TotalTrim
Dim s As String
s = sString
' überschüssige Zeilenumbrüche und Leerzeichen am Anfang und Ende des Strings entfernen
Do While Left$(s, 2) = vbCrLf
s = Trim$(Right$(s, Len(s) - 2))
Loop
Do While Right$(s, 2) = vbCrLf
s = Trim$(Left$(s, Len(s) - 2))
Loop
TotalTrim = s
Exit Function
err_TotalTrim:
Fehler "TotalTrim"
Exit Function
End Function
Zeilenumbruch
Quelle: dmt
Datum: 04.2011
Unterscheidung von COMPUTER-PLATTFORMEN anhand von ASCII-Textdateien nach Art des ZEILENUMBRUCHES:
Die bekanntesten Computer-Betriebssystem-Plattformen sind Workstation-orientierte Unix-Systeme, PC-orientierte Systeme wie z.B. DOS und Windows sowie Macs.
Ein trivialer Unterschied in der Bearbeitung und Übertragung von simplen Textdateien ist die Behandlung von Zeilenumbrüchen.
Das führt immer wieder zu unerwarteten Problemen, wenn Benutzer und selbst Fachleute Textdateien zwischen verschiedenen Plattformen übertragen und sich über schwer lesbare Resultate wundern.
Zunächst wird hier zwischen den Zeichensätzen unterschieden, die von einzelnen Betriebssystemen verwendet werden:
- ASCII: u.a. Unix, Linux, Mac OS X, AmigaOS, BSD, Windows, DOS, OS/2, CP/M, TOS (Atari), Mac OS bis Version 9, Apple II
- EBCDIC / Unicode: AIX OS & OS/390
- kein Zeichensatz: IBM-Großrechner, die keinen Zeilenumbruch kennen, sondern die Zeilenlänge in einem Längenfeld am Zeilenanfang speichern.
Mit Blick auf den ASCII-Zeichensatz unterscheiden sich die Betriebssysteme wie folgt:
- Unix, Linux, Mac OS X, AmigaOS, BSD, etc: Line Feed, abgekürzt LF, hex 0A, dezimal 10, Escape \n
- Windows, DOS, OS/2, CP/M, TOS (Atari): Carriage Return / Line Feed, abgekürzt CR LF, hex 0D 0A, dezimal 13 10, Escape \r\n
- Mac OS bis Version 9, Apple II: Carriage Return, abgekürzt CR, hex 0D, dezimal 13, Escape \r
Nach dieser Unterscheidung differenzier auch Programme wie z.B. der Editor UltraEdit die Herkunft verschieden umgebrochener Textdateien.
Eine Besonderheit sind die Systeme AIX OS & OS/390, die den EBCDIC-Zeichensatz verwenden, der auch durch UTF-EBCDIC abgebildet werden kann. Verwendet wird dann New Line, abgekürzt NEL, hex 15, dezimal 21, eine Escape-Aequenz existiert nicht.
Eine ausführliche Beschreibung mit vielen weiteren Details findet sich im Wikipedia-Artikel Zeilenumbruch.
Eine ältere exemplarische Implementation in der Programmiersprache Basic kann z.B. wie folgt aussehen:
' Hier werden Zeilenumbrüche nach allen bekannten Ascii-Datei-Formaten unterschieden
If InStr(sContent, Asc(10)) > 0 And InStr(sContent, Asc(13)) = 0 Then ' LF, kein CR => UNIX
sUmbruch = Asc(10)
sDateityp = "UNIX"
ElseIf InStr(sContent, Asc(10)) = 0 And InStr(sContent, Asc(13)) > 0 Then ' kein LF, CR => Mac
sUmbruch = Asc(13)
sDateityp = "Mac"
ElseIf InStr(sContent, vbCrLf) > 0 Then ' CR und LF => PC
sUmbruch = vbCrLf
sDateityp = "PC"
Else ' unbekannt
sUmbruch = ""
sDateityp = "unbekannt, enthält keinen Zeilenumbruch."
End If
Hier wird ein Text, der durch die Variable sContent repräsentiert wird, auf Abwesenheit und Vorhandensein der typischen Umbruchszeichen untersucht und dementsprechend wird der Variablen sUmbruch das verwendete Umbruchszeichen und der Variablen sDateityp ein Klartext für die wahrscheinlich benutzte Computer-Betriebssystem-Plattform zugewiesen.
