返回
{***************************************************************}
{*** FVision Unit Version1.0 ***}
{*** 蓝蚂蚁工作室 ***}
{***************************************************************}
{*** 对话框单元 ***}
{***************************************************************}
{$O+,F+,X+,I-,S-}
Unit FDialog;
Interface
Uses
Dos,FEvent,FMouse,FTool,Graph,FGraph,FWrite,FView,FList;
Const
mbNoButton = $0000;
mbOKOnly = $0001;
mbOKCancel = $0002;
mbAbortRetryIgnore = $0003;
mbYesNoCancel = $0004;
mbYesNo = $0005;
mbRetryCancel = $0006;
mbCritical = $0010;
mbQuestion = $0020;
mbExcalamation = $0040;
mbInformation = $0080;
mbChinese = $0000;
mbEnglish = $8000;
mrOK = $0001;
mrCancel = $0002;
mrYes = $0001;
mrNo = $0003;
mrAbort = $0004;
mrRetry = $0005;
mrIgnore = $0006;
ipPassWord = $0001;
ipSelect = $0002;
ipCantInput = $0004;
ipImmediate = $0008;
ipDigital = $0010;
ipBroad = $0020;
ipSaveBack = $0040;
dtInteger = $0001;
dtLongint = $0002;
Const
MaxDirSize = 1000;
Type
AttrStr=String[4];
DirPtr = ^DirRec;
DirRec = record
Attr: Byte;
Time: Longint;
Size: Longint;
Name: string[12];
end;
DirList = array[0..MaxDirSize - 1] of DirPtr;
PMsgDialog=^TMsgDialog;
TMsgDialog=object(TWindow)
Style:Word;
St:array[0..5] of String[60];
Cen:array[0..5] of Boolean;
Long,Hang:Integer;
Img:Pointer;
IconFlag:Boolean;
Constructor Init(T,S:String;Sty:Word);
Procedure Paint;Virtual;
end;
PMsgViewer=^TMsgViewer;
TMsgViewer=object(TMsgDialog)
Constructor Init(T,S:String);
end;
PDrvDialog=^TDrvDialog;
TDrvDialog=object(TWindow)
LastDrv:Integer;
CurDrv:Integer;
CDDrvExist:Boolean;
CDDrv:Integer;
Constructor Init(C:Char);
Procedure Paint;Virtual;
Procedure Draw;Virtual;
Procedure DrawRect;
Procedure HandleEvent(var Event:TEvent);Virtual;
end;
PInput=^TInput;
TInput=object(TView)
Style:Word;
UpRec,DownRec:TRect;
St:String;
Pst,Bak:Pointer;
TColor,DColor,LTColor,LDColor,MColor:Byte;
ActiveFlag,First,RangeFlag,SuccSetData:Boolean;
Len,Mark:Byte;
RangeName:string;
RangeMin,RangeMax:LongInt;
Lister:PLister;
BakSize:Word;
Constructor Init(X,Y:Integer;var S:string;L:Byte;Sty:Word);
Destructor Done;virtual;
Procedure DrawMark;
Procedure Draw;
Procedure Active;virtual;
Procedure SetStr(S:string);virtual;
Function GetStr:Pointer;
Procedure Paint;virtual;
Procedure MoveTo(x,y:Integer);virtual;
Procedure HandleEvent(var Event:TEvent);virtual;
Procedure SetRange(Name:string;Min,Max:LongInt);
Procedure SetLister(ALister:PLister);
Procedure SetData;virtual;
Procedure Run(var Event:TEvent);virtual;
end;
PDigInput=^TDigInput;
TDigInput=Object(TInput)
DigStr:string;
PInt:Pointer;
DataType:Word;
Constructor Init(X,Y:Integer;P:Pointer;L:Byte;Sty:Word;DT:Word);
Procedure SetStr(S:string);virtual;
Procedure SetData;virtual;
end;
PFileList=^TFileList;
TFileList=Object(TView)
ScrollBar:TScrollBar;
MesWin:TRect;
Mark:TPoint;
Dir:DirList;
Path,TempPath:String;
MPath,NPath:PathStr;
D: DirStr;
N: NameStr;
E: ExtStr;
Count:Integer;
TSize:LongInt;
Pos:Integer;
Constructor Init(X,Y:Integer;var P:String);
Destructor Done;Virtual;
Procedure MoveTo(X,Y:Integer);Virtual;
Procedure Paint;Virtual;
Procedure Active;Virtual;
Procedure Draw;
Procedure DrawMessage;
Procedure DrawMark;
Procedure ReScroll;
Procedure SearchDir;
Procedure FreeDirMem;
Procedure MoveMark(X,Y:Integer);
Procedure HandleEvent(var Event:TEvent);Virtual;
end;
PFileDialog=^TFileDialog;
TFileDialog=object(TWindow)
InputLine:PInput;
FileList:PFileList;
TempPath:String;
Constructor Init(p:String;t:string30);
Procedure HandleEvent(var Event:TEvent);Virtual;
end;
{
PDirEntry = ^TDirEntry;
TDirEntry = record
DisplayText: PString;
Directory: PString;
end;
PDirListBox = ^TDirListBox;
TDirListBox = object(TLister)
Dir: DirStr;
Cur: Word;
constructor Init(x,y:Integer);
procedure HandleEvent(var Event: TEvent); virtual;
procedure NewDirectory(var ADir: DirStr);
end;
}
Const
MsgView: PMsgViewer= nil;
Function ShowMsg(T,S:string):PMsgViewer;
Procedure HideMsg(var P:PMsgViewer);
Function MsgBox(Title,Msg:string;mbType:Word):Word;
Implementation
Const
FileListColor = $7F;
Const
MaxHang = 10;
MonthStr: array[1..12] of string[3] = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
Type
LessFunc = Function(X, Y: DirPtr): Boolean;
var
Less : LessFunc;
{$F+}
Function LessName(X, Y: DirPtr): Boolean;
begin
LessName := X^.Name < Y^.Name;
end;
Function LessNameDown(X, Y: DirPtr): Boolean;
begin
LessNameDown := X^.Name > Y^.Name;
end;
Function PathExist(P:PathStr):Boolean;
var
FileInfo:SearchRec;
Attr: Word;
F: File;
D: DirStr;
N: NameStr;
E: ExtStr;
begin
PathExist:=False;
P := FExpand(P);
if P[Length(P)] <> '\' then
begin
Assign(F, P);
GetFAttr(F, Attr);
if (DosError = 0) and (Attr and Directory <> 0) then
P := P + '\';
end;
FSplit(P, D, N, E);
if N='' then N:='*';
if E='' then E:='.*';
assign(F,D);
getfattr(F,Attr);
if (DosError = 0) and (Attr and Directory <> 0) then
PathExist:=True;
FindFirst(D+'*.*', AnyFile , FileInfo);
if (DosError = 0) then
if (System.Pos('?',N)<>0)or(System.Pos('?',E)<>0)or(N='*')or(E='*') then
PathExist:=True;
end;
{------------tmsgdialog object-------------}
Constructor TMsgDialog.Init;
var
i:Integer;
begin
Style:=Sty;
IconFlag:=(Style and $00F0)<>0;
if IconFlag then
case (Style and $00F0) of
mbCritical:Img:=@IcCritical;
mbQuestion:Img:=@IcQuestion;
mbExcalamation:Img:=@IcExcalamation;
mbInformation:Img:=@IcInformation;
end;
Hang:=0;
St[Hang]:='';
Cen[Hang]:=False;
Long:=100;
for i:=1 to Length(S) do
if S[i]=#3 then
Cen[Hang]:=True
else
if S[i]<>#13 then
St[Hang]:=St[Hang]+S[i]
else
begin
Inc(Hang);
St[Hang]:='';
Cen[Hang]:=False;
end;
for i:=0 to Hang do
if Long<Length(St[i])*8 then
Long:=Length(St[i])*8;
Size.x:=Long+60;
Size.y:=100+Hang*20;
if IconFlag then Inc(Size.x,30);
if (Style and $000F)=mbNoButton then Dec(Size.y,20);
if Size.x<200 then Size.x:=200;
Origin.x:=0;
Origin.y:=0;
AssignRect(Broad,0,0,Size.x,Size.y);
Inherited Init(Broad,T,True);
case (Style and $000F) of
mbOKOnly:Insert(New(PButton,Init(Size.X div 2-25,Size.Y-40,
Size.X div 2+25,Size.Y-19,'确定',kbEnter,cmOk)));
mbOkCancel:begin
Insert(New(PButton,Init(Size.X div 2-70,Size.Y-40,
Size.X div 2-10,Size.Y-19,'确定~O~',kbAltO,cmOk)));
Insert(New(PButton,Init(Size.X div 2+10,Size.Y-40,
Size.X div 2+70,Size.Y-19,'取消~C~',kbAltC,cmCancel)));
end;
mbYesNo:begin
Insert(New(PButton,Init(Size.X div 2-60,Size.Y-40,
Size.X div 2-10,Size.Y-19,'是~Y~',kbAltY,cmYes)));
Insert(New(PButton,Init(Size.X div 2+10,Size.Y-40,
Size.X div 2+60,Size.Y-19,'否~N~',kbAltN,cmNo)));
end;
mbRetryCancel:begin
Insert(New(PButton,Init(Size.X div 2-70,Size.Y-40,
Size.X div 2-10,Size.Y-19,'重试~R~',kbAltC,cmRetry)));
Insert(New(PButton,Init(Size.X div 2+10,Size.Y-40,
Size.X div 2+70,Size.Y-19,'取消~C~',kbAltC,cmCancel)));
end;
end;
Next;
Center;
end;
Procedure TMsgDialog.Paint;
var
i,x:Integer;
begin
Inherited Paint;
HideMouse;
if IconFlag then
PutImage(Broad.a.x+15,Broad.a.y+35,Img^,COPYPUT);
if IconFlag then x:=30 else x:=0;
for i:=0 to Hang do
if Cen[i] then
Writecs(Broad.a.x+x+(Size.x-x) div 2-Length(St[i])*4,Broad.a.y+35+i*20,St[i],0)
else
Writecs(Broad.a.x+x+30,Broad.a.y+35+i*20,St[i],0);
ShowMouse;
end;
{-----------end tmsgdialog object----------}
Function MsgBox(Title,Msg:string;mbType:Word):Word;
var
Dlg:PMsgDialog;
Event:TEvent;
begin
Dlg:=New(PMsgDialog,Init(Title,Msg,mbType));
Dlg^.Owner:=nil;
Dlg^.Paint;
Dlg^.Run(Event);
Dispose(Dlg,Done);
case Event.Command of
cmOK :MsgBox:=mrOK;
cmCancel :MsgBox:=mrCancel;
cmYes :MsgBox:=mrYes;
cmNo :MsgBox:=mrNo;
cmRetry :MsgBox:=mrRetry;
cmAbort :MsgBox:=mrAbort;
cmIgnore :MsgBox:=mrIgnore;
end;
end;
{-----------------------------------}
constructor TMsgViewer.Init;
begin
TMsgDialog.Init(T,S,mbNoButton);
end;
function ShowMsg(T,S:string):PMsgViewer;
begin
ShowMsg:=New(PMsgViewer,Init(T,S));
ShowMsg^.Paint;
end;
procedure HideMsg(var P:PMsgViewer);
begin
if P<>nil then
begin
HideMouse;
Dispose(P,Done);
ShowMouse;
P:=nil;
end;
end;
{-----------------------------------}
Constructor TDrvDialog.Init;
var
R:TRect;
i:Char;
Temp,TempDrv:Word;
begin
LastDrv:=1;
CurDrv:=Ord(Upcase(C))-Ord('A');
asm MOV AX,1500H
MOV BX,0
INT 2FH
MOV Temp,BX
MOV TempDrv,CX
end;
CDDrvExist:=Temp<>0;
CDDrv:=TempDrv;
if CDDrvExist then
LastDrv:=CDDrv
else
for i:='C' to 'H' do
if exist_fi(i+':\*.*') then LastDrv:=Ord(i)-Ord('A');
if (CurDrv<0) or (CurDrv>LastDrv) then
CurDrv:=LastDrv;
AssignRect(R,0,0,30*LastDrv+55,75);
Inherited Init(R,'选择驱动器',True);
Center;
end;
Procedure TDrvDialog.Paint;
begin
Inherited Paint;
Draw;
end;
Procedure TDrvDialog.Draw;
Procedure DrawDrv(x,y:Integer;Index:Integer);
begin
Putpixel(0,0,0);
SetColor(0);
if Index<2 then
begin
Rectangle(x,y+6,x+21,y+7);
Rectangle(x+7,y+5,x+14,y+8);
Rectangle(x+17,y+10,x+18,y+11);
end else
if (not CDDrvExist) or (Index<>CDDrv) then
begin
Rectangle(x,y+5,x+21,y+5);
Rectangle(x,y+8,x+21,y+8);
Rectangle(x+10,y+1,x+11,y+12);
Rectangle(x+1,y+10,x+2,y+11);
end else
begin
Rectangle(x,y+3,x+21,y+11);
Rectangle(x+2,y+5,x+19,y+6);
Rectangle(x+4,y+8,x+8,y+9);
Rectangle(x+14,y+8,x+15,y+9);
Rectangle(x+18,y+8,x+19,y+9);
end;
Writecs(x+5,y+16,Chr(Ord('A')+Index),4);
end;
var
i:Integer;
begin
HideMouse;
for i:=0 to LastDrv do
DrawDrv(Broad.a.x+15+i*30,Broad.a.y+35,i);
DrawRect;
ShowMouse;
end;
Procedure TDrvDialog.DrawRect;
begin
HideMouse;
SetWriteMode(1);
SetColor(10);
PutPixel(0,0,0);
Rectangle(Broad.a.x+14+CurDrv*30,Broad.a.y+34,
Broad.a.x+37+CurDrv*30,Broad.a.y+49);
SetWriteMode(0);
ShowMouse;
end;
Procedure TDrvDialog.HandleEvent;
var
R:TRect;
Temp:Integer;
begin
Inherited HandleEvent(Event);
AssignRect(R,Broad.a.x+14,Broad.a.y+35,Broad.a.x+40+LastDrv*30,Broad.a.y+50);
case event.what of
evkeydown:case event.keycode of
kbLeft:if CurDrv>0 then
begin
DrawRect;
Dec(CurDrv);
DrawRect;
end;
kbRight:if CurDrv<LastDrv then
begin
DrawRect;
Inc(CurDrv);
DrawRect;
end;
kbEnter:begin
Event.What:=evCommand;
Event.Command:=cmOk;
Event.InfoChar:=Chr(Ord('A')+CurDrv);
Exit;
end;
else Exit;
end;
evMouseDown,evMouseMove:
if (Event.Buttons=mbLeftButton) and
isin(Event.Where,R) then
begin
Temp:=(Event.Where.x-Broad.a.x+15) div 30 -1;
if (Temp>=0) and (Temp<=LastDrv) and (Temp<>CurDrv) then
begin
DrawRect;
CurDrv:=Temp;
DrawRect;
end;
end else Exit;
evMouseUp:if (Event.Buttons=mbLeftButton) and
isin(Event.Where,R) then
begin
Event.What:=evCommand;
Event.Command:=cmOk;
Event.InfoChar:=Chr(Ord('A')+CurDrv);
Exit;
end else Exit;
else Exit;
end;
ClearEvent(Event);
end;
{------------TInput object-----------------}
Constructor TInput.Init;
begin
Inherited Init;
GrowMode:=gfGrowHiX;
Style:=Sty;
Pst:=@S; St:=S; Len:=L;
Size.X:=Len*8;
Size.Y:=15;
if (Style and (ipDigital+ipSelect))<>0 then Dec(Len,2);
MoveTo(X,Y);
TColor:=10; DColor:=0;
LTColor:=0; LDColor:=15;
MColor:=4;
Mark:=Length(St);
First:=True;
ActiveFlag:=False;
RangeFlag:=False;
Lister:=nil; Bak:=nil;
if (Style and ipSaveBack)<>0 then
begin
ActiveFlag:=True;
DColor:=1;
LDColor:=14;
end;
end;
Destructor TInput.Done;
begin
if ((Style and ipSaveBack)<>0)and(Bak<>nil) then
begin
HideMouse;
PutImage(Broad.A.X,Broad.A.Y,Bak^,CopyPut);
ShowMouse;
FreeMem(Bak,BakSize);
end;
Inherited Done;
end;
Procedure TInput.DrawMark;
begin
SetWriteMode(1);
Graph.SetColor(MColor);
SetLineStyle(0,0,1);
PutPixel(0,0,0);
HideMouse;
Line(Origin.X+Mark*8,Origin.Y+14,Origin.X+Mark*8+7,Origin.Y+14);
Line(Origin.X+Mark*8,Origin.Y+15,Origin.X+Mark*8+7,Origin.Y+15);
ShowMouse;
SetWriteMode(0);
end;
Procedure TInput.Draw;
var
TempStr:string;
begin
DrawMark;
HideMouse;
if First then
Full(Origin.X,Origin.Y,Origin.X+8*Len-1,Origin.Y+15,DColor);
TempStr:=St;
if (Style and ipPassWord)<>0 then
FillChar(TempStr[1],Length(St),'*');
Writecs(Origin.X,Origin.Y,TempStr,TColor);
DrawMark;
end;
Procedure TInput.Active;
begin
ActiveFlag:=not ActiveFlag;
Paint;
end;
Procedure TInput.SetStr;
begin
if RangeFlag and ((StrsInt(S)<RangeMin) or (StrsInt(S)>RangeMax)) then Exit;
St:=S;
Mark:=Length(St);
if (Style and ipImmediate)<>0 then string(Pst^):=St;
end;
Function TInput.GetStr;
begin
GetStr:=@St;
end;
Procedure TInput.Paint;
var
TempStr:string;
begin
HideMouse;
if ((Style and ipSaveBack)<>0)and(Bak=nil) then
Bak:=SaveImage(Broad.A.X,Broad.A.Y,Broad.B.X,Broad.B.Y,BakSize);
if (Style and ipBroad)<>0 then
DrawBroadC(Broad.a.x-2,Broad.a.y-2,Broad.b.x+2,Broad.b.y+2,0,DColor);
if (Style and ipSelect)<>0 then
begin
DrawBroad(UpRec.A.X,UpRec.A.Y,UpRec.B.X,UpRec.B.Y,1);
Writecs(UpRec.A.X+2,UpRec.A.Y,#25,0);
end else
if (Style and ipDigital)<>0 then
begin
DrawBroad(UpRec.A.X,UpRec.A.Y,UpRec.B.X,UpRec.B.Y,1);
DrawBroad(DownRec.A.X,DownRec.A.Y,DownRec.B.X,DownRec.B.Y,1);
SetColor(0);
OutTextXy(UpRec.A.X+4,UpRec.A.Y+1,#30);
OutTextXy(DownRec.A.X+4,DownRec.A.Y,#31);
end;
Full(Origin.X,Origin.Y,Origin.X+8*Len-1,Origin.Y+15,DColor);
if ActiveFlag and First then
begin
if Length(St)>0 then
Full(Origin.X,Origin.Y,Origin.X+8*Length(St)-1,Origin.Y+15,LDColor);
TempStr:=St;
if (Style and ipPassWord)<>0 then
FillChar(TempStr,Length(St),'*');
Writecs(Origin.x,Origin.y,TempStr,LTColor);
DrawMark;
end else
begin
Draw;
if ActiveFlag or First then DrawMark;
end;
end;
Procedure TInput.MoveTo;
begin
Inherited MoveTo(X,Y);
Len:=Size.X div 8;
Size.X:=Len*8;
Broad.B.X:=Broad.A.X+Size.X;
if (Style and (ipDigital+ipSelect))<>0 then Dec(Len,2);
if Length(St)>=Len then Byte(St[0]):=Len-1;
if Mark>=Len then Mark:=Len-1;
if (Style and ipSelect)<>0 then
AssignRect(UpRec,Broad.B.X-11,Broad.A.Y,Broad.B.X,Broad.B.Y)
else if (Style and ipDigital)<>0 then
begin
AssignRect(UpRec,Broad.B.X-15,Broad.A.Y,Broad.B.X,Broad.A.Y+7);
AssignRect(DownRec,Broad.B.X-15,Broad.A.Y+8,Broad.B.X,Broad.B.Y);
end;
end;
Procedure TInput.HandleEvent;
begin
case Event.What of
evCommand : case Event.Command of
cmSelect:begin
First:=True;
Paint;
end;
else Exit;
end;
evMouseDown,evMouseAuto:
if (Event.Buttons=mbLeftButton) and IsIn(Event.Where,Broad) then
begin
if Event.Double then
begin
First:=True;
Paint;
end else
if ((Style and ipSelect)<>0) and (Lister<>nil)
and IsIn(Event.Where,UpRec) then
begin
Lister^.Run(Event);
if (Event.What=evCommand)and(Event.Command=cmOk) then
begin
SetStr(Lister^.List^[Event.InfoInt]);
Paint;
end;
end else
if ((Style and ipDigital)<>0) and IsIn(Event.Where,UpRec) then
begin
First:=True;
SetStr(IntStr(StrsInt(St)+1));
Draw;
end else
if ((Style and ipDigital)<>0) and IsIn(Event.Where,DownRec) then
begin
First:=True;
SetStr(IntStr(StrsInt(St)-1));
Draw;
end;
end else
if (Style and ipSaveBack)<>0 then
begin
Event.What:=evCommand;
if Event.Buttons=mbRightButton then
Event.Command:=cmCancel
else
begin
Event.Command:=cmOk;
string(Pst^):=St;
end;
Event.InfoPtr:=@Self;
Exit;
end else Exit;
evKeyDown : {if not ActiveFlag then
Exit
else}
if Event.CMark and ((Style and ipCantInput)=0) then
begin
if First then
begin
DrawMark;
SetStr(Event.LoCode+Event.HiCode);
Draw;
First:=False;
end else
if Length(St)+2<Len then
begin
DrawMark;
Inc(Mark,2);
Insert(Event.loCode+Event.hiCode,St,Mark-1);
HideMouse;
Full(Origin.x+(Mark-2)*8,Origin.y,
Origin.x+Length(St)*8-9,Origin.y+15,dColor);
Draw;
DrawMark;
end;
end else
case Event.KeyCode of
kbLeft : if First then
begin
Draw;
First:=False;
end else
if Mark>0 then
begin
DrawMark;
Dec(Mark);
DrawMark;
end;
kbRight: if First then
begin
Draw;
First:=False;
end else
if Mark<Length(St) then
begin
DrawMark;
Inc(Mark);
DrawMark;
end;
kbUp:if (Style and ipDigital)<>0 then
begin
First:=True;
SetStr(IntStr(StrsInt(St)+1));
Draw;
end;
kbDown:if (Style and ipSelect)<>0 then
begin
Lister^.Run(Event);
if (Event.What=evCommand)and(Event.Command=cmOk) then
begin
SetStr(Lister^.List^[Event.InfoInt]);
Paint;
end;
end else
if (Style and ipDigital)<>0 then
begin
First:=True;
SetStr(IntStr(StrsInt(St)-1));
Draw;
end;
kbBack : if Mark>0 then
begin
DrawMark;
Delete(St,Mark,1);
Dec(Mark);
HideMouse;
if Mark=Length(St) then
Full(Origin.x+Mark*8,Origin.y,
Origin.x+Mark*8+7,Origin.y+15,DColor)
else
begin
Full(Origin.x+Mark*8,Origin.y,
Origin.x+Length(St)*8+7,Origin.y+15,DColor);
Draw;
end;
if First then
begin
SetStr('');
Paint;
end else
DrawMark;
First:=False;
end;
kbDel : if Mark<Length(St) then
begin
DrawMark;
Delete(St,Mark+1,1);
HideMouse;
if Mark=Length(St) then
Full(Origin.x+Mark*8,Origin.y,
Origin.x+Mark*8+7,Origin.y+15,DColor)
else
begin
Full(Origin.x+Mark*8,Origin.y,
Origin.x+Length(St)*8+7,Origin.y+15,dcolor);
Draw;
end;
DrawMark;
if First then
begin
Draw;
First:=False;
end;
end;
kbEnter: begin
Event.What:=evCommand;
Event.Command:=cmOk;
Event.InfoPtr:=@Self;
if (Style and ipDigital)=0 then
string(Pst^):=St;
DrawMark;
Draw;
if not First then DrawMark;
First:=False;
Exit;
end;
else
case Event.CharCode of
' '..#255 :if ((Style and ipCantInput)=0) or
(((Style and ipDigital)=0) or
(Event.CharCode in ['0'..'9','-','.'])) then
begin
if First then
begin
SetStr(Event.CharCode);
Draw;
First:=False;
end else
if Length(St)+1<Len then
begin
DrawMark;
Inc(Mark);
Insert(Event.CharCode,St,Mark);
HideMouse;
Full(Origin.x+(Mark-1)*8,Origin.y,
Origin.x+Length(St)*8-9,Origin.y+15,dColor);
Draw;
DrawMark;
end;
end;
else Exit;
end;
end;
else Exit;
end;
ClearEvent(Event);
end;
Procedure TInput.SetData;
var
Dialog:PMsgDialog;
begin
SuccSetData:=True;
if RangeFlag then
begin
if (StrsInt(St)>=RangeMin) and (StrsInt(St)<=RangeMax) then
string(Pst^):=St
else
begin
Dialog:=New(PMsgDialog,Init('范围错误',
RangeName+'的范围应在:'#13+
IntStr(RangeMin)+','+IntStr(RangeMax)+'之间!'
,mbOKOnly+mbInformation));
Dialog^.Owner:=Owner;
Dialog^.Paint;
Dialog^.Run(Event);
Dispose(Dialog,Done);
SuccSetData:=False;
end;
end else
string(Pst^):=St;
end;
Procedure TInput.SetRange;
begin
RangeFlag:=True;
RangeName:=Name;
RangeMin:=Min;
RangeMax:=Max;
end;
Procedure TInput.SetLister;
begin
Lister:=ALister;
Lister^.Owner:=@Self;
Lister^.Option:=Lister^.Option or opCantSelect;
end;
Procedure TInput.Run;
begin
repeat
ClearEvent(Event);
GetEvent(Event);
HandleEvent(Event);
if (Event.What=evKeyDown)and(Event.KeyCode=kbEsc) then
begin
Event.What:=evCommand;
Event.Command:=cmCancel;
end;
until (Event.What=evCommand)and
((Event.Command=cmOk)or(Event.Command=cmCancel));
end;
{------------TDigitalInput object-------------}
Constructor TDigInput.Init;
begin
DataType:=DT;
PInt:=P;
case DataType of
dtInteger:DigStr:=IntStr(Integer(PInt^));
dtLongint:DigStr:=IntStr(Longint(PInt^));
end;
Inherited Init(X,Y,DigStr,L,Sty);
end;
Procedure TDigInput.SetStr;
begin
Inherited SetStr(S);
if (Style and ipImmediate)<>0 then
case DataType of
dtInteger:Integer(PInt^):=StrsInt(St);
dtLongint:Longint(PInt^):=StrsInt(St);
end;
end;
Procedure TDigInput.SetData;
begin
Inherited SetData;
if SuccSetData then
case DataType of
dtInteger:Integer(PInt^):=StrsInt(St);
dtLongint:Longint(PInt^):=StrsInt(St);
end;
end;
{-----------TFileList Object-------------------}
Constructor TFileList.Init;
var
R:TRect;
begin
Inherited Init;
IsHot:=False;
Size.x:=30*8;
Size.y:=16*MaxHang;
Path:=P;
Count:=0;
SearchDir;
TempPath:=Path;
AssignRect(R,X,Y+Size.Y+6,240,17);
ScrollBar.Init(sbHor,R,0);
MoveTo(X,Y);
end;
Destructor TFileList.Done;
begin
FreeDirMem;
Inherited Done;
end;
Procedure TFileList.MoveTo;
begin
Origin.x:=X;
Origin.y:=Y;
AssignRect(Broad,x,y,x+Size.X,y+Size.Y);
AssignRect(MesWin,x,y+Size.Y+30,x+Size.X+10*8,y+Size.Y+30+31);
ScrollBar.MoveTo(X,Y+Size.Y+6);
end;
Procedure TFileList.Paint;
begin
HideMouse;
DrawBroad(Broad.a.x-2,Broad.a.y-2,Broad.b.x+2,Broad.b.y+2,0);
DrawBroadC(MesWin.a.x-2,MesWin.a.y-2,MesWin.b.x+2,MesWin.b.y+2,0,9);
SetColor(1);
Line(Broad.a.x+Size.x div 2-2,Broad.a.y,Broad.a.x+Size.x div 2-2,Broad.b.y);
Draw;
DrawMessage;
ScrollBar.Paint;
end;
Procedure TFileList.Draw;
var
i,j,k:Integer;
ExtPath:string[1];
Temp:string[14];
begin
HideMouse;
for j:=0 to 1 do
for i:=0 to MaxHang-1 do
if i+(Pos+j)*MaxHang<Count then
begin
if Dir[(Pos+j)*MaxHang+i]^.Attr and Directory<>0 then
ExtPath:='\' else ExtPath:='';
Temp:=Dir[(Pos+j)*MaxHang+i]^.Name+ExtPath;
InsSpace(Temp,13);
Temp:=' '+Temp;
Writec16(Broad.a.x div 8+j*15,Broad.a.y+i*16,Temp,FileListColor);
end else
Writec16(Broad.a.x div 8+j*15,Broad.a.y+i*16,' ',FileListColor);
if IsHot then DrawMark;
end;
Procedure TFileList.DrawMessage;
var
Str1,Str2:string[40];
T:DateTime;
TempHour:Byte;
begin
if Count=0 then Exit;
HideMouse;
Str1:=Copy(D+N+E,1,40);
InsSpace(Str1,40);
Str2:=Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Name;
InsSpace(Str2,13);
if (Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Attr and Directory)<>0 then
Str2:=Str2+'<DIR>'
else
Str2:=Str2+IntStr(Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Size);
InsSpace(Str2,23);
UnpackTime(Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Time, T);
TempHour:=T.Hour mod 12;
if TempHour=0 then TempHour:=12;
Str2:=Str2+Int_Str(T.Day,2)+'-'+MonthStr[T.Month]+'-'+Int_Str(T.Year mod 100,2)
+' '+IntStr(TempHour)+':'+Int_Str(T.Min,2);
if T.Hour>12 then
Str2:=Str2+'pm'
else
Str2:=Str2+'am';
InsSpace(Str2,40);
Writec16(MesWin.a.x div 8,MesWin.a.y,Str1,$9D);
Writec16(MesWin.a.x div 8,MesWin.a.y+16,Str2,$9B);
ShowMouse;
end;
Procedure TFileList.DrawMark;
var
i:Integer;
begin
HideMouse;
PutPixel(0,0,0);
SetWriteMode(1);
SetColor(1);
for i:=0 to 14 do
Line(Broad.a.x+Mark.x*8*15,Broad.a.y+Mark.y*16+i,
Broad.a.x+Mark.x*8*15+14*8-1,Broad.a.y+Mark.y*16+i);
SetWriteMode(0);
ShowMouse;
end;
Procedure TFileList.Active;
begin
IsHot:=not IsHot;
DrawMark;
end;
Procedure TFileList.ReScroll;
begin
if Count>1 then
ScrollBar.NewPos(((Pos+Mark.x)*MaxHang+Mark.y)/(Count-1))
else
ScrollBar.NewPos(0);
DrawMessage;
end;
Procedure TFileList.SearchDir;
Procedure QuickSort(L, R: Integer);
var
I, J: Integer;
X, Y: DirPtr;
begin
I := L;
J := R;
X := Dir[(L + R) div 2];
repeat
while Less(Dir[I], X) do Inc(I);
while Less(X, Dir[J]) do Dec(J);
if I <= J then
begin
Y := Dir[I];
Dir[I] := Dir[J];
Dir[J] := Y;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then QuickSort(L, J);
if I < R then QuickSort(I, R);
end;
Procedure GetCommand;
var
I: Integer;
Attr: Word;
F: File;
begin
@Less := nil;
Less := LessName;
Path := FExpand(Path);
if Path[Length(Path)] <> '\' then
begin
Assign(F, Path);
GetFAttr(F, Attr);
if (DosError = 0) and (Attr and Directory <> 0) then
Path := Path + '\';
end;
FSplit(Path, D, N, E);
if N = '' then N := '*';
if E = '' then E := '.*';
Path := D + N + E;
mPath:=D;
nPath:=D;
end;
Procedure FindFiles;
var
F: SearchRec;
begin
Count := 0;Tsize:=0;
FindFirst(Path, archive+hidden+readonly , F);
while (DosError = 0) and (Count < MaxDirSize) do
begin
if f.name<>'.' then
begin
GetMem(Dir[Count], Length(F.Name) + 10);
SysTem.Move(F.Attr, Dir[Count]^, Length(F.Name) + 10);
Inc(Count);Tsize:=Tsize+F.size;
end;
FindNext(F);
end;
end;
Procedure Finddirectorys;
var
F: SearchRec;temp:integer;
begin
temp:=count;
Less := LessNamedown;
FindFirst(mPath+'*.*', directory+hidden+readonly , F);
while (DosError = 0) and (Count < MaxDirSize) do
begin
if (f.name<>'.')and((f.attr and directory)<>0) then
begin
GetMem(Dir[Count], Length(F.Name) + 10);
SysTem.Move(F.Attr, Dir[Count]^, Length(F.Name) + 10);
Inc(Count);
end;
FindNext(F);
end;
if count-temp<>0 then quicksort(temp,count-1);
end;
Procedure SortFiles;
begin
if (Count <> 0) and (@Less <> nil) then
QuickSort(0, Count - 1);
end;
begin
FreeDirMem;
GetCommand;
FindFiles;
SortFiles;
FindDirectorys;
Pos:=0;
Mark.x:=0;
Mark.y:=0;
end;
Procedure TFileList.FreeDirMem;
var
i:integer;
begin
for i:=0 to Count-1 do
FreeMem(Dir[i],Length(Dir[i]^.Name)+10);
Count:=0;
end;
Procedure TFileList.MoveMark;
begin
if (Pos+X)*MaxHang+Y>=Count then Exit;
DrawMark;
Mark.x:=X;
Mark.y:=Y;
DrawMark;
ReScroll;
end;
Procedure TFileList.Handleevent;
var
TempX,TempY:Integer;
begin
ScrollBar.HandleEvent(Event);
case Event.What of
evMouseDown:if IsIn(Event.Where,Broad) then
begin
TempY:=((Event.Where.y-Broad.a.y) div 16) mod MaxHang;
TempX:=(Event.Where.x-Broad.a.x) div (Size.x div 2);
if TempX>1 then TempX:=1;
if not IsHot then
begin
if (Pos+TempX)*MaxHang+TempY<Count then
begin
Mark.x:=TempX;
Mark.y:=TempY;
ReScroll;
end;
ClearEvent(Event);
Exit;
end else
if (Pos+TempX)*MaxHang+TempY<Count then
begin
if (Mark.x=TempX) and (Mark.y=TempY) then
begin
if (Dir[(Pos+TempX)*MaxHang+TempY]^.Attr and Directory)<>0 then
begin
Path:=MPath+Dir[(Pos+TempX)*MaxHang+TempY]^.Name+'\'+N+E;
SearchDir;
Draw;
ReScroll;
end else
begin
Event.What:=evCommand;
Event.Command:=cmSelectFile;
NPath:=MPath+Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Name;
Event.Infoptr:=@NPath;
Exit;
end;
end else
MoveMark(TempX,TempY);
end;
end else Exit;
evCommand : case Event.Command of
cmNewDirectory:
begin
Path:=PathStr(Event.InfoPtr^);
SearchDir;
Draw;
ReScroll;
end;
cmLeft :if Mark.x>0 then
MoveMark(Mark.x-1,Mark.y)
else if Pos>0 then
begin
Dec(Pos);
Draw;
ReScroll;
end else
if Mark.y>0 then
MoveMark(Mark.x,0);
cmRight:if Mark.x<1 then
begin
if (Pos+1)*MaxHang<Count then
begin
DrawMark;
Inc(Mark.x);
if (Pos+1)*MaxHang+Mark.y+1>Count then
Mark.y:=Count mod MaxHang-1;
DrawMark;
ReScroll;
end else
if Mark.y<(Count-1) mod MaxHang then
MoveMark(Mark.x,(Count-1) mod MaxHang);
end else
begin
if (Pos+2)*MaxHang<Count then
begin
Inc(Pos);
if (Pos+1)*MaxHang+Mark.y+1>Count then
Mark.y:=Count mod MaxHang-1;
Draw;
ReScroll;
end else
if Mark.y<>((Count-1) mod MaxHang) then
MoveMark(Mark.x,(Count-1) mod MaxHang);
end;
cmInterhor:begin
TempY:=Round(Event.InforEal*Count);
if TempY=Count then Dec(TempY);
TempX:=TempY div MaxHang;
if TempY<>(Pos+Mark.x)*MaxHang+Mark.y then
begin
DrawMark;
Mark.x:=0;
Mark.y:=TempY mod MaxHang;
if TempX<>Pos then
begin
Pos:=TempX;
Draw;
end else
DrawMark;
ReScroll;
end;
end;
else exit;
end;
evKeyDown : case Event.KeyCode of
kbUp :if Mark.y>0 then
MoveMark(Mark.x,Mark.y-1)
else if Mark.x>0 then
begin
Mark.x:=0;
Mark.y:=MaxHang-1;
Draw;
ReScroll;
end else
if Pos>0 then
begin
Dec(Pos);
Mark.y:=MaxHang-1;
Draw;
ReScroll;
end;
kbDown :if Mark.y<MaxHang-1 then
begin
if (Pos+Mark.x)*MaxHang+Mark.y+1<Count then
MoveMark(Mark.x,Mark.y+1);
end else
if Mark.x<1 then
begin
if (Pos+Mark.x+1)*MaxHang<Count then
MoveMark(1,0);
end else
if (Pos+Mark.x+1)*MaxHang<Count then
begin
Inc(Pos);
Mark.y:=0;
Draw;
ReScroll;
end;
kbEnter :if (Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Attr and Directory)<>0 then
begin
Path:=MPath+Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Name+'\'+N+E;
SearchDir;
Draw;
ReScroll;
end else
begin
Event.What:=evCommand;
Event.Command:=cmSelectFile;
NPath:=MPath+Dir[(Pos+Mark.x)*MaxHang+Mark.y]^.Name;
Event.InfoPtr:=@NPath;
Exit;
end;
else Exit;
end;
else Exit;
end;
ClearEvent(Event);
end;
{------------tfiledialog object------------}
Constructor TFileDialog.Init;
begin
AssignRect(Broad,0,0,336,290);
Inherited Init(Broad,T,True);
Option:=Option or opAligen8;
TempPath:=P;
InputLine:=New(PInput,init(8,33,TempPath,30,ipBroad));
FileList:=New(PFileList,init(8,58,TempPath));
Insert(InputLine);
Insert(FileList);
Insert(New(PButton,Init(260,40,325,62,'确定~O~',kbAltO,cmOkDown)));
Insert(New(PButton,Init(260,70,325,92,'取消~N~',kbAltN,cmCancel)));
Insert(New(PButton,Init(260,100,325,122,'帮助~F1~',kbF1,cmHelp)));
Insert(New(PButton,Init(260,180,325,202,'驱动器~D~',kbAltD,cmDriver)));
Next;
Center;
PathExist(TempPath);
end;
Procedure TFileDialog.HandleEvent;
Label StartHandle;
begin
Inherited HandleEvent(Event);
StartHandle:
case Event.What of
evCommand : case Event.Command of
cmOk : if PathExist(TempPath) then
begin
Group^.GetThis^.Active;
Group^.NextActive;
Group^.GetThis^.Active;
Message(Group^.GetThis,cmNewDirectory,@TempPath);
end else
begin
Event.InfoPtr:=@TempPath;
Exit;
end;
cmOkDown : begin
Event.What:=evKeyDown;
Event.KeyCode:=kbEnter;
Event.CMark:=False;
if (Group^.GetThis=PView(InputLine)) or
(Group^.GetThis=PView(FileList)) then
Group^.GetThis^.HandleEvent(Event)
else
begin
Group^.GetThis^.Active;
Group^.Select(InputLine);
Group^.GetThis^.Active;
InputLine^.HandleEvent(Event);
end;
Goto StartHandle;
end;
cmSelectFile: begin
Event.Command:=cmOk;
Exit;
end;
cmDriver:begin
RunView(New(PDrvDialog,Init(FileList^.D[1])),Event);
if Event.Command=cmOk then
begin
TempPath:=Event.InfoChar+':'+FileList^.N+FileList^.E;
Group^.GetThis^.Active;
Group^.Select(FileList);
Group^.GetThis^.Active;
Message(Group^.GetThis,cmNewDirectory,@TempPath);
end;
end;
else Exit;
end;
else Exit;
end;
ClearEvent(Event);
end;
{
constructor TDirListBox.Init;
begin
Inherited Init(x,y,30,10,300,stVScroll);
Dir := '';
end;
procedure TDirListBox.HandleEvent(var Event: TEvent);
begin
Inherited HandleEvent(Event);
end;
procedure TDirListBox.NewDirectory(var ADir: DirStr);
const
PathDir = '滥�';
FirstDir = '缆�';
MiddleDir = ' 媚';
LastDir = ' 滥';
IndentSize = ' ';
var
NewDir, Dirct: DirStr;
C, OldC: Char;
S, Indent: String[80];
P: PString;
isFirst: Boolean;
SR: SearchRec;
I: Integer;
DirEntry: PDirEntry;
function NewDirEntry(const DisplayText, Directory: String): PDirEntry; near;
var
DirEntry: PDirEntry;
begin
New(DirEntry);
DirEntry^.DisplayText := NewStr(DisplayText);
DirEntry^.Directory := NewStr(Directory);
NewDirEntry := DirEntry;
end;
function GetCurDrive: Char; near; assembler;
asm
MOV AH,19H
INT 21H
ADD AL,'A'
end;
begin
Dir := ADir;
List^.Insert(NewDirEntry(Drives^,Drives^));
if Dir = Drives^ then
begin
isFirst := True;
OldC := ' ';
for C := 'A' to 'Z' do
begin
if (C < 'C') or DriveValid(C) then
begin
if OldC <> ' ' then
begin
if isFirst then
begin
S := FirstDir + OldC;
isFirst := False;
end
else S := MiddleDir + OldC;
List^.Insert(NewDirEntry(S, OldC + ':\'));
end;
if C = GetCurDrive then Cur := AList^.Count;
OldC := C;
end;
end;
if OldC <> ' ' then AList^.Insert(NewDirEntry(LastDir + OldC, OldC + ':\'));
end
else
begin
Indent := IndentSize;
NewDir := Dir;
Dirct := Copy(NewDir,1,3);
AList^.Insert(NewDirEntry(PathDir + Dirct, Dirct));
NewDir := Copy(NewDir,4,255);
while NewDir <> '' do
begin
I := Pos('\',NewDir);
if I <> 0 then
begin
S := Copy(NewDir,1,I-1);
Dirct := Dirct + S;
AList^.Insert(NewDirEntry(Indent + PathDir + S, Dirct));
NewDir := Copy(NewDir,I+1,255);
end
else
begin
Dirct := Dirct + NewDir;
AList^.Insert(NewDirEntry(Indent + PathDir + NewDir, Dirct));
NewDir := '';
end;
Indent := Indent + IndentSize;
Dirct := Dirct + '\';
end;
Cur := AList^.Count-1;
isFirst := True;
NewDir := Dirct + '*.*';
FindFirst(NewDir, Directory, SR);
while DosError = 0 do
begin
if (SR.Attr and Directory <> 0) and (SR.Name[1] <> '.') then
begin
if isFirst then
begin
S := FirstDir;
isFirst := False;
end else S := MiddleDir;
AList^.Insert(NewDirEntry(Indent + S + SR.Name, Dirct + SR.Name));
end;
FindNext(SR);
end;
P := PDirEntry(AList^.At(AList^.Count-1))^.DisplayText;
I := Pos('�',P^);
if I = 0 then
begin
I := Pos('�',P^);
if I <> 0 then P^[I] := '�';
end else
begin
P^[I+1] := '�';
P^[I+2] := '�';
end;
end;
NewList(AList);
FocusItem(Cur);
end;
}
end.