cxshelllistview.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,757 行 · 第 1/4 页

      end
      else
        Exit;
    end
    else
      if APath[1] = '\' then
      begin
        if APathLength = 1 then
          APath := Copy(ACurrentPath, 1, 3)
        else
          APath := Copy(ACurrentPath, 1, 2) + APath;
        Result := sptAbsolutePhysical;
        Exit;
      end
      else
        if not AIsDisplayText then
          Exit
        else
        begin
          APath := Copy(APath, 3, APathLength - 2);
          Result := sptRelativePhysical;
          Exit;
        end;
  end;
  Result := sptRelativePhysical;
end;

function CheckViewOptions(AViewOptions: TcxShellViewOptions;
  AShellObjectAttributes: ULONG): Boolean;
begin
  Result := not((AShellObjectAttributes and SFGAO_HIDDEN <> 0) and
    not(svoShowHidden in AViewOptions));
  Result := Result and not((AShellObjectAttributes and SFGAO_FOLDER = 0) and
    not(svoShowFiles in AViewOptions));
  Result := Result and not((AShellObjectAttributes and SFGAO_FOLDER <> 0) and
    not(svoShowFolders in AViewOptions));
end;

procedure DestroyShellSpecialFolderInfoTable;
var
  ACSIDL: Integer;
begin
  for ACSIDL := CSIDL_DESKTOP to CSIDL_HISTORY do
  begin
    DisposePidl(cxShellSpecialFolderInfoTable[ACSIDL].PIDL);
    cxShellSpecialFolderInfoTable[ACSIDL].PIDL := nil;
  end;
end;

function GetShellEnumObjectsFlags(AViewOptions: TcxShellViewOptions): DWORD;
begin
  Result := 0;
  if svoShowFiles in AViewOptions then
    Result := Result or SHCONTF_NONFOLDERS;
  if svoShowFolders in AViewOptions then
    Result := Result or SHCONTF_FOLDERS;
  if svoShowHidden in AViewOptions then
    Result := Result or SHCONTF_INCLUDEHIDDEN;
end;

function GetPIDLDisplayName(APIDL: PItemIDList; AShowFullPath: Boolean = False): string;
var
  AParentIFolder: IShellFolder;
  AStrRet: TStrRet;
  ATempPIDL: PItemIDList;
  I: Integer;
begin
  Result := '';
  if AShowFullPath then
  begin
    Result := GetPidlName(APIDL);
    if Result <> '' then
      Exit;
  end;
  AParentIFolder := GetDesktopIShellFolder;
  for I := 1 to GetPidlItemsCount(APIDL) + Integer(AShowFullPath) - 1 do
  begin
    ATempPIDL := cxMalloc.Alloc(APIDL^.mkid.cb + SizeOf(SHITEMID));
    FillChar(ATempPIDL^, APIDL^.mkid.cb + SizeOf(SHITEMID), 0);
    CopyMemory(ATempPIDL, APIDL, APIDL^.mkid.cb);
    Integer(APIDL) := Integer(APIDL) + APIDL^.mkid.cb;

    if AShowFullPath then
    begin
      if AParentIFolder.GetDisplayNameOf(ATempPIDL, SHGDN_INFOLDER, AStrRet) <> S_OK then
        Break;
      if Result <> '' then
        Result := Result + '\';
      Result := Result + GetTextFromStrRet(AStrRet, APIDL);
    end;

    AParentIFolder.BindToObject(ATempPIDL, nil, IID_IShellFolder, Pointer(AParentIFolder));
    DisposePidl(ATempPIDL);
  end;

  if not AShowFullPath and (AParentIFolder.GetDisplayNameOf(APIDL, SHGDN_NORMAL, AStrRet) = S_OK) then
    Result := GetTextFromStrRet(AStrRet, APIDL);
end;

function InternalParseDisplayName(AParentIFolder: IShellFolder;
  ADisplayName: string; AViewOptions: TcxShellViewOptions): PItemIDList;
var
  AAttributes, AFetchedItemCount, AParsedCharCount: ULONG;
  AFlags: DWORD;
  AIEnumIDList: IEnumIDList;
