bsskinshellctrls.pas

布林电话收费管理系统

  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 TbsSkinDirTreeView.CreateWnd;
begin
  inherited CreateWnd;
  if not (csLoading in ComponentState)
  then
    begin
      ReLoad;
      if Items.GetFirstNode <> nil then
      Items.GetFirstNode.Expand(False);
    end;  
end;

constructor TbsSkinDirTreeView.Create;
var
  sfi: TShFileInfo;
  hImgLst: Uint;
begin
  inherited Create(AOwner);
  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;
end;

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

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

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

procedure TbsSkinDirTreeView.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 TbsSkinDirTreeView.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 TbsSkinDirTreeView.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 TbsSkinDirTreeView.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
  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 TbsSkinDirTreeView.ReLoad;
begin
  Items.BeginUpdate;
  Items.Clear;
  LoadRoot;
  LoadDrives;
  Items.EndUpdate;
end; 

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

procedure TbsSkinDirTreeView.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 TbsSkinDirTreeView.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) then
        begin
          OpenPath(FPreviousPath);
          exit;
        end;
      end;
    FPreviousPath := FSelectedPath;
  end;
end;

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

procedure TbsSkinDirTreeView.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 TbsSkinDirTreeView.OpenPath(dPath: string);
var
  CurNode: TTreeNode;
  count: Integer;
  TempPath: string;
  CurPath: string;
  FullPath: string;
begin
  if (dPath = '') or (Length(dPath) = 1) then exit;
  if not DirectoryExists(dPath) then exit;
  dPath := AddSlash(dPath);
  FullPath := dPath;
  Items.BeginUpdate;
  CurNode := Items.GetFirstNode;  //70
  if CurNode.getFirstChild = nil then
    LoadDrives;
 {if CurNode.Expanded then
     CurNode.Collapse(True);}
  CurNode := Items.GetFirstNode;
  while Pos('\', dPath) > 0 do
  begin
    count := Pos('\', dPath);
    tempPath := Copy(dPath, 1, count);
    dPath := Copy(dPath, count + 1, Length(dPath));
    CurNode := CurNode.getFirstChild;

    while CurNode <> nil do
    begin
      if CurNode.Level = 1 then
        CurPath := Copy(CurNode.Text, 3, 2) + '\'
      else if CurNode.Level > 1 then
        CurPath := CurNode.Text + '\';
      if AnsiCompareText(CurPath, tempPath) = 0 then
      begin
        CurNode.Selected := True;
        CurNode.Expand(False);
        Break;
      end;
      CurNode := CurNode.GetNext;
      if CurNode = nil then exit;
    end;
  end;
  Items.EndUpdate;
  if AnsiCompareText(FSelectedPath, FullPath) <> 0 then
  begin
    FullPath := AddSlash(FullPath);
    FSelectedPath := FullPath;
  end;
end;

procedure TbsSkinDirTreeView.KeyUp(var Key: Word; Shift: TShiftState);
var
  DrvChar: Char;
begin
  if (Key = VK_UP) or (Key = VK_DOWN) or (Key = VK_LEFT) or (Key = VK_RIGHT) then
  begin
    inherited KeyUp(Key, Shift);

    if selected = nil then exit;
    if (Selected.Level = 0) and (Items[0].getFirstChild = nil) then
      LoadDrives
    else
      MakePath(Selected);

    if (Selected.Level = 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) then
          exit;
      end;
  end;
  if Key=VK_F5 then
  begin
    Reload;
    OpenPath(FSelectedPath);
  end;
end;

function TbsSkinDirTreeView.GetPathFromNode(Node: TTreeNode): string;
begin
  Result := '';
  if Node = nil then exit;
  if Assigned(Node) then
  begin
    MakePath(Node);
    Result := TreeViewPath;
  end;
end;

function TbsSkinDirTreeView.CanEdit(Node: TTreeNode): Boolean;
begin
  Result := False;
  if (Assigned(Node.Parent)) and (Node.Level > 1) and
    (not ReadOnly) then
    Result := inherited CanEdit(Node);
end;

procedure TbsSkinDirTreeView.Edit(const Item: TTVItem);
var
  OldDirName: string;
  NewDirName: string;
  Aborted: Boolean;
  OldCur: TCursor;
  Rslt: Boolean;
  SelNode: TTreeNode;
  PrevNode: TTreeNode;

  function GetNodeFromItem(Item: TTVItem): TTreeNode;
  begin
    with Item do
      if (State and TVIF_PARAM) <> 0 then
        Result := Pointer(lParam)
      else
        Result := Items.GetNode(hItem);
  end;

begin
  SelNode := GetNodeFromItem(Item);
  PrevNode := SelNode.Parent;
  if not Assigned(SelNode) then exit;
  if (SelNode = Items[0]) or (SelNode.Level = 1) then
    exit;