XProfan

Français

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Hauptfenster: Fenster mit Farbverlauf füllen

PROC GradientFill

    Parameter: Anfangsfarbe,Endfarbe,Anzahl Farben,Richtung (0= Vertikal, > 0 = Horizontal)
    parameters TopColor&,EndColor&,Colors%,direction%
    declare r%,g%,b%,reddif%,greendif%,bluedif%,i%,h%
    DEF MulDiv(3) @div(@mul(@%(1),@%(2)),@%(3))
    SetTruecolor 1
    Case @lt(colors%,8): let colors%= 8    weniger sieht nicht gut aus, DARF nicht < 2 sein
    usepen 5,0,0 						   Rand unterdrücken
    let RedDif%=@sub(GetRValue(EndColor&),GetRValue(TopColor&))
    let GreenDif%=@sub(GetGValue(EndColor&),GetGValue(TopColor&))
    let BlueDif%=@sub(GetBValue(EndColor&),GetBValue(TopColor&))

    WHILE @lt(i%,colors%)

        let r% = @add(GetRValue(TopColor&), MulDiv(i%, RedDif%, Colors%));
        let g% = @add(GetGValue(TopColor&) , MulDiv (i%, GreenDif%, Colors%));
        let b% = @add(GetBValue(TopColor&) , MulDiv (i%, BlueDif%, Colors%));
        usebrush 1, @rgb(r%,g%,b%)

        IF direction%

            rectangle MulDiv(i%,width(%hwnd),colors%),0 -
            @MulDiv(@add(i%,2),width(%hwnd),colors%),height(%hwnd)

        ELSE

            rectangle 0,MulDiv(i%,Height(%hwnd),colors%) - Width(%hwnd),
            @MulDiv(@add(i%,2),Height(%hwnd),colors%)

        ENDIF

        inc i%

    WEND

ENDPROC

Demoprogramm
 $P+
declare ende%,lastmenu%,verlauf%,titel$
windowstyle 47
let titel$=Gradient - Demo  - © 1997 Thomas Hölzer, Thoelzer@aol.com - Farben:
windowtitle @add$(titel$,16)
window 0,0-640,480
appendmenubar 2,&Vertikal
appendmenubar 3,&Horizontal
popup  &Verlaufsfarben
appendmenu 8,8
appendmenu 16,16
appendmenu 32,32
appendmenu 64,64
appendmenu 128,128
appendmenubar 1,&Beenden
SetTrueColor 1
let verlauf%=16
GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
let lastmenu%=2

whilenot ende%

    waitinput

    IF @menuitem(1)

        let ende%=1

    ELSEIF @menuitem(2)

        GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
        let lastmenu%=2

    ELSEIF @menuitem(3)

        GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        let lastmenu%=3

    ELSEIF @gt(%menuitem,7)

        let verlauf% = %menuitem
        windowtitle @add$(titel$,str$(%menuitem))

    ELSEIF @equ(%key,4)

        case @equ(lastmenu%,2): GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        case @equ(lastmenu%,3): GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0

    ENDIF

Wend

end

16.07.2007 ▲

Vollständiges citation

Absatzweise Citation Zeilenweise Citation

Jörg
Sellmeyer

aussi ne très belle l'affaire!

Kompilieren Marque Séparation

 $I profalt.inc

PROC GradientFill

    'paramètre: Anfangsfarbe,Endfarbe,Anzahl Farben,direction (0= Vertikal, > 0 = Horizontal)
    parameters TopColor&,EndColor&,Colors%,direction%
    declare r%,g%,b%,reddif%,greendif%,bluedif%,i%,h%
    DEF MulDiv(3) @div(@mul(@%(1),@%(2)),@%(3))
    SetTruecolor 1
    Cas @lt(colors%,2): let colors%=  2'moins sieht pas bien aus, DARF pas < 2 son
    usepen 5,0,0'rebord unterdrücken
    let RedDif%=@sub(GetRValue(EndColor&),GetRValue(TopColor&))
    let GreenDif%=@sub(GetGValue(EndColor&),GetGValue(TopColor&))
    let BlueDif%=@sub(GetBValue(EndColor&),GetBValue(TopColor&))

    WHILE @lt(i%,colors%)

        let r% = @add(GetRValue(TopColor&), MulDiv(i%, RedDif%, Colors%));
        let g% = @add(GetGValue(TopColor&) , MulDiv (i%, GreenDif%, Colors%));
        let b% = @add(GetBValue(TopColor&) , MulDiv (i%, BlueDif%, Colors%));
        usebrush 1, @rgb(r%,g%,b%)

        IF direction%

            rectangle MulDiv(i%,width(%hwnd),colors%),0 - \
            @MulDiv(@add(i%,2),width(%hwnd),colors%),height(%hwnd)

        ELSE

            rectangle 0,MulDiv(i%,Height(%hwnd),colors%) - Width(%hwnd),\
            @MulDiv(@add(i%,2),Height(%hwnd),colors%)

        ENDIF

        inc i%

    WEND

ENDPROC

