Ja es geht, einen Dateicommander in 4k zu quetschen! Aussehen und Komfort sind zwar etwas auf der Strecke geblieben, aber alle wesentlichen Funktionen sind drin (und funktionieren hoffentlich auch).
[Blockierte Grafik: http://s8.postimage.org/tunagdjdd/Screen_08_03_2013_14_Uhr_44_34_Sek.jpg]
Code
' 4k-Wettbewerb @Volkmar 2013
Declare Int L1,L2,T1,T2,S1,S2,LW,BA,BL,BK,BV,BU,BN,GF
WindowStyle 543
WindowTitle "4k-Commander"
Window (%MaxX \ 3)*2,(%MaxY \ 2)
UseIcon "DOS"
SetDialogFont External("gdi32.dll","GetStockObject",17)
Set("FileMode",0)
UserMessages $10
T1=CRT()
T2=CRT()
L1=CRL()
L2=CRL()
BA=CRB("Ausführen")
BL=CRB("Löschen")
BK=CRB("Kopieren")
BV=CRB("Verschieben")
BU=CRB("Umbenennen")
BN=CRB("Neuer Ordner")
S1=CRT()
S2=CRT()
SetFont BA,0
RSZ Width(%HWnd),Height(%HWnd)
Upd T1,L1,GetDir$("@")
Upd T2,L2,GetDir$("@")
While 1
If GetFocus(L1)
GF=L1
SetCurSel L2,-1
SetText S2,""
Sta L1,S1,T1
EndIf
If GetFocus(L2)
GF=L2
SetCurSel L1,-1
SetText S1,""
Sta L2,S2,T2
EndIf
WaitInput
Case %UMessage=$10:Break
If %Key=4
RSZ Width(%HWnd),Height(%HWnd)
ElseIf %Key=3
RCmd %GetFocus
ElseIf Clicked(BA)
RCmd GF
ElseIf Clicked(BL)
Cmd 1,GF
ElseIf Clicked(BK)
Cmd 2,GF
ElseIf Clicked(BV)
Cmd 3,GF
ElseIf Clicked(BU)
Cmd 4,GF
ElseIf Clicked(BN)
Cmd 5,GF
EndIf
EndWhile
Proc CRB
Return Create("Button",%HWnd,$(1), 0,0,0,0)
EndProc
Proc CRT
Return Create("Text",%HWnd,"",0,0,0,0)
EndProc
Proc CRL
Return Create("ListBox",%HWnd,1,0,0,0,0)
EndProc
Proc Cmd
Parameters Int M,L
Declare String P,D,To,Z, Int DF,T,EL,ET
CaseNot L:Return
If L=L1
T=T1
EL=L2
ET=T2
Else
T=T2
EL=L1
ET=T1
EndIf
P=GetText$(T)
To=GetText$(ET)
D=GetString$(L,GetCurSel(L))
If Instr("[',D)
DF=1
D=EK(D)
EndIf
Z=P+'\'+D
Case D='..':Return
Case D='.':Return
To=To+'\'+D
Assign #1,Z
If M=1
If MessageBox(Z,'Datei Löschen?',36)=6
If DF
RMDir Z
Else
Erase #1
EndIf
EndIf
ElseIf M=2
Case EQT(Z,To,'Kopieren'):Copy Z>To
ElseIf M=3
If EQT(Z,To,'Verschieben')
Copy Z>To
If %IOResult
NoAct
Else
Erase #1
EndIf
EndIf
ElseIf M=4
To=Input$('Geben Sie den neuen Dateinamen ein','Umbenennen','')
If To <> ''
DF=0
To=P+'\'+To
Case EQT(Z,To,'Umbenennen'):ReName #1,To
EndIf
ElseIf M=5
To=Input$('Geben Sie den neuen Ordnernamen ein','Neuer Ordner','')
If To<>''
MkDir P+'\'+To
EndIf
EndIf
If %IOResult
NoAct
Else
Upd T,L,P
Upd ET,EL,GetText$(ET)
EndIf
EndProc
Proc NoAct
MessageBox('Aktion wurde nicht ausgeführt','Fehler',16)
EndProc
Proc EK
Return Translate$(Translate$($(1),']",""),"[','')
EndProc
Proc EQT
Var Int R=1
If Upper$($(1))=Upper$($(2))
MessageBox('Quelle und Ziel sind gleich',$(3),16)
R=0
ElseIf DF
FindFirst$(''!'')
R=0
EndIf
Return R
EndProc
Proc RCmd
Declare String R,P, Int L,T
If %(1)=L1
L=L1
T=T1
Else
L=L2
T=T2
EndIf
R=GetString$(L,GetCurSel(L))
P=GetText$(T)
If Instr('[',R)
R=EK(R)
If R='.'
ElseIf R='\'
R=Left$(P,2)
ElseIf Instr('-',R)
R=Mid$(R,2,1)+':'
Else
If R='..'
If Len(P)>2
R=SubStr$(P,-1,'\')
R=Left$(P,Len(P)-(Len(R)+1))
Else
R=P
EndIf
Else
R=P+'\'+R
EndIf
EndIf
Upd T,L,R
ElseIf R<>''
ShellExec(P+'\'+R,'open',1)
EndIf
EndProc
Proc RSZ
Parameters Int W,H
Case W=0:Return
Var Int R=W \ 2
Var Int B=H-30
SWP T1,0,2,R-2,20
SWP T2,R+2,2,R-2,20
SWP L1,0,24,R-2,H-82
SWP L2,R+2,24,R-2,H-82
SWP S1,0,B-20,R-2,18
SWP S2,R+2,B-20,R-2,18
SWP BA,2,B,100,22
SWP BL,102,B,100,22
SWP BK,202,B,100,22
SWP BV,302,B,100,22
SWP BU,402,B,100,22
SWP BN,502,B,100,22
EndProc
Proc SWP
SetWindowPos %(1)=%(2),%(3)-%(4),%(5)
EndProc
Proc Upd
Parameters Int T,L, String P
SetText T,P
ClearList L
P=P+'\*.*'
SendMessage(L,$18D,$C03F,Addr(P))
If Len(GetText$(T))>2
P='[..]"
Case SendMessage(L,$18F,-1,Addr(P))=-1:AddString(L,P)
AddString(L,"[\]")
EndIf
EndProc
Proc Sta
Parameters Int L,S,E
Declare String FA,D
D=GetString$(L,GetCurSel(L))
If D=""
SetText S,D
Else
Case Instr("[',D):Return
D=GetText$(E)+'\'+D
Var Int A=GetFAttr(D)
Case TestBit(A,0):FA=FA+'R'
Case TestBit(A,1):FA=FA+'H'
Case TestBit(A,2):FA=FA+'S'
Case TestBit(A,5):FA=FA+'A'
SetText S,D+' '+Str$(FileSize(D))+' Bytes ['+FA+']"
EndIf
EndProc
Alles anzeigen
Gruß Volkmar