spskinshellctrls.pas

P2P即时通讯源码(DELPHI编写)

function TspSkinFileListView.GetMediaTypeStr(MT: TMediaType): String;
begin
  case MT of
    dtUnknown: Result:='<unknown>';
    dtNotExists: Result:='<not exists>';
    dtRemovable: Result:='Removable';
    dtFixed: Result:='Fixed';
    dtRemote: Result:='Remote';
    dtCDROM: Result:='CDROM';
    dtRAMDisk: Result:='RAM';
  end;
end;

{ ================================TspSkinDirTreeView ==============================}
const
  InvalidDOSChars = '\*?/="<>|:,;+^';
  
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;

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;

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

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

function DiskinDrive(Drive: Char; ShowMsg: word; SM: TspSkinMessage): Boolean;
var
  ErrorMode: word;
begin
  if Drive in ['a'..'z'] then
    Dec(Drive, $20);
  if not (Drive in ['A'..'Z']) then
  if SM = nil
  then
    MessageDlg(SP_NOVALIDDRIVEID, mtError, [mbOK], 0)
  else
    SM.MessageDlg(SP_NOVALIDDRIVEID, mtError, [mbOK], 0);


  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    if DiskSize(Ord(Drive) - $40) = -1 then
    begin
      if ShowMsg > 0 then
      begin
        MessageBeep(MB_IconHand);
        if SM = nil
        then
          MessageDlg(SP_NODISKINDRIVE, mtWarning, [mbOK], 0)
        else
          SM.MessageDlg(SP_NODISKINDRIVE,
            mtWarning, [mbOK], 0);
      end;
      Result := False
    end
    else
      Result := True;
  finally
    SetErrorMode(ErrorMode);
  end;
end;

function AddNullToStr(Path: string): string;
begin
  if Path = '' then exit;
  if Path[Length(Path)] <> #0 then
    Result := Path + #0
  else
    Result := Path;
end;

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; 

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 := GetActiveWindow;  
    wFunc := OpMode;
    pFrom := pChar(Src);
    pTo := pChar(Dest);
    fFlags := FOF_ALLOWUNDO;
    fAnyOperationsAborted := Aborted;
    hNameMappings := nil;
    lpszProgressTitle := '';
  end;
  Result := SHFileOperation(ipFileOp) = 0;
  if ipFileOp.fAnyOperationsAborted = True then
    Result := False;
end;

procedure TspSkinDirTreeView.CreateWnd;
begin
  inherited CreateWnd;
  if not (csLoading in ComponentState)
  then
    begin
      ReLoad;
      if Items.GetFirstNode <> nil then
      Items.GetFirstNode.Expand(False);
    end;  
end;

constructor TspSkinDirTreeView.Create;
var
  sfi: TShFileInfo;
  hImgLst: Uint;
begin
  inherited Create(AOwner);

  OldTreeViewPath := '';

  ReadOnly := True;
  Width := 180;
  Height := 120;

  Images := TImageList.Create(Self);
  hImgLst := SHGetFileInfo('', 0,
    sfi, SizeOf(sfi),
    SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  if hImgLst <> 0 then
  begin
    Images.Handle := hImgLst;
    Images.ShareImages := True;
  end;

  OnExpanding := Expanding;
  SortType := stNone;
  HideSelection := False;
  FIsNewFolder := False;
  FisCutCopy := False;

  FSkinMessage := nil;
end;

destructor TspSkinDirTreeView.Destroy;
var
  i: integer;
begin
  for i := Items.Count - 1 downto 0 do
    Items[i].Free;
  Images.Free;
  inherited Destroy;
end;

procedure TspSkinDirTreeView.ChangeSkinData;
begin
  inherited;
  IMages.BkColor := Self.Color;
end;

procedure TspSkinDirTreeView.Notification;
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FSkinMessage)
  then
    FSkinMessage := nil;
end;