'Demoprogramm
' $P+
declare ende%,lastmenu%,verlauf%,titel$
style de fenêtre 47
let titel$="Gradient - Demo  - © 1997 Thomas Bois, Thoelzer@aol.com - Farben:"
windowtitle @add$(titel$,"16")
window 0,0-640,480
appendmenubar 2000,"&Vertikal"
appendmenubar 3000,"&Horizontal"
popup  "&Verlaufsfarben"

WhileLoop 2,10

    AppendMenu &Boucle,Str$(&Boucle)

Wend

WhileLoop 12,128,4

    AppendMenu &Boucle,Str$(&Boucle)

Wend

appendmenu 256,"256"
appendmenu 512,"512"
'appendmenu 8,"8"
'appendmenu 16,"16"
'appendmenu 32,"32"
'appendmenu 64,"64"
'appendmenu 128,"128"
appendmenubar 1000,"& Quitter"
let verlauf%=16
GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
let lastmenu%=2000

whilenot ende%

    waitinput

    IF @menuitem(1000)

        let ende%=1

    ELSEIF @menuitem(2000)

        GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
        let lastmenu%=2000

    ELSEIF @menuitem(3000)

        GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        let lastmenu%=3000

    ELSEIF @Between(%menuitem,1,512)

        let verlauf% = %menuitem
        windowtitle @add$(titel$,str$(%menuitem))
        cas @equ(lastmenu%,2000): GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        cas @equ(lastmenu%,3000): GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
        repaint

    ELSEIF @equ(%clé,4)

        cas @equ(lastmenu%,2000): GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        cas @equ(lastmenu%,3000): GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
        repaint

    ENDIF

Wend

end

Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...

03.06.2018 ▲

Vollständiges citation

Absatzweise Citation Zeilenweise Citation

p.specht

ici comme XProfan-11.2a Version. Super, cela partie!

Kompilieren Marque Séparation

' GradientFill (C) 1997 T.Hoelzer, restored 2018-05 by J.Sellmeyer
' Converted to XProfan-2.11 Version dans 2018-06 by P.Specht/Vienna

PROC GradientFill :parameters TopColor&,EndColor&,Colors%,direction%

    ' Anfangsfarbe,Endfarbe,Anzahl Farben,direction (0=Vertikal, >0=Horizontal)
    declare r%,g%,b%,reddif%,greendif%,bluedif%,i%,h%
    Set("Truecolor",1)
    Cas colors%<2:colors%=2'moins sieht pas bien aus
    usepen 5,0,0'rebord unterdrücken
    RedDif%  = GetRValue(EndColor&)-GetRValue(TopColor&)
    GreenDif%= GetGValue(EndColor&)-GetGValue(TopColor&)
    BlueDif% = GetBValue(EndColor&)-GetBValue(TopColor&)

    WHILE i%<colors%

        r% = GetRValue(TopColor&) + MulDiv(i%, RedDif%, Colors%)
        g% = GetGValue(TopColor&) + MulDiv(i%, GreenDif%, Colors%)
        b% = GetBValue(TopColor&) + MulDiv(i%, BlueDif%, Colors%)
        usebrush 1, rgb(r%,g%,b%)

        IF direction%

            rectangle MulDiv(i%,width(%hwnd),colors%),0 - \
            MulDiv(i%+2,width(%hwnd),colors%),height(%hwnd)

        ELSE

            rectangle 0,MulDiv(i%,Height(%hwnd),colors%) - Width(%hwnd),\
            MulDiv(i%+2,Height(%hwnd),colors%)

        ENDIF

        inc i%

    ENDWHILE

ENDPROC

' Hilfsfunktion
:Proc MulDiv :parameters a%,b%,c%:return (en%*b%)\c%:ENDPROC
' D e m o p r o g r a m m
Déclarer ende%, lastmenu%, verlauf%, titel$
Fenêtre Style 47
Titel$="Gradientdemo XProf-11 Version of ©1997 T.Bois THoelzer@aol.com"
Titre de la fenêtre titel$+"16"
window 0,0-640,480
appendmenubar 2000,"&Vertikal"
appendmenubar 3000,"&Horizontal"
popup  "&Verlaufsfarben"
:WhileLoop 2,10:AppendMenu &Boucle,Str$(&Boucle):Endwhile
:WhileLoop 12,128,4:AppendMenu &Boucle,Str$(&Boucle):Endwhile
appendmenu 256,"256"
appendmenu 512,"512"
'appendmenu 8,"8"
'appendmenu 16,"16"
'appendmenu 32,"32"
'appendmenu 64,"64"
'appendmenu 128,"128"
appendmenubar 1000,"& Quitter"
verlauf%=16
GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
lastmenu%=2000

WHILENOT Ende%

    waitinput

    IF @menuitem(1000)

        Ende%=1

    ELSEIF @menuitem(2000)

        GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
        lastmenu%=2000

    ELSEIF @menuitem(3000)

        GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        lastmenu%=3000

    ELSEIF @Between(%menuitem,1,512)

        verlauf% = %menuitem
        Windowtitle titel$+str$(%menuitem)
        cas lastmenu%=2000:GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        cas lastmenu%=3000:GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
        repaint

    ELSEIF %clé=4

        cas lastmenu%=2000:GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,1
        cas lastmenu%=3000:GradientFill RGB(0,0,255),RGB(255,0,0),verlauf%,0
        repaint

    ENDIF

ENDWHILE

FIN