tstddlg.pas

Turbo Pascal 6.0编译器源码

  GetKey := @SR;
end;

function TFileList.GetText(Item: Integer; MaxLen: Integer): String;
var
  S: String;
  SR: PSearchRec;
begin
  SR := PSearchRec(List^.At(Item));
  S := SR^.Name;
  if SR^.Attr and Directory <> 0 then
  begin
    S[Length(S)+1] := '\';
    Inc(S[0]);
  end;
  GetText := S;
end;

procedure TFileList.HandleEvent(var Event: TEvent);
begin
  if (Event.What = evMouseDown) and (Event.Double) then
  begin
    Event.What := evCommand;
    Event.Command := cmOK;
    PutEvent(Event);
    ClearEvent(Event);
  end
  else TSortedListBox.HandleEvent(Event);
end;

procedure TFileList.ReadDirectory(AWildCard: PathStr);
const
  FindAttr = ReadOnly + Archive;
  AllFiles = '*.*';
  PrevDir  = '..';
var
  S: SearchRec;
  P: PSearchRec;
  FileList: PFileCollection;
  NumFiles: Word;
  CurPath: PathStr;
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
  Event: TEvent;
  Tmp: PathStr;
  Flag: Integer;
begin
  NumFiles := 0;
  FExpand(AWildCard, AWildCard);
  FSplit(AWildCard, Dir, Name, Ext);
  FileList := New(PFileCollection, Init(5, 5));
  Flag := FindFirst(AWildCard, FindAttr, S);
  P := @P;
  while (P <> nil) and (Flag = 0) do
  begin
    if (S.Attr and Directory = 0) then
    begin
      P := MemAlloc(SizeOf(P^));
      if P <> nil then
      begin
	Move(S.Attr, P^, SizeOf(P^));
	FileList^.Insert(P);
      end;
    end;
    Flag := FindNext(S);
  end;
  Tmp := Dir + AllFiles;
  Flag := FindFirst(Tmp, Directory, S);
  while (P <> nil) and (Flag = 0) do
  begin
    if (S.Attr and Directory <> 0) and (S.Name[1] <> '.') then
    begin
      P := MemAlloc(SizeOf(P^));
      if P <> nil then
      begin
	Move(S.Attr, P^, SizeOf(P^));
	FileList^.Insert(PObject(P));
      end;
    end;
    Flag := FindNext(S);
  end;
  if Length(Dir) > 4 then
  begin
    P := MemAlloc(SizeOf(P^));
    if P <> nil then
    begin
      FindFirst(Tmp, Directory, S);
      if (FindNext(S) = 0) and (S.Name = PrevDir) then
	Move(S.Attr, P^, SizeOf(P^))
      else
      begin
	P^.Name := PrevDir;
	P^.Size := 0;
	P^.Time := $210000;
	P^.Attr := Directory;
      end;
      FileList^.Insert(PObject(P));
    end;
  end;
  if P = nil
    then MessageBox(sTooManyFiles, nil, mfWarning + mfOkButton);
  NewList(FileList);
  if List^.Count > 0 then
  begin
    Event.What := evBroadcast;
    Event.Command := cmFileFocused;
    Event.InfoPtr := List^.At(0);
    Owner^.HandleEvent(Event);
  end;
end;

procedure TFileList.SetData(var Rec);
begin
  with PFileDialog(Owner)^ do
    Self.ReadDirectory(Directory^ + WildCard);
end;

constructor TFileInfoPane.Init(var Bounds: TRect);
begin
  TView.Init(Bounds);
  EventMask := EventMask or evBroadcast;
end;

procedure TFileInfoPane.Draw;
var
  B: TDrawBuffer;
  D: String[9];
  M: String[3];
  PM: Boolean;
  Color: Word;
  Time: DateTime;
  Path: PathStr;
  FmtId: Integer;
  Params: array[0..7] of LongInt;
  Str: String[80];