function TspSkinDirTreeView.GetDirectory: String;
begin
  Result := GetPathFromNode(Self.Selected);
end;

procedure TspSkinDirTreeView.SetDirectory(Value: String);
begin
  OpenPath(Value);
end;

procedure TspSkinDirTreeView.LoadRoot;
var
  Sfi: TSHFileInfo;
  Root: TTreenode;
  idRoot: PItemIDList;
begin
  Items.BeginUpdate;
  Items.Clear;
  if SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, idRoot) = NOERROR then
    if SHGetFileInfo(PChar(idRoot), 0, Sfi, SizeOf(TSHFileInfo), SHGFI_PIDL
      or
      SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_DISPLAYNAME) <> 0 then
    begin
      Root := items.AddFirst(nil, Sfi.szDisplayName);
      Root.ImageIndex := Sfi.iIcon;
      Root.SelectedIndex := Sfi.iIcon;
    end;
  Items.EndUpdate;
end; 

procedure TspSkinDirTreeView.LoadDrives;
var
  ADrive: integer;
  DriveLetter: char;
  DriveString: string;
  DrvName: string;
  Sfi: TSHFileInfo;
begin
  Items.BeginUpdate;
  Integer(Drives) := GetLogicalDrives;
  for ADrive := 0 to 25 do
  begin
    if ADrive in Drives then
    begin
      DriveLetter := Chr(ADrive + ord('A'));
      DriveString := DriveLetter + ':\';
      SHGetFileInfo(PChar(DriveString), 0, Sfi, SizeOf(Sfi),
        SHGFI_DISPLAYNAME);
      DrvName := Copy(Sfi.szDisplayName, 1, (Pos('(', Sfi.szDisplayName) - 1));
      with Items do
      begin
        AddChild(Items[0], ' (' + DriveLetter + ':)  ' + DrvName);
        ShowButtons := True;
        Items[Count - 1].HasChildren := True;
        Items[Count - 1].ImageIndex := GetNormalIcon(DriveString);
        Items[Count - 1].SelectedIndex := GetSelectedIcon(DriveString);
      end;
    end;
  end;
  Items.EndUpdate;
end; 

procedure TspSkinDirTreeView.MakePath(Node: TTreeNode);

  procedure MakeSubPath;
  begin
    if Node.Level = 1 then
      TreeViewPath := Copy(Node.Text, 3, 2) + '\' + TreeViewPath
    else if Node.Level > 1 then
      if TreeViewPath = '' then
        TreeViewPath := Node.Text
      else
        TreeViewPath := Node.Text + '\' + TreeViewPath;
  end;

begin
  TreeViewPath := '';
  MakeSubPath;
  while Node.Parent <> nil do
  begin
    Node := Node.Parent;
    MakeSubPath;
  end;
end;

procedure TspSkinDirTreeView.AddSubs(Path: string; Node: TTreeNode);
var
  ANode: TTreeNode;
  APath: string;
  hFindFile: THandle;
  Win32FD: TWin32FindData;

  function IsDirectory(dWin32FD: TWin32FindData): Boolean;
  var
    FName: string;
  begin
    FName := StrPas(dWin32FD.cFileName);
    with dWin32FD do
      Result := (dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY =
        FILE_ATTRIBUTE_DIRECTORY) and (FName <> '.') and (FName <> '..');
  end; 

  function HasSubs(sPath: string): Boolean;
  var
    sAPath: string;
    shFindFile: THandle;
    sWin32FD: TWin32FindData;
  begin
    Result := False;
    sAPath := sPath;
    sAPath := AddSlash(sAPath);
    shFindFile := FindFirstFile(PChar(sAPath + '*.*'), sWin32FD);
    if shFindFile <> INVALID_HANDLE_VALUE then
    try
      repeat
        if IsDirectory(sWin32FD) then
        begin
          Result := True;
          Break;
        end;
      until not FindNextFile(shFindFile, sWin32FD);
    finally
      Windows.FindClose(shFindFile);
    end;
  end; 

