.

Abschnitt 0 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

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


Nimm, vermehre, teile.
Freeware

+AAAA Schrift+Zoom oben im Browser-Menü vergrößern


Beispiele für kleine und große Programmierer

Allgemein Programmier-Sprache BASIC:
  • "VB6" (Visual Basic 6.0 (tm), Windows-Betriebssystem)
  • "Gambas3" (Linux-Betriebssysteme, viel "Europa")

     

    Abschnitt 1 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    »Satz des Pythagoras« (Pythagorean theorem)

    Pythagoras-Uhr, Pythagoras-Schmetterling, Pythagoras-Waage, Winkelfunktionen berechnen, Kreispunkte ermitteln, anschaulich verständlich.
    Wie kann ein Uhr-Zeiger oder ein Bemaßungs-Pfeil mathematisch genau gezeichnet werden? Technische Maßpfeile ◁— —▷
    Bei senkrechten oder waagerechten Linien sind die Koordinaten-Punkte relativ einfach gesetzt. Aber wo liegen bei gedrehten Linien die Koordinaten-Punkte?

    Nächster Abschnitt Beispiel-Projekt in der Programmier-Sprache "Gambas3"
    Gambas3 ist eine Programmier-Sprache für Linux-Betriebssysteme und ähnlich zu anderen "BASIC"-Varianten wie "VB6". Hinweis zu Linux Info-Schritte


    Pythagoras Pythagoras Pythagoras Pythagoras Pythagoras Pythagoras
    Pythagoras Pythagoras Pythagoras Pythagoras Pythagoras Pythagoras
    Pythagoras Uhr-Zeiger_Masspfeil
    Satz-des-Pythagoras Satz-des-Pythagoras-Beispiel Satz-des-Pythagoras-Beispiel-Quadrate Pythagoras Waage
    Kopieren mit rechter Maustaste.

    Mathematik —▷ Geometrie —▷ Trigonometrie, Tri (3, drei), Drei-Ecke (3), Winkel-Funktionen, Tangente, Kreis-Bogen, Torten-Ausschnitt, Uhr-Zeiger, Zeichnung+Bemaßung+Pfeil, Maßpfeil, Sinus (sin), Kosinus (cos), Tangens (tan), Satz des Pythagoras, rechtwinkliges Dreieck, a² + b² = c². Sprachlich: a-Quadrat plus b-Quadrat gleich c-Quadrat. Die Gleichung ist ausgeglichen.

    Mit anderen Worten im Gleichnis mit Gewichten:
    Ein kleiner und ein größerer Eimer mit Wasser sind, zusammen auf der linken Seite, genauso schwer wie die Summe beider Eimer in einem einzigen Eimer auf der rechten Seite. Der linksseitige Gesamt-Wert ist identisch mit dem rechtsseitigem Gesamt-Wert (Volumen, Größe). Als Quadrate werden die unterschiedlichen Größen anschaulicher. Fehlt ein Wert, so kann diese Gleichung (=) umgestellt werden, wobei bekannte Gesamt-Werte auf der einen Seite stehen und der unbekannte Wert allein auf der anderen Seite. Dreiecke mit (1) 'einem' 90°Grad-Winkel sind im Kreis immer vorhanden.

    Auf der leeren Fläche wird ein erster Anfangs-Punkt gesetzt und ein rechtwinkliges Koordinaten-Kreuz (x,y Achsen) kann dann darüber gelegt werden. Über einen weiteren Punkt wird die Entfernung fest gelegt. Ein rechtwinkliges Dreieck kann in dem rechtwinkligen Koordinaten-Kreuz eingezeichnet werden und die Werte können dann abgelesen werden. Über bekannte und rechtwinklige Dreiecke (90°) können andere, fehlende und unbekannte Koordinaten-Punkte berechnet werden.

     

     

    Abschnitt 2 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    Pythagoras-Uhr



    Vorschau Software: pythagorasclock

    Beinhaltet: Ein kleines und komplettes Roh-Programm mit Code-Zeilen und Icons, einsehbar mit einfachen Text- und Bildprogrammen. Zur weiteren Verarbeitung ist die Programmier-Sprache "Gambas3" erforderlich (kostenlos in Ubuntu-Software) oder beim Hersteller Gambas3.

    Gambas3 ist eine Programmier-Sprache für Linux-Betriebssysteme und ähnlich zu anderen "BASIC"-Varianten wie "VB6". Eine Umstellung ist möglich, mit einigen Anpassungen. (Windows —▷ Linux). Basis Lerninhalte: 1. Einfache mathematische Gleichungen | 2. Geometrie, Winkel und Konstruktionen | 3. Programmieren

  • deutsch/english
  • Bild-Dateien (*.png). Bearbeitbar in anderen Bild-Programmen.
  • Text-Dateien (*.class;*.form;*.txt;...). Bearbeitbar in anderen Text-Programmen.
  • Einzelbilder berechnen
  • Demo-Version mit automatischem Durchlauf (Anfang —▷ Ende)
  • ...

    Vorschau Vorschau Vorschau
    Muster

    Update:
    Im Software-Center des Betriebssystems das Programm deinstallieren, danach neu installieren. Eigene Einstellungen und Dateien bleiben erhalten.

    Abschnitt 3 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    FreewarePythagoras-Clock (Linux-Version)

    download Freeware (kostenloses Programm runterladen)
    Datei: pythagorasclock_0.0.14-0ubuntu1_all.deb
    Version 0.0.14, 2024, Dateigröße 0,7 MB, System.Architecture: Alle, 32-bit & 64-bit, x86, x86_64, arm, aarch64, powerpc, e2k
    Öffnen mit:
    Software-Center. Als ausführbares Programm: Installation für Unix-Betriebssysteme. Variante Linux. Linux mit weiteren Varianten: Linux Ubuntu LTS (Mint, Lubuntu, Kubuntu, Edubuntu (Schule), Xubuntu, Studio, ...), Debian, Gnome, Mageia, Manjaro, FreeBSD, MX-Linux, Fedora, OpenSUSE, KDE Plasma, u.a. ...)
    Datei speichern, Mausmenü > Mit Software-Center öffnen (System-Einstellungen>Anwendungen: Suche: pythagorasclock)
    Update durch erneute Installation

    download Freeware (kostenloses Programm runterladen)
    Datei: pythagorasclock_0.0.14.orig.tar.gz
    Version 0.0.14, 2024, Dateigröße 0,8 MB, Tar-Archiv (gzip-komprimiert)
    Öffnen mit:
    Archiv-Verwaltung. Als Roh-Programm für Programmierer: Beinhaltet: Ein kleines und komplettes Roh-Programm mit Code-Zeilen und Icons, einsehbar mit einfachen Text- und Bild-Programmen. Zur Bearbeitung ist die Programmier-Sprache "Gambas3" erforderlich (kostenlos in Ubuntu-Software) oder beim Hersteller. (Linux Ubuntu u.a. ...)
    Datei speichern, Mausmenü > Mit Archiv-Verwaltung öffnen, entpacken, Unter-Ordner mit allen Dateien.

    Diese Freeware ist ohne Einschränkungen und geeignet für Übungszwecke, zum Verändern und Erweitern.
    Rein schauen, miteinander lernen, eigene Projekte erstellen.


    Info-SchritteSetup-Hinweise

    Freeware (kostenlos), Open Source (offener Quelltext)

    Testen, ausprobieren?

    Folgendes Beispiel mit wenigen BASIC-Code-Zeilen als Text
    im Feld "Alles auswählen" und "Kopieren" (rechte Maustaste)

    ...und auf der Herstellerseite im Textfeld ebenso "Alles auswählen" oder Textfeld leeren, "Einfügen" und ausführen mit dem Schalter "Run".
    https://gambas.sourceforge.net/de/main.html
    Siehe » Menü Playground oder "Spielplatz" auf der Herstellerseite Gambas3.
    Ergebnis:
    0 1 2 3 4 5 6 7 9 10 Fertig

     

     

    Abschnitt 4 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    Beispiele in der Programmier-Sprache VB6 (Visual Basic)



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

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

    Nächster Abschnitt Beispiel-Projekt in VB6, Download



    Zwischenablage zwischen "Kopieren & Einfügen" anzeigen

    Vorschau

    Nächster Abschnitt Beispiel-Projekt 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 Beispiel-Projekt in VB6, Download

     

     

    Abschnitt 5 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

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



    Vorschau

     

    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

     

     

    Abschnitt 6 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    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).
    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.

     

     

    Abschnitt 7 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    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 = "Sans-Serif"

    .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

     

     

    Abschnitt 8 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

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

    Alternativ: Text im Vollbild anzeigen?

     

     

    Abschnitt 9 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    Vorschau

    Beispiel 1 + Beispiel 2

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

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

    Freeware (kostenlos), Open Source (offener Quelltext)

     

     

    Abschnitt 10 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    Zwischenablage



    Vorschau

    Das kleine Programm kann als eine weitere Form in deinem 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

    Zwischenablage

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

    Freeware (kostenlos), Open Source (offener Quelltext)

     

     

    Abschnitt 11 Seitenanfang Seitenende Vorheriger Abschnitt Nächster 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

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

    Info-SchritteSetup-Hinweise

    Freeware (kostenlos), Open Source (offener Quelltext)

    Zeilen in Visual Basic, VB6

     

    Abschnitt 12 Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

    Hauptadresse markieren



    Vorschau

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

    Hauptadresse markieren

    download Freeware (kostenloses Programm runterladen)
    Datei: form1_adressemarkieren.zip
    Dateigröße ca. 3 KB (0,003 MB)
    Komplettes Beispiel-Projekt in VB6
    Datei speichern, entpacken, [VBProjekt].vbp öffnen...
    Info-SchritteSetup-Hinweise

    Freeware (kostenlos), Open Source (offener Quelltext)

    Abschnitt Ende Seitenanfang Seitenende Vorheriger Abschnitt Nächster Abschnitt

  • . |<< . Freeware > .
    Letzte Änderung 2024
    © www.design-cad.de