XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Dialogfenster: Fontauswahl mit Vorgabewerten und Rückgabemöglichkeit
-------------------------------------------------------------
ChsFont.inc 	               Dialog zur Fontauswahl anzeigen
Eine Beschreibung der Prozedur ist in ChsFont.txt enthalten
Version 1.0  22.2.2001.      Für Schäden kann keine Haftung übernommen werden.
Autor: Gerhard Putschalka
email: g.putschalka@web.de
homepage: http://members.telering.at/g.putschalka/index.html
folgende Declares müssen global und daher ausserhalb der Prozedur sein.
Declare F_ChsFnt#,F_Fnt#,F_Font$,F_Siz%,F_Kurs%,F_Ulin%,F_Bold%,F_Rot%,F_Grn%,F_Blu%
Def ChooseFont(1) ! COMDLG32.DLL,ChooseFontA,#,%

Proc Fontauswahl			 Dialog zur Fontauswahl

    Parameters Font$,Size%,Kurs%,Ulin%,Bold%,Rot%,Grn%,Blu%
    Declare RetCod&,RetCod%,Farbe&
    Let Farbe& = @Rgb(Rot%,Grn%,Blu%)
    Let Size% = Size% * 100 / 75	 Fonthöhe 1000 entspricht 10
    Dim F_Fnt#,80
    Dim F_ChsFnt#,60
    Struktur TChooseFont
    Long F_ChsFnt#,0 = 60          Länge der Struktur
    Long F_ChsFnt#,4 = %hwnd       Handle des Elternfensters (def. Hauptfenster)
    Long F_ChsFnt#,8 = 0           Drucker DC/IC
    Long F_ChsFnt#,12= F_Fnt#      Zeiger zuLogFontStruktur
    Long F_ChsFnt#,16 = 0          10 * Points  des gewählten Fonts
    Long F_ChsFnt#,20 = $00002341  Dialog Flags
    Long F_ChsFnt#,24 = Farbe&     ausgew. Textfarbe
    Long F_ChsFnt#,28 = 0          Daten zur Hook Funktion
    Long F_ChsFnt#,32 = 0          Zeiger zur Hook Funktion
    long F_ChsFnt#,36=  0          Zeiger auf Dialogvorlage
    Long F_ChsFnt#,40=  0          Instancehandle
    long F_ChsFnt#,44=  0          Schriftschnitt
    Long F_ChsFnt#,48=  $00000001  Font Type
    Long F_ChsFnt#,52=  2          minimale erlaubte Fontgröße
    Long F_ChsFnt#,56=  48         maximale erlaubte Fontgröße
    Struktur LogFont
    Long F_Fnt#,0=Size%            Fonthöhe
    Long F_Fnt#,4=20               Fontweite (1000 entspricht 10)
    Long F_Fnt#,8=0
    Long F_Fnt#,12=200             Font-Orientation
    Long F_Fnt#,16=400             ... normal
    String F_Fnt#,20=
    String F_Fnt#,21=
    CaseNot (Bold% = 0) : Long F_Fnt#,16=600    oder fett
    CaseNot (Kurs% = 0) : String F_Fnt#,20=1  kursiv
    CaseNot (Ulin% = 0) : String F_Fnt#,21=1 unterstrichen
    String F_Fnt#,22=            durchgestrichen (nicht benutzt)
    String F_Fnt#,23=0           Zeichensatz
    String F_Fnt#,24=T           Ausgabequalität
    String F_Fnt#,25=T           Clipping
    String F_Fnt#,26=0           Qualität (Schirm)
    String F_Fnt#,27=2           Schriftfamilie
    String F_Fnt#,28=Font$         Name der Schrift
    Let Retcod& = ChooseFont(F_ChsFnt#)
    Let RetCod% = RetCod&
    Attribute auslesen
    die folgenden Variablen sind global definiert und können daher ausserhalb
    der Prozedur benutzt werden.
    Let F_Font$ = @string$(F_Fnt#,28)
    Let F_Siz%  = div(@word(F_ChsFnt#,16),10)
    Let F_Kurs%  = @Ord(@string$(F_Fnt#,20))
    Let F_Ulin%  = @Ord(@string$(F_Fnt#,21))
    CaseNot (F_Kurs% = 0) : Let F_Kurs% = 1

    If (@Long(F_Fnt#,16) > 600)

        Let F_Bold%=1

    else

        Let F_Bold%=0

    endif

    Let F_Rot% = @GetRValue(@long(F_ChsFnt#,24))
    Let F_Grn% = @GetGValue(@long(F_ChsFnt#,24))
    Let F_Blu% = @GetBValue(@long(F_ChsFnt#,24))
    Dispose F_ChsFnt#
    Dispose F_Fnt#
    Return RetCod%

EndProc

-------------------------------------------------------------
goto ausführen       <===== ermöglicht die Ausführung des Testprogrammes.
Beschreibung der Prozedur Fontauswahl (mit Testprogramm)
Mit dem Aufruf der Prozedur Fontauswahl aus einem Profanprogramm wird der Systemdialog zur
Auswahl einer Schrift, der Größe, der Farbe und der Attribute unterstreichen, fett und
kursiv aufgerufen.
Beim Aufruf können bereits die auszuwählenden Werte mitgegeben werden, die dann im System-
dialog entsprechend vorgegeben sind.
Im Dialog können alle diese Werte geändert werden. Diese geänderten Werte werden dann an das
aufrufende Programm zurückgegeben.
Die zurückgegebenen Werte sind in der Form, daß sie mit den Profanbefehlen UseFont und
TextColor verarbeitet werden können.
Version 1.0  22.2.2001.       Für Schäden kann keine Haftung übernommen werden.
Autor: Gerhard Putschalka
email: g.putschalka@web.de
homepage: http://members.telering.at/g.putschalka/index.html
Aufruf:
Fontauswahl F$,S%,K%,U%,D%,R%,G%,B%
wobei
F$ ... String  ... Vorgabe für Font (Schriftart)
S% ... Integer ... Vorgabe für Fontgröße (2 bis
K% ... Integer ... Vorgabe kursiv ( 0 = nein, 1 = ja)
U% ... Integer ... Vorgabe unterstrichen ( 0 = nein, 1 = ja)
D% ... Integer ... Vorgabe bold (fett) ( 0 = nein, 1 = ja)
R% ... Integer ... Vorgabewert für Textfarbe rot (0, 128, 192 oder 255)
G% ... Integer ... Vorgabewert für Textfarbe grün (0, 128, 192 oder 255)
B% ... Integer ... Vorgabewert für Textfarbe blau (0, 128, 192 oder 255)
ist.
Bei der Rückkehr in das aufrufende Programm zeigt der Returncode (@%(0)) die Beendigung an
0 = der Systemdialog wurde abgebrochen, rückgemeldete Werte sind nicht gültig
1 = der Systemdialog wurde korrekt beendet, rückgemeldete Werte sind gültig.
Die Variablen die die rückgegebenen Werte enthalten sind in der Prozedur, jedoch global
definiert. Die Namen sind: F_Font$, F_Siz%, F_Kurs%, F_Ulin%, F_Bold%, F_Rot%, F_Grn%, F_Blu%
Die Farbwerte sind auch hier getrennt und können mit z.B. @Rgb(F_Rot%,F_Grn%,F_Blu%) ver-
arbeitet werden.
Das Attribut Strike (durchstreichen) im Systemdialog wird ignoriert, da es mit UseFont nicht
verwertet werden kann.
Im Programm, welches die Prozedur Fontauswahl verwendet muß die
Anweisung    $I ChsFont.inc    eingesetzt werden.
(! muß im globalen Bereich stehen also nicht innerhalb einer anderen Prozedur !)
Kurzbeschreibung zum Testprogramm.
Nach dem Start wird ein Dialog gezeigt in dem man die Schriftart und die Attribute eingeben
kann. Mit ausführen wird der Systemdialog angezeigt, wobei auf die Attribute positioniert
ist, die vorgegeben wurden. Hier sind Änderungen möglich. Mit ok oder Abbrechen erscheint
wieder der erste Dialog und die Auswahlen werden links im Fenster angezeigt.
================================================
ausführen:		 hier beginnt das Testprogramm.
Declare F$,S%,K%,U%,D%,R%,G%,B%,_dlg%,F_Box%,S_Box%,R_Box%,Ck%,Cu%,Cd%,Zl%,Bok%,BEnde%,Ende%
 $I ChsFont.inc

Proc Ausführen

    lesen der Angaben aus dem Eingabedialog und aufbereiten der Daten für den
    Aufruf von FontAuswahl
    Declare Z$,X%,Z1$,Z2$
    Let F$ = @GetText$(F_Box%)
    Let K% = @GetCheck(Ck%)
    Let U% = @GetCheck(Cu%)
    Let D% = @GetCheck(Cd%)
    Let S% = @Val(@GetText$(S_Box%))
    Let Z$ = @Substr$(@GetText$(R_Box%),2,;)
    Let R% = @Val(@Mid$(Z$,1,3))
    Let G% = @Val(@Mid$(Z$,4,3))
    Let B% = @Val(@Mid$(Z$,7,3))
    Fontauswahl aufrufen
    Fontauswahl F$,S%,K%,U%,D%,R%,G%,B%
    auswerten  der Angaben aus der Fonauswahl

    If (@%(0) = 0)

        Print Return-abgebrochen, die Werte sind ungültig

    Else

        Print Return-ok

    EndIf

    Print Font-;F_Font$,Größe-;F_Siz%
    Print kursiv-;F_Kurs%,unterstr.-;F_Ulin%,fett-;F_Bold%
    Farbe übersetzen
    Let Z$ = @Format$(000,F_Rot%);@Format$(000,F_Grn%);@Format$(000,F_Blu%)
    Let X% = 0

    While (X% < 16)

        Let Z1$ = @ListBoxItem$(X%)
        Let Z1$ = @Substr$(Z1$,2,;)

        If @Equ$(Z1$,Z$)

            Let Z2$ = @Trim$(@Substr$(@ListBoxItem$(X%),1,;))
            Let X% = 16

        EndIf

        Inc X%

    EndWhile

    Print Farbe-;Z2$
    Print ----------
    Return

EndProc

=========
MainLine
=========
windowtitle Test für Fontauswahl
WindowStyle 16
Window 0,0-800,550
settruecolor 1
cls @RGB(255,255,200)
Dialog für Vorgabewerte
Let _dlg%=@createdialog(%Hwnd,Vorgabewerte für Fontauswahl,320,88,460,288)
Let F_Box%=@createchoicebox(_dlg%,,32,24,176,152)
Let S_Box%=@createchoicebox(_dlg%,,224,24,40,152)
Let Ck%=@createcheckbox(_dlg%,kursiv,312,24,110,18)
Let Cd%=@createcheckbox(_dlg%,Fettdruck,312,54,110,18)
Let Cu%=@createcheckbox(_dlg%,unterstrichen,312,84,110,18)
Let R_Box%=@createchoicebox(_dlg%,,32,144,95,104)
Let Bok%=@createbutton(_dlg%,ausführen,312,144,112,24)
Let BEnde%=@createbutton(_dlg%,Ende,312,200,112,24)
@createtext(_dlg%,Schriftart,32,5,90,16)
@createtext(_dlg%,Größe,220,5,90,16)
@createtext(_dlg%,Schriftfarbe,35,125,90,16)
initialisieren der Auswahlboxen
ClearList
AddFonts
@MoveListToChoice(F_Box%)		 Box für Fonts
@SendMessage(F_Box%,$014E,3,0)
ClearList
Let Zl% = 2

While (Zl% < 49)

    If (Zl% < 10)

        addstring @Add$( ,@Str$(Zl%))

    Else

        addstring @Str$(Zl%)

    EndIf

    Inc Zl%

EndWhile

@MoveListToChoice(S_Box%)		 Box für Fontgrößen
@SendMessage(S_Box%,$014E,6,0)
ClearList
AddString Schwarz           ;000000000
AddString Dunkelrot         ;128000000
AddString Dunkelgrün        ;000128000
AddString Ocker             ;128128000
AddString Dunkelblau        ;000000128
AddString Purpur            ;128000128
AddString Blaugrün          ;000128128
AddString Grau              ;128128128
AddString Hellgrau          ;192192192
AddString Rot               ;255000000
AddString Grün              ;000255000
AddString Gelb              ;255255000
AddString Blau              ;000000255
AddString Lila              ;255000255
AddString Aquamarin         ;000255255
AddString Weiß              ;255255255
@MoveListToChoice(R_Box%)		 Box für die Schriftfarben
@SendMessage(R_Box%,$014E,14,0)

WhileNot Ende%

    WaitInput

    If @Getfocus(Bok%)

        Ausführen

    ElseIf @Getfocus(BEnde%)

        Let Ende% = 1

    EndIf

EndWhile

End