Freeware (kostenlos)
... die mit den bunten Knöpfen.
Beispiele für kleine und große Programmierer
Nimm, vermehre, teile.
 Wie kann ein HTML-Quelltext in einer RichTextBox farblich markiert werden? Nachfolgend zwei Beispiele als Anregung.
1. Beispiel ohne Fokus (schneller). |
|
Zwischenablage zwischen "Kopieren & Einfügen" anzeigen
|
|
Funktionen, Beispiele, u.a.: Function File_DateiausPfad (FOrdnerDatei) |
|
Hauptadresse markieren
|
|
Beispiel 1
|
|
<html> <head> <title>Titeltext</title> </head> <body> Beispieltext </body> </html> |
|
Ergebnis im Format *.rtf: |
|
<html> <head> <title> Titeltext</title></head> <body> Beispieltext </body> </html> |
| HTML-Quelltext in einer RichTextBox |
Beispielprojekt in VB6, Download
Beispiel 2
«HTML-Tags» und »Text« in RTF markieren
|
Wie kann ein HTML-Quelltext in einer RichTextBox farblich markiert werden?
2. Beispiel mit Fokus (langsamer). Mini-Beispiel im Original (Vorgabe im Nur-Text-Format *.txt): |
|
<html> <head> <title>Titeltext</title> </head> <body> Beispieltext </body> </html> |
|
Ergebnis im Format *.rtf: |
|
<html> <head> <title> Titeltext</title></head> <body> Beispieltext </body> </html> |
| HTML-Quelltext in einer RichTextBox |
|
Sie können dieses Beispiel ausprobieren, indem sie eine Form1 laden, ein CommandButton und eine RichTextBox hinzufügen und den Programmiertext unten kopieren, in die Form1 einfügen und das Beispiel ausführen. Benötigt werden: Form1, Command1, Command2, RichTextBox1.
|
Beispiel 1 +
Beispiel 2
«HTML-Tags» und »Text« in RTF markieren
|
Option Explicit
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 = "<HTML><TITLE>Titeltext</TITLE>Beispieltext</HTML>" 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 <html> .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 <Auswahl> .SelStart = Len(.Text) .SelColor = vbRed .SelFontName = "MS Sans Serif" .SelFontSize = 8 .SelText = ErsatzZ .SelLength = 0
' SCHRIFT 003 ' Für <Auswahl> .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
' <Tags> 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), "<html") > 0 Or InStr(LCase(TagText), "</html>") > 0 Then Wert = Farbe_A003 & TagText & Farbe_B003 ElseIf InStr(LCase(TagText), "<head") > 0 Or InStr(LCase(TagText), "</head") > 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
' <html-tags> 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
' <Tags> If InStr(LCase(RBox.SelText), "script") > 0 And InStr(LCase(RBox.SelText), "script") < 5 Then RBox.SelColor = &H40C0& ' braun ElseIf InStr(LCase(RBox.SelText), "<h") > 0 Then RBox.SelColor = &HF8452C ' hellblau ElseIf InStr(LCase(RBox.SelText), "</h") > 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 |
Alles auswählen, kopieren und in ihr Beispielprogramm einfügen.
Alternativ: Text im Vollbild anzeigen?
«HTML-Tags» und »Text« in RTF markieren
Datei: textfiltern_quelltexttags.zip Dateigröße ca. 4 KB (0,004 MB) Komplettes Beispielprojekt in VB6 Datei speichern, entpacken, [VBProjekt].vbp öffnen... |
Freeware (kostenlos)
Zwischenablage
Das kleine Programm kann als eine weitere Form in ihrem Projekt zusätzlich eingefügt werden.
Drei Felder für: Nur-Bild, Nur-Text, RTF-Format mit Bild und Text.
Beinhaltet: 1x Form, 1x PictureBox, 1x TextBox, 1x RichTextBox, 2x CommandButton, 3x Label
|
Datei: form2_zablage.zip Dateigröße ca. 4 KB (0,004 MB) Komplettes Beispielprojekt in VB6 Datei speichern, entpacken, [VBProjekt].vbp öffnen... |
Freeware (kostenlos)
Funktionen, Beispiele
Abfragebeispiel:Text1.text = Folder_PfadohneDatei ("c:\Ordner\Datei.txt")
Text1.text = "c:\Ordner\"
|
'Freeware von
www.design-cad.de ' aus Verzeichnis c:\Ordner\ = c:\Ordner\Datei.txt Public Function Folder_PfadohneDatei (FOrdnerDatei) As String On Error Resume Next Folder_PfadohneDatei = Mid(FOrdnerDatei, 1, InStrRev(FOrdnerDatei, "\")) End Function '########################################################## ' aus Verzeichnis Datei.txt = c:\Ordner\Datei.txt Public Function File_DateiausPfad (FOrdnerDatei) As String On Error Resume Next File_DateiausPfad = Mid(FOrdnerDatei, InStrRev(FOrdnerDatei, "\") + 1) End Function '########################################################## ' Dateiformat txt = c:\Ordner\Datei.txt Public Function File_Endung (FDatei) As String On Error Resume Next Dim XDatei ' Hinweis: c:\Ordner.txt\ kann auch mit Punkt ein Ordner sein. XDatei = Mid(FDatei, InStrRev(FDatei, "\") + 1) ' Datei.txt 'XDatei = fso.GetExtensionName(FDatei) ' Alternativ If InStr(XDatei, ".") <> 0 Then XDatei = Mid(FDatei, InStrRev(FDatei, ".") + 1) Else XDatei = "" ' txt File_Endung = XDatei End Function '########################################################## ' Datei. Verändert am Public Function File_DatumVeraendertAm (FOrdnerDatei, Optional FDatumformat As Variant = "ddd dd.mm.yyyy hh:nn:ss") As String On Error Resume Next ' = FileDateTime (FordnerDatei) ' Alternative (schneller bei größeren Listen) Dim fso, f Set fso = CreateObject("Scripting.FileSystemObject") ' Anmerkung: Bei einer größeren Menge von Reihenabfragungen ist das FileSystemObject spürbar langsamer, ' bei wenigen Abfragungen ist die Verzögerung uninteressant und die zusätzliche Formatumrechnung wichtiger. Set f = fso.getfile(FOrdnerDatei) File_DatumVeraendertAm = Format(f.DateLastModified, FDatumformat) End Function '########################################################## ' Dateigröße Public Function File_DateigroesseKB (FOrdnerDatei) As String On Error Resume Next File_DateigroesseKB = Format(FileLen(FOrdnerDatei) / 1024, "###,###0") & " KB" End Function '########################################################## ' Datei = c:\Ordner\Datei.txt Public Function File_DateiohneEndung (FDatei) As String On Error Resume Next Dim XDatei ' Andere Variable wählen. Ausgangsvariable FDatei wird zurück gegeben. Wertveränderung bei Ausgang. XDatei = FDatei XDatei = Mid(XDatei, InStrRev(XDatei, "\") + 1) XDatei = Mid(XDatei, 1, InStrRev(XDatei, ".") - 1) File_DateiohneEndung = XDatei End Function ' ############################## Text ################################## ' Text kürzen abc...efg = abcdefg = 3 c:\Ordn...tei.txt = c:\Ordner\datei.txt = 7 Public Function Text_mittigkürzen (TText, Optional Rand As Integer = 3) As String On Error Resume Next Dim A, B, Text Text = TText If Len(Text) > Rand * 2 Then A = Left(Text, Rand) B = Right(Text, Rand) Text = A & "..." & B End If Text_mittigkürzen = Text End Function '########################################################## ' Text rechts kürzen abc...efg = abc Public Function Text_rechtskürzen (TText, Optional nachZeichenfolge As Variant = "") As String On Error Resume Next ' = left(TText, nachZeichenfolge) ' Alternative Text_rechtskürzen = Mid(TText, 1, InStr(TText, nachZeichenfolge) - 1) End Function '########################################################## ' Text rechts mit Zeichen auffüllen abc = abcXXX Public Function Text_rechtsauffüllen (TText, Optional mitZeichenfolge As Variant = "", Optional mitZeichenfolgeAnzahl As Integer = 0) As String On Error Resume Next If Len(TText) < mitZeichenfolgeAnzahl Then ' Zeichen * Anzahl, x*3 = xxx Text_rechtsauffüllen = TText & String(mitZeichenfolgeAnzahl - Len(TText), mitZeichenfolge) Else Text_rechtsauffüllen = TText End If End Function '########################################################## ' Für Textanzeige (Recent) kann ein langer Pfad gekürzt werden Public Function File_PfadTextkürzen (FOrdnerDatei, Optional Pfadteileab2 As Integer = 2) ' "=" falls Variable nicht vorher definiert wurde On Error Resume Next ' C:\Ordner = C:\Ordner < 2 c:\...\Datei.txt = 2 c:\...\Ordner\ = 2 c:\Ordner\...\Datei.txt = 3 Pfadteile Dim FDatei, Datensatz, L, Anzahl Anzahl = Len(FOrdnerDatei) - Len(Replace(FOrdnerDatei, "\", "")) If Anzahl <= Pfadteileab2 Then FDatei = FOrdnerDatei: GoTo Ende FDatei = Replace(FOrdnerDatei, "\", "\?") ' ?-Zeichen ist in Pfad nicht erlaubt, deshalb hier als Trennzeichen Datensatz = Split(FDatei, "?", -1) '(Ab / -1=Alle Zeichen einlesen; 0=Binärvergleich 1=Textvergleich) FDatei = "" For L = 0 To Anzahl If L < Pfadteileab2 - 1 Then FDatei = FDatei & Datensatz(L) If L = Pfadteileab2 Then FDatei = FDatei & "..." If Datensatz(L) = "" Then Anzahl = Anzahl - 1: Exit For ' Ende mit \ Next L FDatei = FDatei & "\" & Datensatz(Anzahl) Ende: File_PfadTextkürzen = FDatei End Function '########################################################## ' Textanzeige teilen Public Function Text_splitten (FText, Optional FTrennzeichen As Variant = "@", Optional FTextTeilab0 As Integer = 1) On Error Resume Next ' "\" + 0 = C:\Ordner\Datei.txt = C: ' "." + 1 = http://www.design-cad.de = design-cad Dim FDatensatz If InStr(FText, FTrennzeichen) > 0 Then FDatensatz = Split(FText, FTrennzeichen, -1) '(Ab / -1=Alle Zeichen einlesen; 0=Binärvergleich 1=Textvergleich) Text_splitten = FDatensatz(FTextTeilab0) End If End Function '########################################################## ' Textanzeige teilen Public Function Text_splittenSuche (FText, Optional FTrennzeichen As Variant = "@", Optional FTextTeilabSuche As Integer = 1, Optional FSuche As Variant = ".") On Error Resume Next ' "\" + 0 = C:\Ordner\Datei.txt = C: ' "." + 1 = http://www.design-cad.de = design-cad Dim FDatensatz, L, FAnzahl, Gef, Gefunden As Single Gefunden = -1 FAnzahl = Len(FText) - Len(Replace(FText, FTrennzeichen, "")) If InStr(FText, FTrennzeichen) > 0 Then FDatensatz = Split(FText, FTrennzeichen, -1) '(Ab / -1=Alle Zeichen einlesen; 0=Binärvergleich 1=Textvergleich) For L = 0 To FAnzahl If FDatensatz(L) <> "" Then If InStr(FDatensatz(L), FSuche) > 0 Then Gef = Gef + 1 If Gef = FTextTeilabSuche Then Gefunden = L: Exit For End If Next L If Gefunden >= 0 Then Text_splittenSuche = FDatensatz(Gefunden) Else Text_splittenSuche = "" End If End Function '########################################################## ' Anzahl bestimmter Zeichen Public Function Text_AnzahlZeichen (FText, Optional FSuche As Variant = ".") On Error Resume Next ' C:\Ordner\Datei.txt = 2x "\" ' http://www.design-cad.de = 2x "." Text_AnzahlZeichen = Len(FText) - Len(Replace(FText, FSuche, "")) End Function '########################################################## ' gibt den aktuellen temporären Ordner vollständig zurück, z.B. c:\temp\ oder c:\windows\temp\ Public Function Folder_TempOrdner (Optional FUnterordner As String = "") As String ' mit Unterordner \OH Vorteil: Kann komplett gelöscht werden, keine unlöschbaren Systemdateien On Error Resume Next Dim fso, FOrdner Set fso = CreateObject("Scripting.FileSystemObject") 'FUnterordner = "~OH" 'TemporaryFolder 2, system 1, windows 0 FOrdner = fso.GetSpecialFolder(2) If Right(FOrdner, 1) <> "\" Then FOrdner = FOrdner & "\" FOrdner = FOrdner & FUnterordner If Right(FOrdner, 1) <> "\" Then FOrdner = FOrdner & "\" If fso.FolderExists(FOrdner) = False Then fso.CreateFolder (FOrdner) 'Temp/Unterordner If fso.FolderExists(FOrdner) = True Then Folder_TempOrdner = FOrdner Else Folder_TempOrdner = fso.GetSpecialFolder(2) End Function '########################################################## ' gibt einen einmalig eindeutigen Phantasienamen zurück Public Function File_TempName () As String On Error Resume Next Dim fso Set fso = CreateObject("Scripting.FileSystemObject") File_TempName = fso.GetTempName '"1asdfaeecwe.tmp" End Function '########################################################## ' Startet den Win-Explorer und öffnet den Ordner Public Function File_ExplorerOrdner (FOrdnerDatei) On Error Resume Next Dim FOrdnerX FOrdnerX = Chr(34) & FOrdnerDatei & Chr(34) ' ""c:\Ordner\Datei.txt"" 'FOrdnerX = Folder_PfadohneDatei(FOrdnerX) ' c:\Ordner\ 'Explorer [/e][,/root,<object>][[,/select],<sub object>] 'Examples:Explorer /e, /root, \\Reports 'Explorer /select, C:\Windows\Calc.exe 'Öffnen Explorer, selected=true, markierten Ordner oder Datei "Öffnen..." wie per Maus-Menü FOrdnerX = Shell("explorer /e,/select," & FOrdnerX, vbNormalFocus) File_ExplorerOrdner = FOrdnerX End Function '########################################################## Public Function File_lesen2 (FOrdnerDatei, Optional ZeilenBegrenzung As Double = 0) On Error Resume Next Dim FF As Integer, Dateidaten, Text, Zähler As Double FF = FreeFile If File_Exists(FOrdnerDatei) = True Then Open FOrdnerDatei For Input As #FF ' Datei zum Einlesen öffnen. Do While Not EOF(1) ' Auf Dateiende abfragen. If GetInputState Then Exit Do Line Input #FF, Dateidaten ' Datenzeilen lesen. Text = Text & Dateidaten & vbCrLf Zähler = Zähler + 1 If ZeilenBegrenzung > 0 And Zähler > ZeilenBegrenzung Then Exit Do Loop Close #FF ' Datei schließen. End If 'File_Exists File_lesen2 = Text End Function '########################################################## ' Programmdatei c:\Programme\Ordner\Datei.exe Public Function File_ProgrammOrdnerDatei () As String On Error Resume Next Dim FOrdner FOrdner = App.Path If Right(FOrdner, 1) <> "\" Then FOrdner = FOrdner & "\" FOrdner = FOrdner & App.EXEName & ".exe" If Dir(FOrdner) <> "" Then File_ProgrammOrdnerDatei = FOrdner End Function '########################################################## ' Datei-Name für Sicherungskopie checken und zurück liefern c:\Ordner\Sicherungskopie (1) von Datei.txt Public Function File_SicherungskopieNameliefern (FOrdnerDatei, Optional SDatei As Variant = "Sicherungskopie von ") As String On Error Resume Next Dim fso, FPfad, FDatei, Zahl As Long, XDatei, YDatei Set fso = CreateObject("Scripting.FileSystemObject") FPfad = Mid(FOrdnerDatei, 1, InStrRev(FOrdnerDatei, "\")) FDatei = Mid(FOrdnerDatei, InStrRev(FOrdnerDatei, "\") + 1) XDatei = FPfad & SDatei & FDatei If fso.FileExists(XDatei) = False Then GoTo Ende Do Zahl = Zahl + 1 XDatei = Mid(SDatei, 1, InStr(SDatei, " ")) YDatei = Replace(SDatei, XDatei, "") XDatei = FPfad & XDatei & "(" & Zahl & ") " & YDatei & " " & FDatei If fso.FileExists(XDatei) = False Then Exit Do Loop Until Zahl > 1000000 ' Notausgang Ende: If fso.FileExists(XDatei) = False Then File_SicherungskopieNameliefern = XDatei Else File_SicherungskopieNameliefern = "" End Function '########################################################## Public Function File_umbenennen (AlterOrdnerDateiName, NeuerOrdnerDateiName, Optional FSystem As Boolean = False) As Variant On Error Resume Next Dim XDatei, YDatei, A, B Dim fso Set fso = CreateObject("Scripting.FileSystemObject") XDatei = AlterOrdnerDateiName YDatei = NeuerOrdnerDateiName A = Mid(XDatei, 1, InStrRev(XDatei, "\")) 'c:\Ordner\ B = Mid(YDatei, 1, InStrRev(YDatei, "\")) 'c:\Ordner\ If FSystem = False Then 'TemporaryFolder 2, system 1, windows 0 If Dir(XDatei, vbSystem) <> "" Then YDatei = 0: GoTo Ende ' Systemdateien nicht ändern End If If LCase(A) = LCase(B) And fso.FileExists(XDatei) = True And fso.FileExists(YDatei) = False Then Name XDatei As YDatei End If If Err.Number <> 0 And fso.FileExists(YDatei) = False Then YDatei = 0 ' Fehler Ende: File_umbenennen = YDatei End Function '########################################################## ' öffnet Dialogfenster und gibt ausgewählte Datei "nur" als vollständigen Pfad-Namen zurück > c:\Ordner\Datei.txt Public Function File_OeffnenDialog (Optional FVerzeichnis As Variant = "", Optional FDialogTitel As Variant = "Öffnen", Optional FFiltertitel As Variant = "Nur-Text", Optional FFilter As Variant = "*.txt") As Variant On Error Resume Next 'Dim fso 'Set fso = CreateObject("Scripting.FileSystemObject") ' Das Steuerelement "CommonDialog1" (Werkzeugsammlung) muß in der Form1 vorhanden sein. Genauen Namen beachten. With Form1.CommonDialog1 '.Flags = cdlOFNHideReadOnly 'Blendet das Kontrollkästchen Schreibgeschützt aus. '.InitDir = fso.GetParentFolderName(FVerzeichnis) .InitDir = Folder_PfadohneDatei(FVerzeichnis) ' c:\Ordner\ oder c:\Ordner\Datei.txt .FileName = Mid(FVerzeichnis, InStrRev(FVerzeichnis, "\") + 1) 'Datei.txt File_DateiausPfad(FVerzeichnis) .DialogTitle = FDialogTitel '.Flags = &H80000 'mehrere Eigenschaften wie Zahlen addieren. Besser Standard lassen. .CancelError = True ' 1 2 3 .Filter = FFiltertitel & "(" & FFilter & ")|" & FFilter & "|" & "Nur-Text (*.txt)|*.txt|" & "Alle Dateien (*.*)|*.*|" .FilterIndex = 1 .ShowOpen If Err.Number = cdlCancel Then Exit Function 'Benutzer hat abgebrochen If Len(.FileName) = 0 Then Exit Function Else 'Auswahl File_OeffnenDialog = .FileName ' Nur Name c:\Ordner\Datei.txt. Das Öffenen der Datei muß im anderen, weiteren Code vorbereitet werden. End If End With 'If Err.Number <> 0 Then Fehlerliste (Err.Number & " = " & Err.Description & ", " & "File_Oeffnen...") End Function '########################################################## ' öffnet Dialogfenster und gibt ausgewählte Datei "nur" als vollständigen Pfad-Namen zurück > c:\Ordner\Datei.txt Public Function File_SpeichernDialog (Optional FVerzeichnis As Variant = "", Optional FDialogTitel As Variant = "Speichern unter...", Optional FFiltertitel As Variant = "Nur-Text", Optional FFilter As Variant = "*.txt") As Variant On Error Resume Next 'Dim fso 'Set fso = CreateObject("Scripting.FileSystemObject") ' Das Steuerelement "CommonDialog1" (Werkzeugsammlung) muß in der Form1 vorhanden sein. Genauen Namen beachten. With Form1.CommonDialog1 '.Flags = cdlOFNHideReadOnly 'Blendet das Kontrollkästchen Schreibgeschützt aus. '.InitDir = fso.GetParentFolderName(FVerzeichnis) .InitDir = Folder_PfadohneDatei(FVerzeichnis) ' c:\Ordner\ oder c:\Ordner\Datei.txt .FileName = Mid(FVerzeichnis, InStrRev(FVerzeichnis, "\") + 1) 'Datei.txt File_DateiausPfad(FVerzeichnis) .DialogTitle = FDialogTitel '.Flags = &H80000 'mehrere Eigenschaften wie Zahlen addieren. Besser Standard lassen. .CancelError = True ' 1 2 3 .Filter = FFiltertitel & "(" & FFilter & ")|" & FFilter & "|" & "Text (*.txt)|*.txt|" & "Alle Dateien (*.*)|*.*|" .FilterIndex = 1 .ShowSave If Err.Number = cdlCancel Then Exit Function 'Benutzer hat abgebrochen If Len(.FileName) = 0 Then Exit Function Else 'Auswahl File_SpeichernDialog = .FileName ' Nur Name c:\Ordner\Datei.txt. Das Speichern der Datei muß im anderen, weiteren Code vorbereitet werden. End If End With 'If Err.Number <> 0 Then Fehlerliste (Err.Number & " = " & Err.Description & ", " & "File_Oeffnen...") End Function '########################################################## ' öffnet Dialogfenster und gibt ausgewählte Farbe als Zahl zurück > 123... Public Function Farbe_Dialogfeld (Optional FFarbe As Variant = "", Optional FFiltertitel As Variant = "Andere Farbe wählen...") As Variant On Error Resume Next ' Das Steuerelement CommonDialog1 muß in der Form1 vorhanden sein. Die genaue Benennung beachten. With Form1.CommonDialog1 If FFarbe = "" Then .Color = Val(GetSetting(App.ProductName, "Optionen", "FFARBE", RGB(192, 192, 192))) ' ohne Rückgabe = Grau Else .Color = Val(FFarbe) End If 'cdlCCFullOpen = gesamtes Dialogfeld einschließlich Benutzerdefinierte Farben anzeigen. 'cdlCCRGBInit = Legt den Anfangswert der Farbe für das Dialogfeld fest. .Flags = cdlCCFullOpen + cdlCCRGBInit ' Anfangsfarbe aus .color zeigen/markieren .DialogTitle = FFiltertitel .CancelError = True .ShowColor If Err.Number = cdlCancel Then Exit Function 'Benutzer hat abgebrochen SaveSetting App.ProductName, "Optionen", "FFARBE", .Color Farbe_Dialogfeld = .Color End With ' Tipp: Farbe splitten in Rot-Grün-Blau. Rot-Anteil = Farbteilaus_RGB_Dez_Hex(Farbe_Dialogfeld,rgbRed) End Function '########################################################## ' Farbteilaus_RGB_Dez_Hex gibt je nach Übergabe von rgbRed, rgbGreen oder rgbBlue ' den Rot-, Blau- oder Grünanteil einer in Color übergebenen ' Farbe zurück: Private Function Farbteilaus_RGB_Dez_Hex (ByVal Color As Long, ByVal Part As RGBEnum) As Byte On Error Resume Next ' Ist Color ein RGB-Farbwert oder ein Pallettenindex? If (Color And &HFF000000) <> 0 Then ' Palettenindex in RGB-Farbe umwandeln: Color = GetSysColor(Color And &HFFFFFF) End If ' Gewünschten Farbanteil separieren Select Case Part Case rgbRed: Farbteilaus_RGB_Dez_Hex = Color And &HFF& Case rgbGreen: Farbteilaus_RGB_Dez_Hex = Color \ &H100& And &HFF& Case rgbBlue: Farbteilaus_RGB_Dez_Hex = Color \ &H10000 And &HFF& End Select 'Beispiel Abfrage und Zuordnung von Farbe=&HC0FFC0: 'Form1.BackColor = RGB(Farbteilaus_RGB_Dez_Hex(Farbe, rgbRed), Farbteilaus_RGB_Dez_Hex(Farbe, rgbGreen), Farbteilaus_RGB_Dez_Hex(Farbe, rgbBlue)) End Function '########################################################## ' Umrechnen der Dateigröße 1234 Bytes, 1,234 KB, 0,001 MB, O,0 GB Public Function File_Groesse_MByte (Optional FOrdnerDatei As Variant = "", Optional FgroesseinByte As Variant = "", Optional Byte0_KB1_MB2_GB3 As Variant = 1) On Error Resume Next Dim FGröße If FOrdnerDatei <> "" Then FGröße = FileLen(FOrdnerDatei) Else FGröße = FgroesseinByte Select Case Byte0_KB1_MB2_GB3 Case 0, "Bytes": FGröße = Format(FGröße, "##,0") ' Liefert "1.234" 1 KB = 1000 Bytes oder 1024 (alt) Case 1, "KB": FGröße = Format((FGröße / 1024), "##,0") Case 2, "MB": FGröße = Format((FGröße / 1024) / 1024, "##,0") Case 3, "GB": FGröße = Format((FGröße / 1024) / 1024 / 1024, "##,0") End Select File_Groesse_MByte = FGröße End Function '########################################################## ' Dateien mit Platzhalterzeichen c:\Ordner\Dateien*.* Public Function File_DateienimOrdner_ohnemitPlatzhalter (FOrdnerDatei, Optional FTrennzeichen As Variant = vbCrLf) As String On Error Resume Next Dim XOrdner, Text Dim fso, f, f1, s, sf, Suchteil Set fso = CreateObject("Scripting.FileSystemObject") XOrdner = FOrdnerDatei If InStr(XOrdner, "\") = 0 Then Exit Function Suchteil = Mid(XOrdner, InStrRev(XOrdner, "\") + 1) ' *Datei*.* XOrdner = Mid(XOrdner, 1, InStrRev(XOrdner, "\")) 'c:\Ordner\ Set f = fso.GetFolder(XOrdner) Set sf = f.Files For Each f1 In sf If LCase(f1.Name) Like LCase(Suchteil) = True Then Text = Text & XOrdner & f1.Name & FTrennzeichen Next 'MsgBox Text File_DateienimOrdner_ohnemitPlatzhalter = Text ' Text kann mit Split getrennt werden X = Split(Text, vbcrlf, -1) '(Ab / -1=Alle Zeichen einlesen; 0=Binärvergleich 1=Textvergleich) End Function '########################################################## Public Function Zahl_zufällig (Optional FUntergrenze As Variant = 0, Optional FObergrenze As Variant = 10) On Error Resume Next 'Randomize ' Zufallszahlengenerator initialisieren. Randomize (1) ' (1) die selbe Zahl nicht wiederholen 'Int((Obergrenze - Untergrenze + 1) * Rnd + Untergrenze) 'Wert1 = Int((6 * Rnd) + 1) ' Zufallszahl im Bereich von 1 bis 6 generieren. Zahl_zufällig = Int((FObergrenze - FUntergrenze + 1) * Rnd + FUntergrenze) End Function '########################################################## Public Function Zwischenablage_abfragen () On Error Resume Next Dim L, Msg, ClpFmt As Integer If Clipboard.GetFormat(vbCFText) Then ClpFmt = ClpFmt + 1 If Clipboard.GetFormat(vbCFBitmap) Then ClpFmt = ClpFmt + 2 If Clipboard.GetFormat(vbCFDIB) Or Clipboard.GetFormat(vbCFEMetafile) Then ClpFmt = ClpFmt + 4 If Clipboard.GetFormat(vbCFRTF) Then ClpFmt = ClpFmt + 8 Select Case ClpFmt Case 1 Msg = "Text" ' "Die Zwischenablage enthält nur Text." Case 2, 4, 6 Msg = "Bild" ' "Die Zwischenablage enthält nur eine Bitmap." Case 3, 5, 7 Msg = "Text+Bild" ' "Die Zwischenablage enthält Text und eine Bitmap." Case 8, 9 If InStr(Clipboard.GetText(vbCFRTF), "{\pic") > 0 Then Msg = "+Bild" Msg = "Text" & Msg & ", RTF-Format" ' "Die Zwischenablage enthält nur Text im RTF-Format." Case 12 Msg = "Bild, RTF-Format" Case Else Msg = "Leer" ' "Die Zwischenablage ist leer." End Select ' Beispielabfrage: 'If InStr(Zwischenablage_abfragen, "Text") = 0 Then mnuEinfügen.Enabled = False Else mnuEinfügen.Enabled = True 'If ClpFmt mod 2 = 0 Then Code...Bilder else Code...Text Zwischenablage_abfragen = Msg End Function '########################################################## Public Function Text_Eingabebox (Optional Voreinstellungswert As Variant = "", Optional Titel As Variant = "Eingeben...", Optional Erklärungstext As Variant = "Wert eingeben:") As Variant On Error Resume Next ' Meldung, Titel und Standardwert anzeigen. ""=Abgebrochen Text_Eingabebox = InputBox(Erklärungstext, Titel, Voreinstellungswert) End Function '########################################################## Public Function Folder_Größe (Optional FOrdner As Variant = "") On Error Resume Next If FOrdner = "" Then Exit Function Dim fso, f, s, FText Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(FOrdner) = True Then Set f = fso.GetFolder(FOrdner) s = f.Size FText = "(" & Format(s, "##,0") & " Bytes)" ' mit Tausenderpunkten z.B. 123.456.789 Bytes s = Format(s / 1024 / 1024, "##,0.0") ' mit Komma z.B. 0,1 MB FText = s & " MB " & FText Else FText = "0 KBytes (nicht vorhanden)" End If Folder_Größe = FText End Function '########################################################## Private Sub Timer1_Timer () On Error Resume Next ' Dies ist nur ein Beispiel und kann kopiert werden als Grundlage einer Timer-Prozedur ' benötigt wird ein Timer1-Element, Einstellung Intervall=60,Timer1.Enabled = true, Variable am Formular-Anfang: Public Sekunden If Timer1.Tag <> Now Then ' Sekundentakt Timer1.Tag = Now Sekunden = Sekunden + 1 ' Sekunden als Variable im Modul-Anfang festlegen > Public Sekunden If Sekunden Mod 3 = 0 Then ' alle x Sekunden If Sekunden > 5 Then Timer1.Enabled = False Unload Me ' Zeitlimit setzen und autom. beenden End If End If 'Mod End If 'Timer1.Tag End Sub '########################################################## |
Hauptadresse markieren
Beinhaltet: 1x Form, 1x RichTextBox, 1x CommandButton
|
Datei: form1_adressemarkieren.zip Dateigröße ca. 3 KB (0,003 MB) Komplettes Beispielprojekt in VB6 Datei speichern, entpacken, [VBProjekt].vbp öffnen... |
Freeware (kostenlos)
Zeilen in Visual Basic, VB6
Freeware >