Option Explicit
' Beachten: < = linker Pfeil, > = rechter Pfeil im Textprogramm tauschen
Private Declare Function GetInputState Lib "user32" () As Long 'Eingabe über Tastatur? Abbrechen?
'Freeware von www.design-cad.de
'#############################################################
Private Sub Form_Load()
Caption = "TextFiltern_Quelltexttags"
' Siehe Werkzeugsammlung, Menue > Projekt > Komponenten > Rich Textbox Control 6.0
RichTextBox1.Text = "TiteltextBeispieltext"
RichTextBox1.Visible = True
End Sub
'#############################################################
Private Sub Command1_Click()
RichTextBox1.Visible = False
RichTextBox1.TextRTF = TextFiltern_Quelltexttags (RichTextBox1.Text)
RichTextBox1.Visible = True
Text1.Text = RichTextBox1.TextRTF
End Sub
'#############################################################
Private Sub Command2_Click()
RichTextBox1.Visible = False
RichTextBox1.TextRTF = TextFiltern_Quelltexttags2 (RichTextBox1.Text)
RichTextBox1.Visible = True
Text1.Text = RichTextBox1.TextRTF
End Sub
'#############################################################
Public Function TextFiltern_Quelltexttags2 (FText, Optional FZeichenAnfang As Variant = "<", Optional FZeichenEnde As Variant = ">")
'On Error Resume Next
' benötigt: RichTextBox
Dim L, EinAus As Boolean, Wo1, Wo2, Wo3, Wo4, Wert, TagText, SichtText, Schriftgröße, ErsatzZ
Dim RTFAnfang, RTFEnde, Farbe_A001, Farbe_B001, Farbe_A002, Farbe_B002, Farbe_A003, Farbe_B003, Farbe_A004, Farbe_B004
Dim RBox As RichTextBox
Set RBox = RichTextBox1 ' eine RichTextBox zuordnen
' Grundgerüstbeispiel für RTF-Text, Schrift, Farben...
' Beispiel:
'{\rtf1\ansi\ansicpg1252\deff0\deflang1031{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}}
'{\colortbl ;\red255\green0\blue0;\red0\green0\blue255;}
'\viewkind4\uc1\pard\cf1\f0\fs24 @@@\cf2 @@@
'\par }
'
' \cf1 = Farbe1 Ende=\cf0
' \f1 = Schrift1
' \pard = Absatz, Zeilenvorschub \par
' \fs24 = Fontsize, Schriftgröße
' \;red255\green0\blue0; = erste RGB-Farbe, hier Rot, Trennzeichen ; 0;1;2;...
' \fonttbl und \colortbl sind Schrift- und Farbtabellenlisten am Anfang
' @@@ = Beispiel für beliebigen Nur-Text
' {...} die Klammer stehen für Anfang und Ende
With RBox ' RRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR
.Text = ""
.TextRTF = ""
ErsatzZ = "@@@"
' SCHRIFT 001
' Für
.SelStart = 0
.SelColor = &H808080 ' Grau
.SelFontName = "MS Sans Serif"
.SelFontSize = 8
.SelText = ErsatzZ
.SelLength = 0
Schriftgröße = Mid(.TextRTF, InStr(.TextRTF, "\fs"))
Schriftgröße = Mid(Schriftgröße, 1, InStr(Schriftgröße, " ") - 1) ' Beispiel= "\fs20"
' SCHRIFT 002
' Für
.SelStart = Len(.Text)
.SelColor = vbRed
.SelFontName = "MS Sans Serif"
.SelFontSize = 8
.SelText = ErsatzZ
.SelLength = 0
' SCHRIFT 003
' Für
.SelStart = Len(.Text)
.SelColor = vbBlue
.SelFontName = "MS Sans Serif"
.SelFontSize = 8
.SelText = ErsatzZ
.SelLength = 0
' SCHRIFT 004
' Für >Text<
.SELSTART = LEN(.TEXT)
.SELCOLOR = VBBLACK
.SELBOLD = TRUE
.SELFONTNAME = "Arial"
.SELFONTSIZE = 16
.SELTEXT = ERSATZZ
.SELLENGTH = 0
WO1 = INSTR(.TEXTRTF, ERSATZZ)
RTFANFANG = MID(.TEXTRTF, 1, WO1 - 1)
RTFENDE = "\par }"
END WITH ' RRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR
FARBE_A001 = "\cf1 " ' BEACHTEN: ZAHL BEZIEHT SICH AUF WEITERE BENANNTE INFOS IM RTF-KOPF
FARBE_B001 = "\cf0 " ' ENDE DER FARBE, SONST BIS ZUM ENDE DES GESAMTEN FARBLOSEN TEXTES
FARBE_A002 = "\cf2 "
FARBE_B002 = "\cf0 "
FARBE_A003 = "\cf3 "
FARBE_B003 = "\cf0 "
FARBE_A004 = "\cf4\f4\fs24\b1 " 'FETT(BOLD) MIT \B1 ODER EINFACH \B
FARBE_B004 = "\b0" & SCHRIFTGRößE & "\f0\cf0 " ' \FUNKTIONEN BEENDEN IN UMGEKEHRTER REIHENFOLGE
WO1 = 0
DO ' LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
IF GETINPUTSTATE = TRUE THEN EXIT DO ' ABBRECHEN ERMöGLICHEN
WO1 = WO1 + 1
WO1 = INSTR(WO1, FTEXT, FZEICHENANFANG) ' <
IF WO1 > 0 Then ' wenn Null = Fehler in Instr
Wo2 = InStr(Wo1, FText, FZeichenEnde) ' >
End If
If Wo1 = 0 Or Wo2 = 0 Then Exit Do ' raus aus Schleife
'
TagText = ""
If Wo1 > 0 And Wo2 > Wo1 Then
TagText = Mid(FText, Wo1, Wo2 - Wo1 + 1)
If InStr(LCase(TagText), "script") > 0 And InStr(LCase(TagText), "script") < 10 THEN
WERT = FARBE_A002 & TAGTEXT & FARBE_B002
ELSEIF INSTR(LCASE(TAGTEXT), " 0 Or InStr(LCase(TagText), "") > 0 Then
Wert = Farbe_A003 & TagText & Farbe_B003
ElseIf InStr(LCase(TagText), " 0 Or InStr(LCase(TagText), " 0 Then
Wert = Farbe_A003 & TagText & Farbe_B003
Else
Wert = Farbe_A001 & TagText & Farbe_B001
End If
FText = Mid(FText, 1, Wo1 - 1) & Wert & Mid(FText, Wo2 + 1)
' veränderte Position, neu ermitteln:
Wo1 = Wo1 + 1
Wo1 = InStr(Wo1, FText, FZeichenAnfang) ' <
WO2 = INSTR(WO1, FTEXT, FZEICHENENDE) ' >
End If
Wo2 = Wo2 + 1
Wo3 = InStr(Wo2, FText, FZeichenAnfang) + 1 ' <
WO4 = INSTR(WO2, FTEXT, FZEICHENENDE) - 1 ' >
' >Text<
SICHTTEXT = ""
IF WO3 > 0 And Wo3 > Wo2 Then
SichtText = Mid(FText, Wo2 - 1, Wo3 - Wo2)
If Left(SichtText, 1) = "\" And Right(SichtText, 1) = " " Then SichtText = ""
SichtText = Mid(SichtText, InStr(SichtText, " ") + 1)
If InStr(LCase(SichtText), "{") > 0 And InStr(LCase(SichtText), ":") > 0 Then
Wert = Farbe_A002 & SichtText & Farbe_B002
ElseIf InStr(LCase(SichtText), "//") > 0 And InStr(LCase(SichtText), "-->") > 0 Then ' Notiz-Zeilen im Quellcode vom Programmierer
Wert = Farbe_A001 & SichtText & Farbe_B001
Else
Wert = Farbe_A004 & SichtText & Farbe_B004
'Wert = ""
End If
'If Wert <> "" Then
FText = Mid(FText, 1, Wo2 - 1) & Wert & Mid(FText, Wo3 - 1)
'End If
End If
Loop ' LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
FText = Replace(FText, vbCrLf, "\par ") ' Absätze
FText = RTFAnfang & FText & RTFEnde
TextFiltern_Quelltexttags2 = FText
End Function
'#############################################################
Public Function TextFiltern_Quelltexttags (FText, Optional FZeichenAnfang As Variant = "<", Optional FZeichenEnde As Variant = ">", Optional FErsetzenAnfang As Variant = "", Optional FErsetzenEnde As Variant = "")
'On Error Resume Next
Dim L, EinAus As Boolean, Wo1, Wo2, NeuText
Dim RBox As RichTextBox
Set RBox = RichTextBox1 ' eine RichTextBox zuordnen
EinAus = RBox.Visible
RBox.Visible = False
RBox.TextRTF = ""
RBox.SelRTF = FText
RBox.SelStart = 0 ' an den Textanfang setzen
' markieren
Do
If GetInputState Then Exit Do ' Abbrechen ermöglichen
'Einfügemarke an das Wortende bewegen.
RBox.UpTo FZeichenAnfang, True, False ' |<
WO2 = RBOX.SELSTART
' >Text<
IF WO1 > 0 And Wo2 > Wo1 Then
RBox.SelStart = Wo1 + 1
RBox.SelLength = Wo2 - Wo1
If InStr(RBox.SelText, "{") > 0 And InStr(RBox.SelText, ":") > 0 Then ' Scripte?
RBox.SelColor = &H8080FF ' hellrot
Else
RBox.SelColor = vbBlack ' lesbarer Text
RBox.SelBold = True
End If
RBox.SelStart = Wo2
End If
' Text bis Wortende auswählen .
RBox.Span FZeichenAnfang, False, False ' <
RBOX.SPAN FZEICHENENDE, TRUE, TRUE ' >
RBox.SelLength = RBox.SelLength + 1
If RBox.SelLength <= 1 THEN EXIT DO ' AUFGABE BEENDET UND RAUS AUS DER SCHLEIFE
'
If InStr(LCase(RBox.SelText), "script") > 0 And InStr(LCase(RBox.SelText), "script") < 5 THEN
RBOX.SELCOLOR = &H40C0& ' BRAUN
ELSEIF INSTR(LCASE(RBOX.SELTEXT), " 0 Then
RBox.SelColor = &HF8452C ' hellblau
ElseIf InStr(LCase(RBox.SelText), " 0 Then
RBox.SelColor = &HF8452C ' hellblau
Else
RBox.SelColor = &H808080 ' Grau
End If
RBox.UpTo FZeichenEnde, True, False ' >|
RBox.SelLength = 1
Wo1 = RBox.SelStart
Loop
TextFiltern_Quelltexttags = RBox.TextRTF
RBox.Visible = EinAus
End Function