lsfileexplorer27.pas

TLsDirComboBox 及 TLsFileListView 是类似资源管理器 ( File Explorer ) 式样的加强版 TComboBox 构件

  public
  { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CutCopy(Mode: integer);
    procedure DeleteItems;
    procedure FindFile;
    procedure FileAttr;
    procedure NewFolder;
    procedure OneLevelUp;
    procedure OpenItem;
    procedure Paste;
    procedure RenameFile;
    procedure UpdateFileList;
    procedure ViewFile;
    procedure SetColumnWidth(Col_Name, Col_Size, Col_Type, Col_Mod,
      Col_Attr: integer);
    property DirectorySize: integer read FDirectorySize;
    property SelectedItem: string read GetSelectedItem write SetSelectedItem;
    property SelCount;
    property Selected;

  published
  { Published declarations }
{$IFNDEF D5_OR_HIGHER}
    property About: TAboutProperty read FAbout write FAbout;
{$ENDIF}
    property DateFormat: TDTFormat read FDaTeFormat write SetDaTeFormat
      default df_MMddyyyy; //70
    property TimeFormatStr: string read FTFormatStr write SetTFormatStr; //70
    property HideFileExt: Boolean read FHideFileExt write SetHideFileExt
      default False; //70
    property Directory: string read GetDirectory write SetDirectory;
    property DirTreeCombo: TLsDirTreeCombo27 read FDirTreeCombo
      write SetDirTreeCombo;
    property DirTree: TLsDirTree20 read FDirTree
      write SetDirTree; //60
    property DriveFreeSpace: Integer read GetFreeSpace;
    property DblClickToOpen: Boolean read FDblClickToOpen
      write SetDblClickToOpen default True;
    property FileType: TFileType read FFileType write SetFileType default
      [ftNormal];
    property Mask: string read FMask write SetMask;
    property PopUpMenuEnabled: Boolean read FPopUpMenuEnabled
      write SetPopUpMenuEnabled default True;
    property SelectedNumber: Integer read GetSelectedNum;
    property SelectedSize: Integer read GetSelectedSize;
    property ShowFolders: Boolean read FShowFolders write SetShowFolders
      default True;
    property Align;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property Cursor;
    property Dragmode;
    property DragCursor;
    property Enabled;
    property Font;
    property Height;
    property HideSelection default False;
    property Hint;
    property IconOptions;
    property Items;
    property Left;
    property MultiSelect default True;
    property Name;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly default False;
    property ShowColumnHeaders default True;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Top;
    property ViewStyle default vsReport;
    property Visible;
    property Width;
    property OnChange;
    property OnChanging;
    property OnClick;
    property OnColumnClick;
    property OnCompare;
    property OnDblClick;
    property OnDeletion;
    property OnDragDrop;
    property OnDragOver;
    property OnEdited;
    property OnEditing;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnInsert;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
{$IFDEF D3_OR_HIGHER}
    property HotTrack;
    property RowSelect default False;
{$ENDIF}
{$IFDEF D4_OR_HIGHER}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property HotTrackStyles;
{$ENDIF}
  end;

 { ====== TLsFileListView27PopUp ====== }

  TLsFileListView27PopUp = class(TPopupMenu)
  private
    SendToList: TStrings;
    FFileListView: TLsFilelistView27;
    Bmp1, Bmp2,
      Bmp3, Bmp4,
      Bmp5, Bmp6,
      Bmp7, Bmp8,
      Bmp9, Bmp10,
      Bmp11, Bmp12: HBITMAP; //70

  protected
    function AddNewItem(const aCaption: string; aShortCut: TShortCut;
      aChecked, aEnabled: Boolean; aGroup: integer; aOnClick: TNotifyEvent;
      hCtx: word; const aName: string; aBitMap: HBitMap): TMenuItem;
    procedure SetFileListView(Value: TLsFilelistView27);
    procedure GetSendToSubMenu;
    procedure ItemOnClick(Sender: TObject);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BuildItems;
    procedure Popup(X, Y: integer); override;
    property FileListView: TLsFilelistView27 read FFileListView;
  end;

 {*******************************************}
 {             TAboutProperty                }
 {*******************************************}

{$IFNDEF D5_OR_HIGHER}
  TAboutProperty = class(TPropertyEditor)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
  end;
{$ENDIF}

{*******************************************}
{          Global Functions                 }
{*******************************************}

function ExecuteFile(const Operation, FileName, Params, DefaultDir: string;
  ShowCmd: Integer): THandle;
function DoSHFileOp(Handle: THandle; OpMode: UInt; Src: string;
  Dest: string; var Aborted: Boolean): Boolean;
function AddNullToStr(Path: string): string;
function StrContains(Str1, Str2: string): Boolean;
function BrowseForDir(const FormHandle: HWND; var DirPath: string):
  Boolean;
function numpos(a: char; b: string; c: integer): integer;
function getcount(a: char; b: string): integer;
function GetDiskSize(Root: string): LongInt;
function GetFreeDiskSize(Root: string): LongInt;
function DiskinDrive(Drive: Char; ShowMsg: word): Boolean;
function SlashSep(Path, FName: string): string;
function AddSlash(Path: string): string;
function DelSlash(Path: string): string;
function FileTimeToDateTimeStr(FTime: TFileTime; DFormat: string; //70
  TFormat: string): string;
function FileDirExist(FDName: string): Boolean;
function GetNormalIcon(Path: string): integer;
function GetSelectedIcon(Path: string): Integer;
function ConvertSize(FSize: integer; FAttr: string): String;


procedure Register;


implementation

{$R *.Res}

const

  InvalidDOSChars = '\*?/="<>|:,;+^';
  DefaultMask = '*.*';
  FileOpMode: array[0..3] of UInt =
    (FO_COPY, FO_DELETE, FO_MOVE, FO_RENAME);

  FileExt: array[0..13] of string = ('.C', '.CPP', '.DPK', '.DPR', '.H',
    '.INF', '.INI', '.PAS', '.PRG', '.TXT', '.DOC', '.RTF', '.WRI', '.BMP');


 {***********************************************************************}
 {                        Global Functions                               }
 {***********************************************************************}

function ExecuteFile(const Operation, FileName, Params, DefaultDir: string;
  ShowCmd: Integer): THandle;
var
  zOperation: array[0..79] of Char;
  zFileName: array[0..79] of Char;
  zParams: array[0..79] of Char;
  zDir: array[0..79] of Char;
begin
  Result := ShellExecute(Application.Handle,
    StrPCopy(zOperation, Operation),
    StrPCopy(zFileName, FileName),
    StrPCopy(zParams, Params),
    StrPCopy(zDir, DefaultDir), ShowCmd);
  if Result <= 32 then
    MessageDlg('ERROR - Can''t ' + Operation + ' file  ' +
      FileName, mtError, [mbOK], 0);
end; {ExecuteFile}

function DoSHFileOp(Handle: THandle; OpMode: UInt; Src: string;
  Dest: string; var Aborted: Boolean): Boolean;
var
  ipFileOp: TSHFileOpStruct;
begin
  Src := AddNullToStr(Src);
  Dest := AddNullToStr(Dest);
  FillChar(ipFileOp, SizeOf(ipFileOp), 0);
  with ipFileOp do
  begin
    wnd := Handle;
    wFunc := OpMode;
    pFrom := pChar(Src);
    pTo := pChar(Dest);
    fFlags := FOF_ALLOWUNDO; //or FOF_NOCONFIRMATION;
    fAnyOperationsAborted := Aborted;
    hNameMappings := nil;
    lpszProgressTitle := '';
  end;
  Result := SHFileOperation(ipFileOp) = 0;
  if ipFileOp.fAnyOperationsAborted = True then
    Result := False;
end; {DoSHFileOp}

function AddNullToStr(Path: string): string; //70
begin
  if Path = '' then exit;
  Result := Path + #0;
end; {AddnullToStr}

function StrContains(Str1, Str2: string): Boolean;
var
  i: Integer;
begin
  for i := 1 to Length(Str1) do
    if Pos(Str1[i], Str2) <> 0 then
    begin
      Result := True;
      Exit;
    end;
  Result := False;
end; {StringCountains}

function BrowseForDir(const FormHandle: HWND; var DirPath: string):
  Boolean;
var
  pidl: PItemIDList;
  FBrowseInfo: TBrowseInfo;
  Success: Boolean;
  TitleName: string;
  Buffer: array[0..Max_Path] of Char;
begin
  Result := False;
  ZeroMemory(@FBrowseInfo, SizeOf(FBrowseInfo));
  try
    GetMem(FBrowseInfo.pszDisplayName, MAX_PATH);
    FBrowseInfo.HWndOwner := FormHandle;
    TitleName := 'Please specify a directory';
    FBrowseInfo.lpszTitle := PChar(TitleName);
    pidl := SHBrowseForFolder(FBrowseInfo);
    if pidl <> nil then
    begin
      Success := SHGetPathFromIDList(pidl, Buffer);
      if Success then
      begin
        DirPath := Buffer;
        if DirPath[Length(DirPath)] <> '\' then
          DirPath := DirPath + '\';
        result := True;
      end;
      GlobalFreePtr(pidl);
    end;
  finally
    if Assigned(FBrowseInfo.pszDisplayName) then
      FreeMem(FBrowseInfo.pszDisplayName, Max_Path);
  end;
end; {BrowseForDir}

function numpos(a: char; b: string; c: integer): integer;
var
  it: integer;
  az: integer;
begin
  result := maxint;
  if length(b) > 0 then
  begin
    az := 0;
    for it := 1 to length(b) do
      if b[it] = a then
      begin
        inc(az);
        if az = c then
        begin
          result := it;
          exit;
        end;
      end;
  end;
end; {numpos}

function getcount(a: char; b: string): integer;
var
  it: integer;
begin
  result := 0;
  if length(b) > 0 then
    for it := 1 to length(b) do
      if b[it] = a then inc(result);
end; {getcount}

function GetDiskSize(Root: string): LongInt;
var
  SpC,
    BpS,
    NfC,
    TnC: DWORD;
  DiskSize: Extended; //Double;  //53
begin
  GetDiskFreeSpace(PChar(Root), SpC, BpS, NfC, TnC);
  DiskSize := TnC * SpC; //53
  DiskSize := (DiskSize * BpS) / 1024;
  Result := Round(DiskSize); // Result in KB
end; {GetDiskSize}

function GetFreeDiskSize(Root: string): LongInt;
var
  SpC, BpS,
    NfC, TnC: DWORD;
  FreeDiskSize: Extended; //Double;  //53
begin
  GetDiskFreeSpace(PChar(Root), SpC, BpS, NfC, TnC);
  FreeDiskSize := Nfc * SpC;
  FreeDiskSize := (FreeDiskSize * BpS) / 1024;
  Result := Round(FreeDiskSize); // Result in KB
end; {GetFreeDiskSize}

function DiskinDrive(Drive: Char; ShowMsg: word): Boolean;
var
  ErrorMode: word;
begin
  if Drive in ['a'..'z'] then
    Dec(Drive, $20);
  if not (Drive in ['A'..'Z']) then
    Showmessage('Not a valid Drive ID');
  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    if DiskSize(Ord(Drive) - $40) = -1 then
    begin
      if ShowMsg > 0 then
      begin
        MessageBeep(MB_IconHand);
        ShowMessage('ERROR - There is no disk in Drive ' + Drive + #13 +
          '                or Drive ' + Drive + ' is not ready');
      end;
      Result := False
    end
    else
      Result := True;
  finally
    SetErrorMode(ErrorMode);
  end;
end; {DiskinDrive}

function SlashSep(Path, FName: string): string;
begin
  if (Path = '') or (FName = '') then exit;
  Result := AddSlash(Path) + FName;
end; {SlashSep}

function AddSlash(Path: string): string;
begin
  if Path = '' then exit;
  if Path[Length(Path)] <> '\' then
    Result := Path + '\'
  else
    Result := Path;
end; {AddSlash}

function DelSlash(Path: string): string;
begin
  Result := Path;
  if Path <> '' then
    if Path[Length(Path)] = '\' then
      Delete(Result, Length(Path), 1);
end; {DelSlash}

function FileTimeToDateTimeStr(FTime: TFileTime; DFormat,
  TFormat: string): string;  //70
var
  SysTime       : TSystemTime;
  DateTime      : TDateTime;
  LocalFileTime : TFileTime;
begin
  FileTimeToLocalFileTime(Ftime, LocalFileTime);
  FileTimeToSystemTime(LocalFileTime, SysTime);
  DateTime := SystemTimeToDateTime(SysTime);
  Result := FormatDateTime(DFormat + ' ' + TFormat, DateTime);
end; {FileTimeToDateTimeStr}

function FileDirExist(FDName: string): Boolean;
var
  SRec: TSearchRec;
  FName: string;
begin
  FillChar(SRec, SizeOf(TSearchRec), 0);
  Result := FindFirst(AddNullToStr(FDName), faAnyFile or faDirectory, SRec) = 0;
  if Result then
  begin
    FName := ExtractFileName(DelSlash(FDName));
    if (FName[Length(FName)] = #0) then
      FName := Copy(FName, 1, Length(FName) - 1);
    ShowMessage('ERROR - "' + FName + '" already exists !');
  end;
  SysUtils.FindClose(SRec);
end; {FileDirExist}

function GetNormalIcon(Path: string): integer;
var
  sfi: TShFileInfo;
begin
  SHGetFileInfo(Pchar(Path), 0, sfi, SizeOf(TSHFileInfo),
    SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  Result := sfi.iIcon;
end; {GetNormalIcon}

function GetSelectedIcon(Path: string): Integer;
var
  sfi: TShFileInfo;
begin
  SHGetFileInfo(Pchar(Path), 0, sfi, sizeOf(TSHFileInfo),
    SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_OPENICON);
  Result := sfi.iIcon;
end; {GetSelectedIcon}

function ConvertSize(FSize: integer; FAttr: String): String;
begin
  if (FSize < 1024) and (FSize > 0) then
    FSize := 1024;
  Result := IntToStr(FSize div 1024);
  if (UpperCase(FAttr) = 'DIR') then
    Result := '0';
end; {ConvertSize}

///// End of Global Functions /////

{************************************************************************}
{                           TAboutProperty                               }
{************************************************************************}

{$IFNDEF D5_OR_HIGHER}

procedure TAboutProperty.Edit;
begin
  MessageDlg('TLsDirTree20, TLsDirTreeCombo27 and' + #13#10 +
    '               TLsFilelistView27' + #13#10 +
    '                   Version 2.70 ' + #13#13#10 +
    '