//  AStrRet: TStrRet;
  ATempPIDL: PItemIDList;
begin
  Result := nil;
  AAttributes := SFGAO_HIDDEN or SFGAO_FOLDER;
  AParentIFolder.ParseDisplayName(0, nil, StringToOleStr(ADisplayName),
    AParsedCharCount, Result, AAttributes);
  if Result <> nil then
  begin
    if not CheckViewOptions(AViewOptions, AAttributes) then
      Result := nil;
    Exit;
  end;

  AFlags := GetShellEnumObjectsFlags(AViewOptions);
  if (AParentIFolder.EnumObjects(0, AFlags, AIEnumIDList) = S_OK) and
    Assigned(AIEnumIDList) then
  begin
    ADisplayName := AnsiUpperCase(ADisplayName);
    while AIEnumIDList.Next(1, ATempPIDL, AFetchedItemCount) = NOERROR do
    begin
//      FillChar(AStrRet, SizeOf(AStrRet), 0);
//      AParentIFolder.GetDisplayNameOf(ATempPIDL, SHGDN_INFOLDER, AStrRet);
//      if AnsiUpperCase(GetTextFromStrRet(AStrRet, ATempPIDL)) = ADisplayName then
      if AnsiUpperCase(GetShellItemDisplayName(AParentIFolder, ATempPIDL, True)) = ADisplayName then
      begin
        Result := ATempPIDL;
        Break;
      end
      else
        DisposePidl(ATempPIDL);
    end;
  end;
end;

function PathToAbsolutePIDL(APath: string; ARoot: TcxCustomShellRoot;
  AViewOptions: TcxShellViewOptions; ACheckIsSubPath: Boolean = True): PItemIDList;

  function InternalPathToAbsolutePIDL: PItemIDList;
  var
    ACSIDL: Integer;
    APathType: TcxShellObjectPathType;
    ATempPIDL: PItemIDList;
  begin
    Result := nil;
    APathType := CheckShellObjectPath(APath, AnsiUpperCase(GetPidlName(ARoot.Pidl)), False);
    case APathType of
      sptIncorrect:
        Exit;
      sptAbsolutePhysical, sptUNC, sptVirtual:
        Result := InternalParseDisplayName(GetDesktopIShellFolder, APath, AViewOptions);
      sptInternalAbsoluteVirtual, sptInternalRelativeVirtual:
        Result := ShellObjectInternalVirtualPathToPIDL(APath, ARoot, AViewOptions);
      sptRelativePhysical:
        begin
          ATempPIDL := InternalParseDisplayName(ARoot.ShellFolder, APath, AViewOptions);
          if ATempPIDL <> nil then
          begin
            Result := ConcatenatePidls(ARoot.Pidl, ATempPIDL);
            DisposePidl(ATempPIDL);
            Exit;
          end;

          for ACSIDL := CSIDL_DESKTOP to CSIDL_HISTORY do
            with cxShellSpecialFolderInfoTable[ACSIDL] do
              if (PIDL <> nil) and (PIDLUpperCaseDisplayName = APath) and
                CheckViewOptions(AViewOptions, Attributes) then
              begin
                Result := GetPidlCopy(PIDL);
                Break;
              end;
        end;
    end;
  end;

begin
  CheckShellRoot(ARoot);

  if APath = '' then
    Result := GetPidlCopy(ARoot.Pidl)
  else
  begin
    APath := AnsiUpperCase(APath);
    Result := InternalPathToAbsolutePIDL;
  end;

  if (Result <> nil) and ACheckIsSubPath and not IsSubPath(ARoot.Pidl, Result) then
  begin
    DisposePidl(Result);
    Result := nil;
  end;
end;

function ShellObjectInternalVirtualPathToPIDL(APath: string;
  ARoot: TcxCustomShellRoot; AViewOptions: TcxShellViewOptions): PItemIDList;