begin
  FExpand(PFileDialog(Owner)^.Directory^ + PFileDialog(Owner)^.WildCard, Path);
  Color := GetColor($01);
  MoveChar(B, ' ', Color, Size.X);
  MoveStr(B[1], Path, Color);
  WriteLine(0, 0, Size.X, 1, B);
  Params[0] := LongInt(@S.Name);
  MoveChar(B, ' ', Color, Size.X);
  Params[0] := LongInt(@S.Name);
  if S.Attr and Directory <> 0 then
  begin
    FmtId := sFileLine;
    D := Strings^.Get(sDirectory);
    Params[1] := LongInt(@D);
  end else
  begin
    FmtId := sDirectoryLine;
    Params[1] := S.Size;
  end;
  UnpackTime(S.Time, Time);
  M := Strings^.Get(Time.Month + sMonthBase);
  Params[2] := LongInt(@M);
  Params[3] := Time.Day;
  Params[4] := Time.Year;
  PM := Time.Hour >= 12;
  Time.Hour := Time.Hour mod 12;
  if Time.Hour = 0 then
    Time.Hour := 12;
  Params[5] := Time.Hour;
  Params[6] := Time.Min;
  if PM then
    Params[7] := Byte('p')
  else
    Params[7] := Byte('a');
  FormatStr(Str, Strings^.Get(FmtId), Params);
  MoveStr(B, Str, Color);
  WriteLine(0, 1, Size.X, 1, B);
  MoveChar(B, ' ', Color, Size.X);
  WriteLine(0, 2, Size.X, Size.Y - 2, B);
end;

function TFileInfoPane.GetPalette: PPalette;
const
  P: String[Length(CInfoPane)] = CInfoPane;
begin
  GetPalette := @P;
end;

procedure TFileInfoPane.HandleEvent(var Event: TEvent);
begin
  TView.HandleEvent(Event);
  if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) then
  begin
    S := PSearchRec(Event.InfoPtr)^;
    DrawView;
  end;
end;

constructor TFileDialog.Init(AWildCard: TWildStr; ATitle: String;
  InputName: String; AOptions: Word; HistoryId: Byte; AHelpCtx: Word);
var
  Control: PView;
  R: TRect;
  S: String;
  Opt: Word;
  ACurDir: PathStr;
  Y: Integer;
begin
  R.Assign(15, 1, 64, 20);
  TDialog.Init(R, ATitle);
  Options := Options or ofCentered;
  WildCard := AWildCard;
  R.Assign(3, 3, 31, 4);
  FileName := PFileInputLine(SetHelp(
    New(PFileInputLine, Init(R, 79)), AHelpCtx));
  FileName^.Data^ := WildCard;
  Inc(AHelpCtx);
  Insert(FileName);
  Insert(StandardLabel(InputName, FileName, lfTop));
  Insert(StandardHistory(FileName, HistoryId));
  R.Assign(3, 14, 34, 15);
  Control := New(PScrollBar, Init(R));
  Insert(Control);
  R.Assign(3, 6, 34, 14);
  FileList := PFileList(SetHelp(
    New(PFileList, Init(R, WildCard, PScrollBar(Control))), AHelpCtx));
  Inc(AHelpCtx);
  Insert(FileList);
  Insert(StandardLabel('~F~iles', FileList, lfTop));
  Opt := bfDefault;
  Y := 3;
  if AOptions and fdOpenButton <> 0 then
  begin
    Insert(NewButton(35, Y, 11, '~O~pen', cmFileOpen, Opt, AHelpCtx));
    Inc(AHelpCtx);
    Opt := bfNormal;
    Inc(Y, 3);
  end;
  if AOptions and fdOkButton <> 0 then
  begin
    Insert(NewButton(35, Y, 11, 'O~K~', cmOK, Opt, hcOkButton));
    Opt := bfNormal;
    Inc(Y, 3);
  end;
  if AOptions and fdReplaceButton <> 0 then
  begin
    Insert(NewButton(35, Y, 11, '~R~eplace', cmFileReplace, Opt, AHelpCtx));
    Inc(AHelpCtx);
    Opt := bfNormal;
    Inc(Y, 3);
  end;
  if AOptions and fdClearButton <> 0 then
  begin
    Insert(NewButton(35, Y, 11, '~C~lear', cmFileClear, Opt, AHelpCtx));
    Inc(AHelpCtx);
  end;
  Insert(NewButton(35, 11, 11, 'Cancel', cmCancel, bfNormal, hcCnlButton));
  Insert(NewButton(35, 14, 11, 'Help', cmHelp, bfNormal, AHelpCtx));
  R.Assign(1, 16, 48, 18);
  Insert(New(PFileInfoPane, Init(R)));
  SelectNext(False);
