infobase: EDV - MS-Access


Zeichenketten

Anzahl und Vorkommen   Quelle: dmt   Datum: 04.2006   nach oben

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   nach oben

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   nach oben

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   nach oben

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   nach oben

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   nach oben

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   nach oben

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   nach oben

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:

Mit Blick auf den ASCII-Zeichensatz unterscheiden sich die Betriebssysteme wie folgt:

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.

nach oben
zur Startseite dieses Webangebotes zur infobase-Hauptseite   xhtml1.0