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
ENDIF
WEND
DeInitC Aufräumen
end