end;

constructor TFileDialog.Load(var S: TStream);
var
  ACurDir: DirStr;
  ViewId: Word;
begin
  TDialog.Load(S);
  S.Read(WildCard, SizeOf(TWildStr));
  ACurDir := GetCurDir;
  Directory := NewStr(ACurDir);
  GetSubViewPtr(S, FileName);
  GetSubViewPtr(S, FileList);
end;

destructor TFileDialog.Done;
begin
  DisposeStr(Directory);
  TDialog.Done;
end;

procedure TFileDialog.GetData(var Rec);
begin
  GetFilename(PathStr(Rec));
end;

procedure TFileDialog.GetFileName(var S: PathStr);
var
  Path: PathStr;
  Name: NameStr;
  Ext: ExtStr;
  TPath: PathStr;
  TName: NameStr;
  TExt: NameStr;

function LTrim(S: String): String;
var
  I: Integer;
begin
  I := 1;
  while (I < Length(S)) and (S[I] = ' ') do
    Inc(I);
  LTrim := Copy(S, I, 255);
end;

function RTrim(S: String): String;
var
  I: Integer;
begin
  while S[Length(S)] = ' ' do
    Dec(S[0]);
  RTrim := S;
end;

function RelativePath(var S: PathStr): Boolean;
var
  I, J: Integer;
  P: PathStr;
