Abschnitt 1

»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? 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 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

Pythagoras-Uhr

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

Muster

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

Abschnitt 3

Pythagoras-Clock (Linux-Version) 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 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. Setup-Hinweise Freeware (kostenlos), Open Source (offener Quelltext) Mini-Beispiel mit wenigen BASIC-Code-Zeilen als Text '....BeispielCode.... Dim i as Integer Dim sText as String For i = 0 to 10 sText = sText & Str(i) & Space(1) Next Print sText & "Fertig" '....BeispielCode.... Ergebnis: 0 1 2 3 4 5 6 7 9 10 Fertig Das Programm pythagorasclock wurde erstellt mit der Programmiersprache "Gambas3". Herstellerseite: https://gambaswiki.org/website/en/main.html

Abschnitt 4

Beispiele in der Programmier-Sprache VB6 (Visual Basic)

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). Beispiel-Projekt in VB6, Download

Zwischenablage zwischen "Kopieren & Einfügen" anzeigen Beispiel-Projekt in VB6, Download

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

Hauptadresse markieren http://www.muster-adresse.de/muster.html Beispiel-Projekt in VB6, Download

Abschnitt 5

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

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

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

Abschnitt 7

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

Abschnitt 8

Alternativ: Text im Vollbild anzeigen?

Abschnitt 9

Beispiel 1 + Beispiel 2 «HTML-Tags» und »Text« in RTF markieren Datei: textfiltern_quelltexttags.zip Dateigröße ca. 4 KB (0,004 MB) Komplettes Beispiel-Projekt in VB6 Datei speichern, entpacken, [VBProjekt].vbp öffnen... Setup-Hinweise Freeware (kostenlos), Open Source (offener Quelltext)

Abschnitt 10

Zwischenablage

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 Datei: form2_zablage.zip Dateigröße ca. 4 KB (0,004 MB) Komplettes Beispiel-Projekt in VB6 Datei speichern, entpacken, [VBProjekt].vbp öffnen... Setup-Hinweise Freeware (kostenlos), Open Source (offener Quelltext)

Abschnitt 11

Funktionen, Beispiele

'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 '########################################################## Setup-Hinweise Freeware (kostenlos), Open Source (offener Quelltext) Zeilen in Visual Basic, VB6

Abschnitt 12

Hauptadresse markieren

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

Hauptadresse markieren Datei: form1_adressemarkieren.zip Dateigröße ca. 3 KB (0,003 MB) Komplettes Beispiel-Projekt in VB6 Datei speichern, entpacken, [VBProjekt].vbp öffnen... Setup-Hinweise Freeware (kostenlos), Open Source (offener Quelltext)

Abschnitt Ende