XProfan

English

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 volume#
Dispose volume#
end

07/16/07 ▲

Vollständiges Quote

Absatzweise Quote Zeilenweise Quote

« this Posting watts as Solution marked. »

Jörg
Sellmeyer

and too repariert. with difficulty ernährt itself the Eichhörnchen...
one ought to yet add, that the Rebarcontrol well on one Code Uwe "Pascal" Niemeyer basiert.

Compile Mark Separation

'Source watts on the 15.07.2007 from the MMJ-Quellcodesammlung (Dietmar horn) into Babyklappe on XProfan.com stored:
'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'---everything 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

'}end 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

'}end TrackBar
'{wallpaper.pcu of}:

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

'}end 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' ------------------must not zero his
            .Style&      = if(fbgrip%,128,256)'--RBBS_NOGRIPPER (1. volume without handle)
            .cxMinChild& = minx%'----------------minimum wide
            .cyMinChild& = by%'------------------Höhe the Bandes
            .cx&         = bx%'------------------default wide
            .hwndChild&  = cWnd&'----------------volume 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 (following bands with handle)
            .cxMinChild& = minx%'---------------minimum wide
            .cyMinChild& = by%'-----------------Höhe the Bandes
            .cx&         = bx%'-----------------default wide
            .hwndChild&  = cWnd&'---------------volume 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

'}end ReBarGrip
'----- end CONTROLS.INC --------------------------------------------------------------------------
declare volume# , lb1& , lb2& , lb3&
Dim volume# , ReBar
Window Title "Rebar-demonstration of 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",volume#,%hWnd,0,0,500,400,0,100,400,lb1&,1)
InsertReBarBand(volume#,0,100,200,lb2&)
InsertReBarBand(volume#,0,100,100,lb3&)

whilenot IsKey(27)

    waitinput

wend

DestroyReBar volume#
Dispose volume#
end