begin
  S := LTrim(RTrim(S));
  if (S <> '') and ((S[1] = '\') or (S[2] = ':')) then
    RelativePath := False
  else
    RelativePath := True;
end;

function NoWildChars(var S: String): String; assembler;
asm
	PUSH    DS
	LDS     SI,S
	XOR     AX,AX
	LODSB
	XCHG    AX,CX
	LES     DI,@Result
	INC     DI
@@1:    LODSB
	CMP     AL,'?'
	JE      @@2
	CMP     AL,'*'
	JE      @@2
	STOSB
@@2:    LOOP    @@1
	XCHG    AX,DI
	MOV     DI,WORD PTR @Result
	SUB     AX,DI
	DEC     AX
	STOSB
	POP     DS
end;

begin
  S := FileName^.Data^;
  if RelativePath(S) then
    FExpand(Directory^ + S, S)
  else
    FExpand(S, S);
  FSplit(S, Path, Name, Ext);
  if ((Name = '') or (Ext = '')) and not IsDir(S) then
  begin
    FSplit(WildCard, TPath, TName, TExt);
    if (Name = '') and (Ext = '') then
      S := Path + TName + TExt
    else if Name = '' then
      S := Path + TName + Ext
    else if Ext = '' then
      if IsWild(Name) then
        S := Path + Name + TExt
      else
        S := Path + Name + NoWildChars(TExt);
  end;
end;

procedure TFileDialog.HandleEvent(var Event: TEvent);
begin
  TDialog.HandleEvent(Event);
  if Event.What = evCommand then
    case Event.Command of
      cmFileOpen, cmFileReplace, cmFileClear:
	begin
	  EndModal(Event.Command);
	  ClearEvent(Event);
	end;
    end;
end;

procedure TFileDialog.SetData(var Rec);
begin
  TDialog.SetData(Rec);
  if (PathStr(Rec) <> '') and (IsWild(TWildStr(Rec))) then
  begin
    Valid(cmFileInit);
    FileName^.Select;
  end;
end;

procedure TFileDialog.Store(var S: TStream);
begin
  TDialog.Store(S);
  S.Write(WildCard, SizeOf(TWildStr));
  PutSubViewPtr(S, FileName);
  PutSubViewPtr(S, FileList);
end;

function TFileDialog.Valid(Command: Word): Boolean;
var
  T: Boolean;
  FName: PathStr;
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;

function CheckDirectory(var S: PathStr): Boolean;
begin
  if not DirExists(S) then
  begin
    MessageBox(sInvalidDir, nil, mfError + mfOkButton);
    FileName^.Select;
    CheckDirectory := False;
  end else CheckDirectory := True;
end;

begin
  if Command = cmValid then
  begin
    Valid := True;
    Exit;
  end else
    Valid := False;
  if TDialog.Valid(Command) then
  begin
    GetFileName(FName);
    if (Command <> cmCancel) and (Command <> cmFileClear) then
    begin
      if IsWild(FName) then
      begin
	FSplit(FName, Dir, Name, Ext);
	if CheckDirectory(Dir) then
	begin
	  DisposeStr(Directory);
	  Directory := NewStr(Dir);
	  WildCard := Name + Ext;
	  if Command <> cmFileInit then
            FileList^.Select;
	  FileList^.ReadDirectory(Directory^ + WildCard);
	end
      end
      else if IsDir(FName) then
      begin
	if CheckDirectory(FName) then
	begin
	  DisposeStr(Directory);
	  Directory := NewSTr(FName+'\');
	  if Command <> cmFileInit then
            FileList^.Select;
	  FileList^.ReadDirectory(Directory^ + WildCard);
	end
      end else if ValidFileName(FName) then
        Valid := True
      else
      begin
	MessageBox(sInvalidFileName, nil, mfError + mfOkButton);
	Valid := False;
      end
    end
    else
      Valid := True;
  end;
end;

type

  PDirEntry = ^TDirEntry;
  TDirEntry = record
    DisplayText: PString;
    Directory: PString;
  end;

  PDirCollection = ^TDirCollection;
  TDirCollection = object(TCollection)
    procedure FreeItem(Item: Pointer); virtual;
  end;

procedure TDirCollection.FreeItem(Item: Pointer);
var
  DirItem: PDirEntry absolute Item;
begin
  DisposeStr(DirItem^.DisplayText);
  DisposeStr(DirItem^.Directory);
  Dispose(DirItem);
end;

const
  DrivesS: String[6] = 'Drives';
  Drives: PString = @DrivesS;

constructor TDirListBox.Init(var Bounds: TRect; AScrollBar:
  PscrollBar);
begin
  TListBox.Init(Bounds, 1, AScrollBar);
  Dir := '';
end;

destructor TDirListBox.Done;
begin
  if List <> nil then Dispose(List, Done);
  TListBox.Done;
end;

function TDirListBox.GetText(Item: Integer; MaxLen: Integer): String;
begin
  GetText := PDirEntry(List^.At(Item))^.DisplayText^;
end;

procedure TDirListBox.HandleEvent(var Event: TEvent);
begin
  if (Event.What = evMouseDown) and (Event.Double) then
  begin
    Event.What := evCommand;
    Event.Command := cmChangeDir;
    PutEvent(Event);
    ClearEvent(Event);
  end
  else TListBox.HandleEvent(Event);
end;

function TDirListBox.IsSelected(Item: Integer): Boolean;
begin
  IsSelected := Item = Cur;
end;

procedure TDirListBox.NewDirectory(var ADir: DirStr);
const
  PathDir            = '滥