XProfan

Italia

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
RebarWindow (2)
(C) 2006 Nico Madysa
----- Beginn CONTROLS.INC ------------------------------------------------------------------------------
Struct ReBar = Size& , Mask& , Style& , clrFore& , clrBack& ,
lpText& , cch& , iImage& , hwndChild& , cxMinChild& ,
cyMinChild& , cx& , hbmBack& , wID& , cyChild& ,
cyMaxChild& , cyIntegral& , cxIdeal& , lParam& ,
cxHeader& , handle& , bandcount%
declare inum% , a#
Dim a# , 16
clear a#
Long a#,0 = 8
Long a#,4 = $FFFF---Alles initialisieren
External(comctl32.dll,InitCommonControlsEx,a#)
Dispose a#
{Labels}:

subproc Create.cText

    parameters pWnd& , text$ , x% , y% , dx% , dy%
    inc inum%
    return Control(STATIC,text$,$54000001,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance)

endproc

subproc Create.rText

    parameters pWnd& , text$ , x% , y% , dx% , dy%
    inc inum%
    return Control(STATIC,text$,$54000002,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance)

endproc

}Ende Labels

{Trackbar}:

subproc Create.TrackBar

parameters pWnd& , options$ , x% , y% , dx% , dy%
declare htb& , stil&
inc inum%
stil& = $54010040
options$ = Upper$(options$)
case InStr(SEL ,options$) : add stil& , 20
case InStr(BOTH,options$) : add stil& , 8
htb& = Control(msctls_trackbar32,,stil&,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance,$00000)
SetTrackRange htb& , val(SubStr$(options$,2,;)) , val(SubStr$(options$,3,;))
SetTrackPos htb& , val(SubStr$(options$,1,;))
return htb&

endproc

proc SetTrackPos

parameters h& , pos%
SendMessage(h&,$0405,1,pos%)

endproc

proc GetTrackPos

parameters h&
return SendMessage(h&,$0400,0,0)

endproc

proc SetTrackRange

parameters h& , anf% , end%
SendMessage(h&,$0406,1,MakeLong(anf%,end%))

endproc

}Ende TrackBar

{Progressbar}:

subproc Create.ProgressBar

if %pCount = 6

parameters pWnd& , stil& , x% , y% , dx% , dy%
declare hpb&
stil& = stil& + $50000000

else

parameters pWnd& , frame% , smooth% , x% , y% , dx% , dy%
declare hpb& , stil&
stil& = $50000000 + if(smooth%,1,0) + if(frame%,$800000,0)

endif

inc inum%
hpb& = Control(msctls_progress32,,stil&,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance)
return hpb&

endproc

proc SetProgPos

parameters h& , pos%
return Sendmessage(h&,$402,pos%,0)

endproc

}Ende ProgressBar

{ReBarGrip}:

subproc Create.ReBar

parameters rebar# , pWnd& , x% , y% , dx% , dy% , minx% , bx% , by% , cWnd& , fbgrip%
declare rebar&