var
  AAttributes: UINT;
  AFetchedItemCount: ULONG;
  AFlags: DWORD;
  AIEnumIDList: IEnumIDList;
  AParentIFolder: IShellFolder;
  AStrRet: TStrRet;
  ATempPIDL, ATempPIDL1, ATempPIDL2: PItemIDList;
  I: Integer;
  S: string;
begin
  Result := nil;

  if Copy(APath, 1, cxShellObjectInternalVirtualPathPrefixLength) = cxShellObjectInternalAbsoluteVirtualPathPrefix then
  begin
    AParentIFolder := GetDesktopIShellFolder;
    ATempPIDL := nil;
  end
  else
  begin
    AParentIFolder := ARoot.ShellFolder;
    ATempPIDL := GetPidlCopy(ARoot.Pidl);
  end;
  APath := Copy(APath, cxShellObjectInternalVirtualPathPrefixLength + 2,
    Length(APath) - cxShellObjectInternalVirtualPathPrefixLength - 1);
  if APath = '' then
  begin
    Result := CreateEmptyPidl;
    Exit;
  end;

  repeat
    I := Pos('\', APath);
    if I = 0 then
    begin
      S := APath;
      APath := '';
    end
    else
    begin
      S := Copy(APath, 1, I - 1);
      APath := Copy(APath, I + 1, Length(APath) - I);
    end;

    AFlags := GetShellEnumObjectsFlags(AViewOptions);
    if (AParentIFolder.EnumObjects(0, AFlags, AIEnumIDList) <> S_OK) or
      not Assigned(AIEnumIDList) then
    begin
      DisposePidl(ATempPIDL);
      Exit;
    end;
    while AIEnumIDList.Next(1, ATempPIDL1, AFetchedItemCount) = NOERROR do
    begin
      FillChar(AStrRet, SizeOf(AStrRet), 0);
      AParentIFolder.GetDisplayNameOf(ATempPIDL1, SHGDN_INFOLDER, AStrRet);
      if AnsiUpperCase(GetTextFromStrRet(AStrRet, ATempPIDL1)) = S then
      begin
        if APath = '' then
        begin
          Result := ConcatenatePidls(ATempPIDL, ATempPIDL1);
          DisposePidl(ATempPIDL);
          DisposePidl(ATempPIDL1);
          Exit;
        end;
        AAttributes := SFGAO_FOLDER;
        AParentIFolder.GetAttributesOf(1, ATempPIDL1, AAttributes);
        if AAttributes and SFGAO_FOLDER = 0 then
        begin
          DisposePidl(ATempPIDL);
          DisposePidl(ATempPIDL1);
          Exit;
        end;
        AParentIFolder.BindToObject(ATempPIDL1, nil, IID_IShellFolder, Pointer(AParentIFolder));
        ATempPIDL2 := ATempPIDL;
        ATempPIDL := ConcatenatePidls(ATempPIDL, ATempPIDL1);
        DisposePidl(ATempPIDL1);
        DisposePidl(ATempPIDL2);
        Break;
      end;
    end;
  until I = 0;
end;

procedure PrepareShellSpecialFolderInfoTable;
var
  ACSIDL: Integer;
  ADesktopIFolder: IShellFolder;
  ATempPIDL: PItemIDList;
begin
  ADesktopIFolder := GetDesktopIShellFolder;
  for ACSIDL := CSIDL_DESKTOP to CSIDL_HISTORY do
    with cxShellSpecialFolderInfoTable[ACSIDL] do
    begin
      if SHGetSpecialFolderLocation(0, ACSIDL, PIDL) <> S_OK then
      begin
        Attributes := 0;
        PIDL := nil;
        PIDLDisplayName := '';
        PIDLName := '';
        PIDLUpperCaseDisplayName := '';
        Continue;
      end;

      PIDLDisplayName := GetPIDLDisplayName(PIDL);
      PIDLUpperCaseDisplayName := AnsiUpperCase(PIDLDisplayName);
      PIDLName := AnsiUpperCase(GetPidlName(PIDL));

      if PIDL <> nil then
      begin
        Attributes := SFGAO_HIDDEN or SFGAO_FOLDER;
        ATempPIDL := GetLastPidlItem(PIDL);
        if ADesktopIFolder.GetAttributesOf(1, ATempPIDL, Attributes) <> NOERROR then
          raise EcxEditError.Create('');
        Attributes := Attributes and (SFGAO_HIDDEN or SFGAO_FOLDER);
      end;
    end;
end;

{ TcxInnerShellListView }

constructor TcxInnerShellListView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  BorderStyle := bsNone;
  ControlStyle := ControlStyle + [csDoubleClicks];
  ParentColor := False;
  ParentFont := True;
  ShowColumnHeaders := True;
  FPressedHeaderItemIndex := -1;
  FCanvas := TcxCanvas.Create(inherited Canvas);
  inherited OnChange := ChangeHandler;
end;

destructor TcxInnerShellListView.Destroy;
begin
  FreeAndNil(FCanvas);
  if FHeaderHandle <> 0 then
  begin
    SetWindowLong(FHeaderHandle, GWL_WNDPROC, Integer(FDefHeaderProc));
    FHeaderHandle := 0;
  end;
  FreeObjectInstance(FHeaderInstance);
  inherited Destroy;
end;

procedure TcxInnerShellListView.DefaultHandler(var Message);
begin
  if (Container = nil) or not Container.InnerControlDefaultHandler(TMessage(Message)) then
    inherited DefaultHandler(Message);
end;

procedure TcxInnerShellListView.DragDrop(Source: TObject; X, Y: Integer);
begin
  if Container <> nil then
    Container.DragDrop(Source, Left + X, Top + Y);
end;

function TcxInnerShellListView.ExecuteAction(Action: TBasicAction): Boolean;
begin
  Result := inherited ExecuteAction(Action) or
    TcxCustomDataBindingAccess(Container.FDataBinding).ExecuteAction(Action);
end;

function TcxInnerShellListView.UpdateAction(Action: TBasicAction): Boolean;
begin
  Result := inherited UpdateAction(Action) or
    TcxCustomDataBindingAccess(Container.FDataBinding).UpdateAction(Action);
end;

{$IFDEF DELPHI5}
function TcxInnerShellListView.CanFocus: Boolean;
begin
  Result := Container.CanFocusEx;
end;
{$ENDIF}

procedure TcxInnerShellListView.Click;
begin
  inherited Click;
  if Container <> nil then
    Container.Click;
end;

procedure TcxInnerShellListView.DblClick;
begin
  inherited DblClick;
  if Container <> nil then
    Container.DblClick;
end;

procedure TcxInnerShellListView.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if Container.IconOptions.AutoArrange then
    Params.Style := Params.Style or LVS_AUTOARRANGE
  else
    Params.Style := Params.Style and not LVS_AUTOARRANGE;
  if not Container.ShowColumnHeaders then
    Params.Style := Params.Style or LVS_NOCOLUMNHEADER;
end;

function TcxInnerShellListView.DoCompare(AItem1, AItem2: TcxShellFolder;
  out ACompare: Integer): Boolean;
begin
  Result := Container.DoCompare(AItem1, AItem2, ACompare);
end;

function TcxInnerShellListView.DoMouseWheel(Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
  Result := (Container <> nil) and Container.DoMouseWheel(Shift,
    WheelDelta, MousePos);
  if not Result then
    inherited DoMouseWheel(Shift, WheelDelta, MousePos);
end;

procedure TcxInnerShellListView.DragOver(Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  if Container <> nil then
    Container.DragOver(Source, Left + X, Top + Y, State, Accept);
end;

procedure TcxInnerShellListView.DrawHeader;
var
  I: Integer;
begin
  Canvas.Brush.Color := clBtnFace;
  Canvas.Font := Font;
  Canvas.Font.Color := clBtnText;
  for I := 0 to Columns.Count do
    DrawHeaderSection(FHeaderHandle, I, Canvas, Container.LookAndFeel, SmallImages);
end;

function TcxInnerShellListView.GetPopupMenu: TPopupMenu;
begin
  if Container = nil then
    Result := inherited GetPopupMenu
  else
    Result := Container.GetPopupMenu;