begin
  if (Length(Path) = 3) and (Pos(':\', Path) <> 0)
  then
    begin
      if not DiskInDrive(Path[1], 1, FSkinMessage)
      then
        Exit;
    end;
  APath := Path;

  APath := AddSlash(APath);
  hFindFile := FindFirstFile(PChar(APath + '*.*'), Win32FD);
  if hFindFile <> INVALID_HANDLE_VALUE then
  try
    repeat
      if IsDirectory(Win32FD) then
      begin
        ANode := Items.AddChild(Node, Win32FD.cFileName);
        ANode.HasChildren := HasSubs(APath + Win32FD.cFileName);
        ANode.ImageIndex := GetNormalIcon(APath + Win32FD.cFileName);
        ANode.SelectedIndex := GetSelectedIcon(APath + Win32FD.cFileName);
      end;
    until not FindNextFile(hFindFile, Win32FD);
  finally
    Windows.FindClose(hFindFile);
  end;
end; 

procedure TspSkinDirTreeView.ReLoad;
begin
  Items.BeginUpdate;
  Items.Clear;
  LoadRoot;
  LoadDrives;
  Items.EndUpdate;
end; 

procedure TspSkinDirTreeView.Loaded;
begin
  inherited Loaded;
  Reload;
  if Items.GetFirstNode <> nil then
    Items.GetFirstNode.Expand(False);
end; 

procedure TspSkinDirTreeView.Expanding(Sender: TObject; Node: TTreeNode;
  var AllowExpansion: Boolean);
var
  OldCursor: TCursor;
begin
  if Node.GetFirstChild = nil then
  begin
    OldCursor := Screen.Cursor;
    Screen.Cursor := crHourGlass;
    try
      MakePath(Node);
      Node.HasChildren := false;
      AddSubs(TreeViewPath, Node);
      Node.AlphaSort;
    finally
      Screen.Cursor := OldCursor;
    end;
  end;
end;

procedure TspSkinDirTreeView.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  vHitTest: THitTests;
  DrvChar: Char;
begin
  inherited MouseDown(button, shift, x, y);

  TreeViewPath := '';
  FPreviousPath := FSelectedPath;
  vHitTest := GetHitTestInfoAt(X, Y);
  if (htOnItem in vHitTest) or (htOnIcon in vHitTest) or
     (htOnButton in vHitTest) then
  begin
    Selected := GetNodeAt(X, Y);
    if (Selected.Level = 0) and (Items[0].getFirstChild = nil) then
      LoadDrives
    else
      MakePath(Selected);

    if Selected = Items[0] then
      FSelectedPath := 'Drives'
    else
      FSelectedPath := TreeViewPath;

    if Selected.Level = 1 then
      if GetDriveType(PChar(FSelectedPath)) in
           [DRIVE_REMOVABLE, DRIVE_CDROM] then
      begin
        DrvChar := FSelectedPath[1];
        if not DiskInDrive(DrvChar, 1, FSkinMessage) then
        begin
          OpenPath(FPreviousPath);
          exit;
        end;
      end;
    FPreviousPath := FSelectedPath;
  end;
end;

procedure TspSkinDirTreeView.SetSelectedPath(Value: string);
begin
  if AnsiCompareText(Value, FSelectedPath) = 0 then
    exit;
  FSelectedPath := Value;
end;

procedure TspSkinDirTreeView.SetInitialDir(Value: string);
begin
  if (Value = '') or (AnsiCompareText(Value, FInitialDir) = 0)  then
    exit;
  Value := AddSlash(Value);
  if (not DirectoryExists(Value)) then
    exit
  else begin
    FInitialDir := Value;
    OpenPath(FInitialDir);
  end;
end;

procedure TspSkinDirTreeView.OpenPath(dPath: string);