if lower$(ClassOf(ReBar#)) = rebar

inc inum%
rebar&=Control(ReBarWindow32,,$50000804 ,x%,y%,dx%,dy%,pWnd&,inum%,0)

With Rebar#

.Size&       = SizeOf(ReBar#) - 6
.Mask&       = $71--RBBIM_STYLE | RBBIM_CHILD | RBBIM_CHILDSIZE | RBBIM_SIZE
.cyMaxChild& = 1  ------------------Darf nicht Null sein
.Style&      = if(fbgrip%,128,256)--RBBS_NOGRIPPER (1. Band ohne Griff)
.cxMinChild& = minx%----------------Minimum Breite
.cyMinChild& = by%------------------Höhe des Bandes
.cx&         = bx%------------------Vorgabe Breite
.hwndChild&  = cWnd&----------------Band 1
SendMessage(ReBar&,$0401,0,ReBar#)--RB_INSERTBAND
.handle&     = rebar&
.bandcount%  = 1

EndWith

return 1

else

return 0

endif

endproc

proc InsertReBarBand

parameters ReBar# , minx% , bx% , by% , cWnd&

if lower$(ClassOf(ReBar#)) = rebar

With ReBar#

.Style&      = 128-----------------RBBS_GRIPPERALWAYS (folgende Bänder mit Griff)
.cxMinChild& = minx%---------------Minimum Breite
.cyMinChild& = by%-----------------Höhe des Bandes
.cx&         = bx%-----------------Vorgabe Breite
.hwndChild&  = cWnd&---------------Band 2
SendMessage(.handle&,$0401,.bandcount%,ReBar#)--RB_INSERTBAND
.bandcount%  = .bandcount% + 1

EndWith

return 1

else

return 0

endif

endproc

proc DestroyReBar

parameters rebar#

if lower$(ClassOf(rebar#)) = rebar

DestroyWindow(rebar#.handle&)
Dispose rebar#

else

return 0

endif

endproc

}Ende ReBarGrip

----- Ende CONTROLS.INC --------------------------------------------------------------------------
declare band# , lb1& , lb2& , lb3&
Dim band# , ReBar
WindowTitle Rebar-Demo von Nico Madysa
Window 0 , 0 - 640 , 480
cls External(User32,GetSysColor,15)
ClearList
AddFonts
lb1& = Create(ListBox,%hWnd,0,0,0,0,0)
MoveListToHandle(lb1&)
lb2& = Create(ListBox,%hWnd,0,0,0,0,0)
MoveListToHandle(lb2&)
lb3& = Create(ListBox,%hWnd,0,0,0,0,0)
MoveListToHandle(lb3&)
Create(ReBar,band#,%hWnd,0,0,500,400,0,100,400,lb1&,1)
InsertReBarBand(band#,0,100,200,lb2&)
InsertReBarBand(band#,0,100,100,lb3&)

whilenot IsKey(27)

waitinput

wend

DestroyReBar band#
Dispose band#
end

16.07.2007 ▲

Vollständiges Zitat

Absatzweise Citazione Zeilenweise Citazione

« Dieser Beitrag wurde als Lösung gekennzeichnet. »

Jörg
Sellmeyer

Und auch repariert. Mühsam ernährt sich das Eichhörnchen...
Man sollte noch hinzufügen, dass das Rebarcontrol wohl auf einem Code von Uwe "Pascal" Niemeyer basiert.

Kompilieren Markieren Separieren

'Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
'RebarWindow (2)
'(C) 2006 Nico Madysa
'----- Beginn CONTROLS.INC ------------------------------------------------------------------------------
Struct ReBar = Size& , Mask& , Style& , clrFore& , clrBack& ,\
lpText& , cch& , iImage& , hwndChild& , cxMinChild& ,\
cyMinChild& , cx& , hbmBack& , wID& , cyChild& ,\
cyMaxChild& , cyIntegral& , cxIdeal& , lParam& ,\
cxHeader& , handle& , bandcount%
declare inum% , a#
Dim a# , 16
clear a#
Long a#,0 = 8
Long a#,4 = $FFFF'---Alles initialisieren
External("comctl32.dll","InitCommonControlsEx",a#)
Dispose a#
{Labels}:

subproc Create.cText

    parameters pWnd& , text$ , x% , y% , dx% , dy%
    inc inum%
    return Control("STATIC",text$,$54000001,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance)

endproc

subproc Create.rText

    parameters pWnd& , text$ , x% , y% , dx% , dy%
    inc inum%
    return Control("STATIC",text$,$54000002,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance)

endproc

'}Ende Labels
'{Trackbar}:

subproc Create.TrackBar

    parameters pWnd& , options$ , x% , y% , dx% , dy%
    declare htb& , stil&
    inc inum%
    stil& = $54010040
    options$ = Upper$(options$)
    case InStr("SEL" ,options$) : add stil& , 20
    case InStr("BOTH",options$) : add stil& , 8
    htb& = Control("msctls_trackbar32","",stil&,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance,$00000)
    SetTrackRange htb& , val(SubStr$(options$,2,;)) , val(SubStr$(options$,3,;))
    SetTrackPos htb& , val(SubStr$(options$,1,;))
    return htb&

endproc

proc SetTrackPos

    parameters h& , pos%
    SendMessage(h&,$0405,1,pos%)

endproc

proc GetTrackPos

    parameters h&
    return SendMessage(h&,$0400,0,0)

endproc

proc SetTrackRange

    parameters h& , anf% , end%
    SendMessage(h&,$0406,1,MakeLong(anf%,end%))

endproc

'}Ende TrackBar
'{Progressbar}:

subproc Create.ProgressBar

    if %pCount = 6

        parameters pWnd& , stil& , x% , y% , dx% , dy%
        declare hpb&
        stil& = stil& + $50000000

    else

        parameters pWnd& , frame% , smooth% , x% , y% , dx% , dy%
        declare hpb& , stil&
        stil& = $50000000 + if(smooth%,1,0) + if(frame%,$800000,0)

    endif

    inc inum%
    hpb& = Control(msctls_progress32,,stil&,x%,y%,dx%,dy%,pWnd&,inum%,%hInstance)
    return hpb&

endproc

proc SetProgPos

    parameters h& , pos%
    return Sendmessage(h&,$402,pos%,0)

endproc

'}Ende ProgressBar
'{ReBarGrip}:

subproc Create.ReBar

    parameters rebar# , pWnd& , x% , y% , dx% , dy% , minx% , bx% , by% , cWnd& , fbgrip%
    declare rebar&

    if lower$(ClassOf(ReBar#)) = "rebar"

        inc inum%
        rebar&=Control("ReBarWindow32","",$50000804 ,x%,y%,dx%,dy%,pWnd&,inum%,0)

        With Rebar#

            .Size&       = SizeOf(ReBar#) - 6
            .Mask&       = $71'--RBBIM_STYLE | RBBIM_CHILD | RBBIM_CHILDSIZE | RBBIM_SIZE
            .cyMaxChild& = 1' ------------------Darf nicht Null sein
            .Style&      = if(fbgrip%,128,256)'--RBBS_NOGRIPPER (1. Band ohne Griff)
            .cxMinChild& = minx%'----------------Minimum Breite
            .cyMinChild& = by%'------------------Höhe des Bandes
            .cx&         = bx%'------------------Vorgabe Breite
            .hwndChild&  = cWnd&'----------------Band 1
            SendMessage(ReBar&,$0401,0,ReBar#)'--RB_INSERTBAND
            .handle&     = rebar&
            .bandcount%  = 1

        EndWith

        return 1

    else

        return 0

    endif

endproc

proc InsertReBarBand

    parameters ReBar# , minx% , bx% , by% , cWnd&

    if lower$(ClassOf(ReBar#)) = "rebar"

        With ReBar#

            .Style&      = 128'-----------------RBBS_GRIPPERALWAYS (folgende Bänder mit Griff)
            .cxMinChild& = minx%'---------------Minimum Breite
            .cyMinChild& = by%'-----------------Höhe des Bandes
            .cx&         = bx%'-----------------Vorgabe Breite
            .hwndChild&  = cWnd&'---------------Band 2
            SendMessage(.handle&,$0401,.bandcount%,ReBar#)'--RB_INSERTBAND
            .bandcount%  = .bandcount% + 1

        EndWith

        return 1

    else

        return 0

    endif

endproc

proc DestroyReBar

    parameters rebar#

    if lower$(ClassOf(rebar#)) = "rebar"

        DestroyWindow(rebar#.handle&)
        Dispose rebar#

    else

        return 0

    endif

endproc

'}Ende ReBarGrip
'----- Ende CONTROLS.INC --------------------------------------------------------------------------
declare band# , lb1& , lb2& , lb3&
Dim band# , ReBar
WindowTitle "Rebar-Demo von Nico Madysa"
Window 0 , 0 - 640 , 480
cls External("User32","GetSysColor",15)
ClearList
AddFonts
lb1& = Create("ListBox",%hWnd,0,0,0,0,0)
MoveListToHandle(lb1&)
lb2& = Create("ListBox",%hWnd,0,0,0,0,0)
MoveListToHandle(lb2&)
lb3& = Create("ListBox",%hWnd,0,0,0,0,0)
MoveListToHandle(lb3&)
Create("ReBar",band#,%hWnd,0,0,500,400,0,100,400,lb1&,1)
InsertReBarBand(band#,0,100,200,lb2&)
InsertReBarBand(band#,0,100,100,lb3&)

whilenot IsKey(27)

    waitinput

wend

DestroyReBar band#
Dispose band#
end