XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Laufwerke: Laufwerks-Combobox mit Icons und Abfrage
Dirbox mit Icons und Abfrage Dieter Zornow
Falls ein Laufwerk angewählt wird das nicht ansprechbar ist wird das letzte LW wieder angewählt
getestet mit Xprofan, Win ME, 9xx, XP
Code ist frei, ohne Gewähr
DEF LoadIcon(2) ! USER32,LoadIconA
DEF ImageList_Create(5)  ! COMCTL32,ImageList_Create
DEF ImageList_AddIcon(2) ! COMCTL32,ImageList_AddIcon
DEF ImageList_Destroy(1) ! COMCTL32,ImageList_Destroy
DEF ImageList_GetImageCount(1)! COMCTL32,ImageList_GetImageCount
Def InitCommonControlsEx(1) !COMCTL32,InitCommonControlsEx
Def GetDriveType(1) ! KERNEL32.DLL,GetDriveTypeA
Def GetVolumeInformation(8) !KERNEL32,GetVolumeInformationA
Declare cb&,cbtext#,cbline&,cb#,cbID&,lwcount%,oldline&,olddrive$
Declare Imagelist&,Iconname#,iconhdll&,lwb$
Declare ResInst&
ResInst& = Usedll(Iconres.dll)
case resInst& < 32:Messagebox(Dll nicht gefunden,Fehler,64)
dim cbtext#,260
dim cb#,36
dim$ 26

