XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Copyright- und Versionsinformationen
Größe an die Texte anpassen alles andere verändert sich mit.
Dies ist nur ein Beispiel, ohne Abfrage ob die Maße gültig sind
es wird nicht alles abgefangen
Es sollte nur die Möglichkeit bestehen etwas längeren Text
ohne Probleme unterzubringen.
min lang%=360
min hoch%=290
Autor Dieter Zornow, der Code kann frei verwendet werden

PROC copyright

    DECLARE Copydlg&,ende%,ok%,lang%,hoch%,maske%,maske1%
    let lang%=400hier Länge festlegen kann auch mit parametern übergeben werden
    let hoch%=400hier Höhe festlegen
    case @lt(sizeX%,lang%):let sizeX%=lang%
    case @lt(sizeY%,hoch%):let sizeY%=hoch%
    LET copydlg&=CREATEDIALOG(%HWND,Copyright und Versionsinformation,@sub(@add(xpos%,div(sizeX%,2)),@div(lang%,2)),@sub(@add(ypos%,div(sizeY%,2)),@div(hoch%,2)),lang%,hoch%)
    USEFONT MS Sans Serif,13,0,0,0,0
    SETDIALOGFONT 1
    LET ok%=@CREATEBUTTON(Copydlg&,&OK,45,@sub(hoch%,63),@sub(lang%,95),25)

    PROC show

        SETAUTOPAINT 2
        STARTPAINT Copydlg&
        cls RGB(208,200,208)
        @destroywindow(maske%)
        @destroywindow(maske1%)
        let maske%=Control(STATIC,,$50000006,45,@add(@sub(hoch%,hoch%),6),@sub(lang%,95),sub(hoch%,80),copydlg&,0,%hinstance,$020200)
        USEFONT Arial,18,0,1,0,0
        Textcolor RGB(255,0,0),-1
        DrawText 60,10,        Mein Programm, Version 1.0
        USEFONT Arial,18,0,0,0,0
        DrawText 60,40,        Das ist die Zeile 2 des Dlg´s
        DrawText 60,70,        Das ist die Zeile 3 des Dlg´s
        DrawText 60,100,        Das ist die Zeile 4 des Dlg´s
        Textcolor RGB(0,0,255),-1
        DrawText 60,130,         Copyright 2003 by Nobody
        DrawText 60,160,           E-mail: nobody@net.de
        Textcolor RGB(255,0,0),-1
        DrawText 60,190,                Lizenz: Freeware
        DRAWICON A,10,10 Aus Profan ein Icon
        DrawLibIcon Shell32.dll,46,10,10
        USEFONT MS Sans Serif,13,0,0,0,0
        let maske1%=Control(BUTTON,&Ok,$5001D000,45,@sub(hoch%,63),@sub(lang%,95),25,copydlg&,0,%hinstance,$0)Flacher Button zur Anzeige als Maske
        ENDPAINT
        SETAUTOPAINT 1 sonst kann man das Hauptfenster ausradieren

    ENDPROC

    show

    WHILENOT ende%

        Waitinput

        If @EQU(%KEY,2)

            LET ende%= 1

        ELSEIF %WMPAINT

            show

        Elseif Getfocus(ok%)

            LET ende%= 1

        ENDIF

    WEND

    SETAUTOPAINT 2 abhängig von Programmeinstellungen
    @DESTROYWINDOW(Copydlg&)

ENDPROC

Proc Showcopyright

    Def @GetWindowPos(2) !USER32, GetWindowRect
    Declare pos#
    DIM pos#,16
    let hwnd&=@getactiveWindow() Handle des eigenen Fensters holen
    @GetWindowPos(hwnd&,pos#) die 4 Ecken holen per API
    let xpos%=@long(Pos#,0) links oben
    let ypos%=@long(Pos#,4)
    let xRpos%=@long(Pos#,8) rechts unten
    let yRpos%=@long(Pos#,12)
    SizeX%=@sub(xRpos%,xpos%) Fenstergröße X
    SizeY%=@sub(yRpos%,ypos%) Fenstergröße Y
    Dispose pos#
    copyright Dialog aufrufen

Endproc

Beispiel Hauptprogramm. Das ganze würde auch mit Parameterübergabe funktionieren
Declare xpos%,ypos%,xRpos%,yRpos%,hwnd&,sizeX%,SizeY%
SETTRUECOLOR 1
Windowstyle 15
Window 0,0-800,600
cls RGB(208,200,208)
Showcopyright Fensterposition und Größe holen und Dialog aufrufen
Print Bitte Fenster verschieben (und) oder auch kleiner oder größer ziehen
waitinput
Showcopyright wieder Fensterparameter holen und Aufruf
end