. VB6 Werkstatt-Ecke Freeware    Freeware, vollständige Seite
Freeware (kostenlos)
... die mit den bunten Knöpfen.

Seitenende Nächster Abschnitt Vorheriger Abschnitt


Nimm, vermehre, teile.
Freeware

Beispiele für kleine und große Programmierer

Vorschau
Wie kann ein HTML-Quelltext in einer RichTextBox farblich markiert werden?
Nachfolgend zwei Beispiele als Anregung.

1. Beispiel ohne Fokus (schneller).
2. Beispiel mit Fokus (langsamer).

Nächster Abschnitt Beispielprojekt in VB6, Download

Zwischenablage zwischen "Kopieren & Einfügen" anzeigen

Vorschau

Nächster Abschnitt Beispielprojekt in VB6, Download

Funktionen, Beispiele, u.a.:
Function File_DateiausPfad (FOrdnerDatei)

Nächster Abschnitt Beispiele in VB6

Hauptadresse markieren

Vorschau
http://www.muster-adresse.de/muster.html

Nächster Abschnitt Beispielprojekt in VB6, Download

 

Beispiel 1
«HTML-Tags» und »Text« in RTF markieren


Vorschau
Seitenende Nächster Abschnitt Vorheriger Abschnitt Der bearbeitete Text aus der Funktion TextFiltern_Quelltexttags wird an die RichTextBox übergeben.

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

 

 

Beispiel 2
«HTML-Tags» und »Text« in RTF markieren


Seitenende Nächster Abschnitt Vorheriger Abschnitt

 

Wie kann ein HTML-Quelltext in einer RichTextBox farblich markiert werden?

2. Beispiel mit Fokus (langsamer).
Der bearbeitete Text aus der Funktion TextFiltern_Quelltexttags2 wird an die RichTextBox übergeben.

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

Seitenende Nächster Abschnitt Vorheriger Abschnitt

 

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

 

Seitenende Nächster Abschnitt Vorheriger Abschnitt

 

Alles auswählen, kopieren und in ihr Beispielprogramm einfügen.

Alternativ: Text im Vollbild anzeigen?

 

 

Seitenende Nächster Abschnitt Vorheriger Abschnitt

 

«HTML-Tags» und »Text« in RTF markieren

Vorschau
download Freeware (kostenloses Programm runterladen)
Datei: textfiltern_quelltexttags.zip
Dateigröße ca. 4 KB (0,004 MB)
Komplettes Beispielprojekt in VB6
Datei speichern, entpacken, [VBProjekt].vbp öffnen...

Freeware (kostenlos)

 

 

Seitenende Nächster Abschnitt Vorheriger Abschnitt

 

Zwischenablage



Vorschau

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

download Freeware (kostenloses Programm runterladen)
Datei: form2_zablage.zip
Dateigröße ca. 4 KB (0,004 MB)
Komplettes Beispielprojekt in VB6
Datei speichern, entpacken, [VBProjekt].vbp öffnen...

Freeware (kostenlos)

Seitenende Nächster Abschnitt Vorheriger Abschnitt

 

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

'##########################################################

 

 

Seitenende Nächster Abschnitt Vorheriger Abschnitt

 

Hauptadresse markieren



Vorschau

Beinhaltet: 1x Form, 1x RichTextBox, 1x CommandButton

download Freeware (kostenloses Programm runterladen)
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 Seitenanfang Nächster Abschnitt Vorheriger Abschnitt

 

 

 

. |<< Freeware >
Letzte Änderung M/T/J
© www.design-cad.de 2010