XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
System: Laufwerke ermitteln
Def FileExists(1) If(Len(FindFirst$($(1))),1,Equ(%IOResult,0)) 1=exists, 0=missing aus prfellow
Def GetDrives(2) !KERNEL32,GetLogicalDriveStringsA
Def GetDriveType(1) ! KERNEL32.DLL,GetDriveTypeA
Def GetVolumeInformation(8) !KERNEL32,GetVolumeInformationA
Def SetCurrentDirectory(1) !KERNEL32,SetCurrentDirectoryA
declare dirbuf#,anzlw% Globale Declaration
declare lwa$[26,26]

Proc CheckDrive

    Parameters drive$
    Declare result&,dw1&,dw2&
    Dim dirbuf#,8
    String dirbuf#,0=drive$
    Let result&=GetVolumeInformation(dirbuf#,0,0,0,Addr(dw1&),Addr(dw2&),0,0)
    dispose dirbuf#
    case equ(result&,0):messagebox(Drive not ready,Access Error,16)
    Return result&

EndProc

proc onfocusLW

    Declare LW$,Type$
    Parameters Globalhandle&,what% 0 = Lw, 1= type
    let lw$=@GetText$(Globalhandle&)

    If neq$(lw$,)

        let Type$= Trim$(mid$(lw$,6,sub(len(lw$),6)))
        let lw$=Trim$(left$(lw$,3))

    endif

    case equ(what%,0):Return lw$
    case equ(what%,1):Return type$

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) or lt(len(lw$),1)

        let type$=falsche Eingabe
        return type$

    ENDIF

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

    IF equ(LW&,0)

        type$=unbekannter Typ

    ELSEIF equ(LW&,1)

        type$=nicht vorhanden

    ELSEIF equ(LW&,2)

        type$=W-Medium

    ELSEIF equ(LW&,3)

        type$=Festplatte

    ELSEIF equ(LW&,4)

        type$=Netzlaufwerk

    ELSEIF equ(LW&,5)

        type$=CD-Laufwerk

    ELSEIF equ(LW&,6)

        type$=RAM-Laufwerk

    ENDIF

    dispose Drive#
    Return type$

endproc

Proc progSearch

    Declare search%,try$
    parameters file$
    let File$=Upper$(file$)
    case Equ$(mid$(file$,2,1),:):let file$=mid$(file$,4,sub(len(file$),3))
    case Equ$(mid$(file$,1,1),):let file$=mid$(file$,2,sub(len(file$),1))
    let search%=anzlw%

    whilenot equ(search%,0)

        let try$=lwa$[search%]
        let try$=add$(try$,file$)
        case FileExists(try$):break
        dec search%

    endwhile

    if FileExists(try$)

        return try$

    else

        @messagebox(Konnte die gesuchte Datei nicht finden,Suchergebnis,64)

    endif

endproc

proc DZLWcount

    declare a#,lwa%
    dim a#,80
    let anzlw%=0
    let lwa%=0
    GetDrives(80,a#)

    while 1

        let lwa$[anzlw%]=string$(a#,lwa%)
        add lwa%,4
        casenot len(lwa$[anzlw%]):break
        inc anzlw%

    endwhile

    dispose a#

endproc

Proc CreateLWChoice

    Declare Handle&,fill%,fenster&,s#,num%
    Parameters X1%,X2%,yes%,lw$
    dim s#,4
    string s#,0=lw$
    let fenster&=@GetActiveWindow()
    let handle&=@CreateChoiceBox(fenster&,,X1%,X2%,130,250)
    DZLWcount
    let fill%=0

    whilenot equ(fill%,anzlw%)

        lwtype lwa$[fill%]
        let lwa$[fill%]=lwa$[fill%]+ [+@$(0)+]
        inc fill%

    endwhile

    clearlist
    let fill%=0

    whilenot equ(fill%,anzlw%)

        addstring lwa$[fill%]
        inc fill%

    endwhile

    @MoveListToChoice(handle&)
    Clearlist
    let num%=@sendmessage(handle&,$014D,-1,s#)

    If equ(num%,-1)

        let lw$=left$(@GetDir$(@),1)
        clear s#
        string s#,0=lw$
        let num%=@sendmessage(handle&,$014D,-1,s#)

    endif

    IF equ(yes%,1)

        @sendmessage(handle&,$014E,num%,-1)

    else

        @sendmessage(handle&,$014E,-1,-1)

    endif

    let yes%=0
    Dispose s#
    return handle&

endproc

Beispiel Laufwerksbox erzeugen mit Typ des LW und Abfrage
Parameter x,y Koordinaten,Eintrag vorwählen 1=ja,gewünschtes Laufwerk
cls
Declare Globalhandle&
CreateLWChoice 10,10,1,@getdir$(@)
let Globalhandle&=@&(0)
onfocusLW Globalhandle&,0
locate 18,0
print Laufwerk:,@$(0)
onfocusLW Globalhandle&,1
Locate 20,0
Print Laufwerkstyp:,@$(0)
Checkdrive left$(@getdir$(@),3)
Locate 22,0
Print Laufwerk ist,@$(0),//1 = ready ,2 = not ready//
waitkey
-----------------------------------------------------
Beispiel Programm suchen der Pfad muss vorhanden sein, das richtige Laufwerk wird eingetragen
cls
DZLWcount
progSearch Programmieren!MeineProgsBenutzerHLFPfad.inc
print @$(0)
waitkey
-------------------------------------------------------
Beispiel Laufwerke anzeigen
cls
Declare show%
let show%=0
dzlwcount

whilenot equ(show%,anzlw%)

    print lwa$[show%]
    inc show%

endwhile

pr