Proc LabelOneLW

    parameters lw$
    Case len(LW$) > 3:Return

    If len(lw$) = 1

        lw$ = Lw$+:

    elseif len(lw$) = 2

        lw$ = Lw$+

    endif

    Declare is&,label#,text$,root#
    Dim label#,20
    Dim root#,4
    String root#,0=lw$
    is&=GetVolumeInformation(root#,label#,20,0,0,0,0,0)
    case is&:text$=String$(label#,0)
    Dispose label#
    Dispose root#
    text$ =  (+text$+)
    case text$=  ():text$ =  (--)
    Return text$

endproc

Proc CheckDrive

    Parameters lw$
    Declare result&,lw#

    If len(lw$) = 1

        lw$=lw$ + :)

    ELSEIF len(lw$) = 2

        lw$=lw$ + )

    ELSEIF len(lw$) > 3

        lw$ = left$(lw$,3)

    ENDIF

    Dim lw#,8
    String lw#,0=lw$
    Let result&=GetVolumeInformation(lw#,0,0,0,0,0,0,0)
    dispose lw#
    Return result&

EndProc

proc lwtype

    declare Drive#,type$,lw&
    Dim Drive#,4
    parameters lw$
    let lw$=trim$(lw$)

    If equ(len(lw$),1)

        let lw$=@add$(lw$,:)

    ELSEIF equ(len(lw$),2)

        let lw$=@add$(lw$,)

    ELSEIF gt(len(lw$),3)

        let lw$=left$(lw$,3)

    ENDIF

    String Drive#,0=lw$
    Let LW&=GetDriveType(Drive#)

    IF equ(LW&,0)

        type$=unknow Type

    ELSEIF equ(LW&,1)

        type$=not available

    ELSEIF equ(LW&,2)

        type$=Changable

    ELSEIF equ(LW&,3)

        type$=Harddrive

    ELSEIF equ(LW&,4)

        type$=Netdrive

    ELSEIF equ(LW&,5)

        type$=CD-Rom

    ELSEIF equ(LW&,6)

        type$=RAM-Drive

    ENDIF

    dispose Drive#
    Return type$

endproc

proc DZLWcount

    Declare V#,tbox&
    tBOX& = CREATE(SORTEDLISTBOX,%HWND,,0,0,0,0)
    Dim V#,4
    clear v#
    String V#,0 =
    Sendmessage(tbox&,$018D,$4000,V#)
    lwcount% = getcount(tbox&)

    whileloop 0,25

        List$ &loop = mid$(getstring$(tbox&,&loop),3,1)+:

    endwhile

    Dispose V#
    @DestroyWindow(tbox&)

endproc

proc InitLwBox

    parameters X%,Y%,hndl&
    Declare CStruct#
    Dim CStruct#,8
    Long CStruct#,0=8
    Long CStruct#,4= 512
    InitCommonControlsEx(CStruct#)
    Dispose CStruct#
    Let cb&=Control(ComboBoxEx32,,$50010007,x%,y%,210,170,hndl&,110,%hinstance,0)
    Let Imagelist&=ImageList_Create(16,16,$0001,3,3)
    cbID& = sendmessage(cb&,$0406,0,0)

endproc

proc addIcon

    parameters Iconname$,handle&
    Declare counter&
    dim Iconname#,len(Iconname$)+1
    String Iconname#,0=Iconname$
    Let iconhdll&=loadicon(handle&,Iconname#)
    ImageList_AddIcon(Imagelist&,iconhdll&)
    let counter&=ImageList_GetImageCount(Imagelist&)
    sendmessage(cb&,$0402,0,Imagelist&)
    Dispose Iconname#
    Return counter&

endproc

Proc AddText

    parameters text$,showIcon&
    string cbtext#,0=Text$
    long cb#,0=$000F
    long cb#,4=-1
    long cb#,8=cbtext#
    long cb#,12=260
    long cb#,16= showIcon&
    long cb#,20= showIcon&
    sendmessage(cb&,$0401,0,cb#)

endproc

Proc ShowLine

    parameters line&
    long cb#,4=line&
    sendmessage(cb&,$014E,line&,cb#)

endproc

proc onFocusCB

    let oldline&=word(cb#,4)
    let olddrive$=string$(cbtext#,0)
    long cb#,4=sendmessage(cb&,$0147,0,0)
    sendmessage(cb&,$0404,0,cb#)
    let lwb$= string$(cbtext#,0)
    let cbline&= word(cb#,4)
    checkdrive lwb$

    if equ(@&(0),1)

        chdir left$(lwb$,2)
        showline cbline&

    else

        let cbline&=oldline&
        let lwb$=olddrive$
        showline oldline&

    endif

endproc

proc LwBoxFill

    parameters x%,y%,Icon1$,Icon2$,Icon3$,Icon4$,hndl&,instance&
    Declare run%,fill$,label$
    DZLWCOUNT
    InitLwBox x%,y%,hndl&
    addIcon Icon1$,instance&
    addIcon Icon2$,instance&
    addIcon Icon3$,instance&
    addIcon Icon4$,instance&
    let run%=0

    whilenot equ(run%,lwcount%)

        LabelOneLW @List$(run%)
        label$ = @$(0)
        lwType @List$(run%)
        let fill$=Upper$(@List$(run%))+ +@$(0)+label$

        If Trim$(@$(0)) = unknow Type

            AddText fill$,3

        ELSEIf Trim$(@$(0)) = not available

            AddText fill$,3

        ELSEIf Trim$(@$(0)) = Changable

            AddText fill$,0

        ELSEIf Trim$(@$(0)) = Harddrive

            AddText fill$,1

        ELSEIf Trim$(@$(0)) = Netdrive

            AddText fill$,1

        ELSEIf Trim$(@$(0)) = CD-Rom

            AddText fill$,2

        ELSEIf Trim$(@$(0)) = Ram-Drive

            AddText fill$,2

        ENDIF

        inc run%

    endwhile

    chdir @GetDir$(@)
    chdir
    let run%=0

    whilenot run% = lwcount%

        long cb#,4=sendmessage(cb&,$014E,run%,0)
        sendmessage(cb&,$0404,0,cb#)
        let lwb$= string$(cbtext#,0)
        let cbline&= word(cb#,4)
        case Upper$(left$(lwb$,1)) = Upper$(left$(@GetDir$(@),1)):Break
        inc run%

    endwhile

    ShowLine cbline&

endproc

proc DeInitC

    dispose cb#
    dispose cbtext#
    ImageList_Destroy(Imagelist&)

endproc

Def GetSysColor(1) !USER32,GetSysColor
SETTRUECOLOR 1
DECLARE ENDE%,BUTTON&
WINDOWSTYLE 63
WINDOWTITLE Dirbox
WINDOW 22,20-640,500
CLS GETSYSCOLOR(15)
USEFONT MS Sans Serif,13,0,0,0,0
SETDIALOGFONT 1
usermessages 16
BUTTON& = CREATE(BUTTON,%HWND,Ende,0487,0404,0070,0030)
------------------------------------------------- Aufruf
Parameters X-pos,y-pos,icon1,icon2,icon3,icon4,Fenster-Handle,instance-Handle(= Iconresource)
im Falle der eigenen Exe = %hinstance das instance-Handle

If ResInst& <= 31

    ResInst& = %hinstance
    LwBoxFill 10,40,A,STEIN,MUENZE,PROFAN,%Hwnd,ResInst&

else

    LwBoxFill 10,40,CHLW,LW,CD,SORRY,%Hwnd,ResInst&

endif

-------------------------------------------------

WHILENOT ENDE%

    getmessage

    If %UMessage = 16

        LET ENDE%= 1

    ELSEIF getfocus(cbID&) Abfrage der Combobox und Wechsel auf das Laufwerk

        if equ(%lastmessage,514)

            onFocusCB

        endif

    ELSEIF GETFOCUS(BUTTON&)

        LET ENDE%= 1