systemimagelist.pas

动态提示控件

end;

{$IFDEF DFS_COMPILER_4_UP}
function TdfsSystemImageList.GetFileInformation(const APidl: PItemIDList;
   Selected, Open: boolean; Attrs: TSystemFileAttributes;
   var Descr: string): integer;
begin
  Result := GetFileInfo(APidl, Selected, Open, SFA2API(Attrs), Attrs <> [], Descr);
end;
{$ELSE}
function TdfsSystemImageList.GetFileInformationPIDL(const APidl: PItemIDList;
   Selected, Open: boolean; Attrs: TSystemFileAttributes;
   var Descr: string): integer;
begin
  Result := GetFileInfoPIDL(APidl, Selected, Open, SFA2API(Attrs), Attrs <> [],
    Descr);
end;
{$ENDIF}

{$IFDEF DFS_COMPILER_4_UP}
function TdfsSystemImageList.GetFileInformation(SpecialItem: TShellItem;
   Selected, Open: boolean; Attrs: TSystemFileAttributes;
   var Descr: string): integer;
begin
  Result := GetFileInfo(SpecialItem, Selected, Open, SFA2API(Attrs), Attrs <> [],
    Descr);
end;
{$ELSE}
function TdfsSystemImageList.GetFileInformationSpecial(SpecialItem: TShellItem;
   Selected, Open: boolean; Attrs: TSystemFileAttributes;
   var Descr: string): integer;
begin
  Result := GetFileInfoSpecial(SpecialItem, Selected, Open, SFA2API(Attrs),
    Attrs <> [], Descr);
end;
{$ENDIF}


function TdfsSystemImageList.GetVersion: string;
begin
  Result := DFS_COMPONENT_VERSION;
end;

procedure TdfsSystemImageList.SetVersion(const Val: string);
begin
  { empty write method, just needed to get it to show up in Object Inspector }
end;

// Needed to support the "Save to bitmap" component editor.
procedure TdfsSystemImageList.SaveToStream(Stream: TStream);
var
  DIB1, DIB2: TBitmap;
  DC: HDC;
  S: TMemoryStream;

  procedure WriteDIB(BM: HBitmap);
    { The ImageList leaves its bitmap handle selected into a DC somewhere,
      so we can't select it into our own DC to copy from it.  The only safe
      operation is GetDIB (GetDIBits), which extracts the pixel bits without
      selecting the BM into a DC.  This code builds our own bitmap from
      those bits, then crops it to the minimum size before writing it out.}
  var
    BitsSize: DWORD;
    Header, Bits: PChar;
    DIBBits: Pointer;
    R: TRect;
    HeaderSize: DWORD;
    GlyphsPerRow, Rows: Integer;
  begin
    if BM = 0 then Exit;
    GetDIBSizes(BM, HeaderSize, BitsSize);
    GetMem(Header, HeaderSize + BitsSize);
    try
      Bits := Header + HeaderSize;
      GetDIB(BM, 0, Header^, Bits^);
      DIB1.Handle := CreateDIBSection(DC, PBitmapInfo(Header)^, DIB_RGB_COLORS,
         {$IFDEF DFS_COMPILER_2}
         DIBBits, NIL, 0);
         {$ELSE}
         DIBBits, 0, 0);
         {$ENDIF}
      System.Move(Bits^, DIBBits^, BitsSize);
      with PBitmapInfo(Header)^.bmiHeader do
      begin
        GlyphsPerRow := biWidth div Width;
        if GlyphsPerRow = 0 then Inc(GlyphsPerRow);
        if GlyphsPerRow > Count then GlyphsPerRow := Count;
        biWidth := GlyphsPerRow * Width;
        Rows := Count div GlyphsPerRow;
        if Count > Rows * GlyphsPerRow then Inc(Rows);
        biHeight := Rows * Height;
        R := Rect(0, 0, biWidth, biHeight);
      end;
      DIB2.Handle := CreateDIBSection(DC, PBitmapInfo(Header)^, DIB_RGB_COLORS,
         {$IFDEF DFS_COMPILER_2}
         DIBBits, NIL, 0);
         {$ELSE}
         DIBBits, 0, 0);
         {$ENDIF}
      DIB2.Canvas.CopyRect(R, DIB1.Canvas, R);
      DIB2.SaveToStream(S);
    finally
      FreeMem(Header);
    end;
  end;

begin
  DIB1 := nil;
  DIB2 := nil;
  DC := 0;
  S := TMemoryStream.Create;
  try
    DIB1 := TBitmap.Create;
    DIB2 := TBitmap.Create;
    DC := GetDC(0);
    WriteDIB(GetImageBitmap);
    Stream.WriteBuffer(S.Memory^, S.Size);
  finally
    ReleaseDC(0, DC);
    DIB1.Free;
    DIB2.Free;
    S.Free;
  end;
end;

{------------------------------------------------------------------------------}
{ Utility functions                                                            }
{------------------------------------------------------------------------------}

function GetValidHandle(ImgList: TdfsSystemImageList): HWND;
begin
  if assigned(ImgList) and assigned(ImgList.Owner) and
    (ImgList.Owner is TWinControl) and TWinControl(ImgList.Owner).HandleAllocated then
    Result := TWinControl(ImgList.Owner).Handle
  else if assigned(ImgList) and (ImgList.Owner is TControl) and
    (GetParentForm(TControl(ImgList.Owner)) <> NIL) and (GetParentForm(
    TControl(ImgList.Owner)).HandleAllocated) then
    Result := GetParentForm(TControl(ImgList.Owner)).Handle
  else if assigned(Application.MainForm) and
     Application.MainForm.HandleAllocated then
    Result := Application.MainForm.Handle
  else
    Result := 0;
end;


function SFA2API(Attrs: TSystemFileAttributes): DWORD;
const
  API_VALUES: array[TSystemFileAttribute] of DWORD = (
     FILE_ATTRIBUTE_READONLY, FILE_ATTRIBUTE_HIDDEN, FILE_ATTRIBUTE_SYSTEM,
     FILE_ATTRIBUTE_DIRECTORY, FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_NORMAL,
     FILE_ATTRIBUTE_TEMPORARY, FILE_ATTRIBUTE_COMPRESSED, FILE_ATTRIBUTE_OFFLINE);
var
  x: TSystemFileAttribute;
begin
  Result := 0;
  for x := Low(x) to High(x) do
    if x in Attrs then
      Result := Result or API_VALUES[x];
end;

function SI2API(Item: TShellItem): integer;
const
  {$IFNDEF DFS_COMPILER_4_UP}
  CSIDL_INTERNET        = $0001;
  CSIDL_INTERNET_CACHE  = $0020;
  CSIDL_COOKIES         = $0021;
  CSIDL_HISTORY         = $0022;
  {$ENDIF}
  API_VALUES: array[TShellItem] of integer = (
     CSIDL_DESKTOP, CSIDL_INTERNET, CSIDL_PROGRAMS, CSIDL_CONTROLS,
     CSIDL_PRINTERS, CSIDL_PERSONAL, CSIDL_FAVORITES, CSIDL_STARTUP,
     CSIDL_RECENT, CSIDL_SENDTO, CSIDL_BITBUCKET, CSIDL_STARTMENU, CSIDL_DRIVES,
     CSIDL_NETWORK, CSIDL_FONTS, CSIDL_TEMPLATES, CSIDL_INTERNET_CACHE,
     CSIDL_COOKIES, CSIDL_HISTORY);

begin
  Result := API_VALUES[Item];
end;

function GeTdfsSystemImageList(Large: boolean): HImageList;
var
  SFI: TSHFileInfo;
begin
  // SHGetFileInfo puts the requested information in the SFI variable, but it
  // also can return the handle of the system image list.  We just pass an
  // empty file because we aren't interested in it, only the returned handle.
  if Large then
    Result := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
                            SHGFI_SYSICONINDEX or SHGFI_LARGEICON)
  else
    Result := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
                            SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
end;

const
  SELECTED_FLAG: array[boolean] of DWORD = (0, SHGFI_SELECTED);
  OPEN_FLAG: array[boolean] of DWORD = (0, SHGFI_OPENICON);

function GetIconIndex(const APath: string; Selected, Open: boolean;
   Attrs: DWORD; AlwaysUseAttrs: boolean): integer;
var
  SFI: TSHFileInfo;
begin
  if (not AlwaysUseAttrs) and (FileExists(APath) or DirectoryExists(APath)) then
    // If the file or directory exists, just let Windows figure out it's attrs.
    SHGetFileInfo(PChar(APath), 0, SFI, SizeOf(TSHFileInfo),
       SHGFI_SYSICONINDEX or OPEN_FLAG[Open] or SELECTED_FLAG[Selected])
  else
    // File doesn't exist, so Windows doesn't know what to do with it.  We have
    // to tell it by passing the attributes we want, and specifying the
    // SHGFI_USEFILEATTRIBUTES flag so that the function knows to use them.
    SHGetFileInfo(PChar(APath), Attrs, SFI, SizeOf(TSHFileInfo),
       SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or OPEN_FLAG[Open] or
       SELECTED_FLAG[Selected]);
  Result := SFI.iIcon;
end;

{$IFDEF DFS_COMPILER_4_UP}
function GetIconIndex(const APidl: PItemIDList; Selected, Open: boolean
{$ELSE}
function GetIconIndexPIDL(const APidl: PItemIDList; Selected, Open: boolean
{$ENDIF}
   ): integer;
var
  SFI: TSHFileInfo;
begin
  SHGetFileInfo(PAnsiChar(APidl), 0, SFI, SizeOf(TSHFileInfo),
     SHGFI_PIDL or SHGFI_SYSICONINDEX or OPEN_FLAG[Open] or
     SELECTED_FLAG[Selected]);
  Result := SFI.iIcon;
end;

{$IFDEF DFS_COMPILER_4_UP}
function GetIconIndex(SpecialItem: TShellItem; Selected, Open: boolean
{$ELSE}
function GetIconIndexSpecial(SpecialItem: TShellItem; Selected, Open: boolean
{$ENDIF}
  ): integer;
var
  pidl: PItemIDList;
  ShellMalloc: IMalloc;
begin
  SHGetMalloc(ShellMalloc);
  SHGetSpecialFolderLocation(GetValidHandle(NIL), SI2API(SpecialItem),
     pidl);
  try
    {$IFDEF DFS_COMPILER_4_UP}
    Result := GetIconIndex(pidl, Selected, Open);
    {$ELSE}
    Result := GetIconIndexPIDL(pidl, Selected, Open);
    {$ENDIF}
  finally
    ShellMalloc.Free(pidl);
    {$IFNDEF DFS_NO_COM_CLEANUP} // Delphi 2 won't free automatically, 3 and up will
    ShellMalloc.Release;
    {$ENDIF}
  end;
end;


function GetFileInfo(const APath: string; Selected, Open: boolean; Attrs: DWORD;
   AlwaysUseAttrs: boolean; var Descr: string): integer;
const
  SELECTED_FLAG: array[boolean] of DWORD = (0, SHGFI_SELECTED);
var
  SFI: TSHFileInfo;
begin
  if FileExists(APath) or DirectoryExists(APath) then
    SHGetFileInfo(PChar(APath), Attrs, SFI, SizeOf(TSHFileInfo),
       SHGFI_TYPENAME or SHGFI_SYSICONINDEX or OPEN_FLAG[Open] or
       SELECTED_FLAG[Selected])
  else
    SHGetFileInfo(PChar(APath), Attrs, SFI, SizeOf(TSHFileInfo),
       SHGFI_TYPENAME or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES or
       OPEN_FLAG[Open] or SELECTED_FLAG[Selected]);
  Descr := SFI.szTypeName;
  Result := SFI.iIcon;
end;

{$IFDEF DFS_COMPILER_4_UP}
function GetFileInfo(const APidl: PItemIDList; Selected, Open: boolean;
{$ELSE}
function GetFileInfoPIDL(const APidl: PItemIDList; Selected, Open: boolean;
{$ENDIF}
   Attrs: DWORD; AlwaysUseAttrs: boolean; var Descr: string): integer;
var
  SFI: TSHFileInfo;
begin
  SHGetFileInfo(PAnsiChar(APidl), 0, SFI, SizeOf(TSHFileInfo),
     SHGFI_PIDL or SHGFI_TYPENAME or SHGFI_SYSICONINDEX or OPEN_FLAG[Open] or
     SELECTED_FLAG[Selected]);
  Descr := SFI.szTypeName;
  Result := SFI.iIcon;
end;

{$IFDEF DFS_COMPILER_4_UP}
function GetFileInfo(SpecialItem: TShellItem; Selected, Open: boolean;
{$ELSE}
function GetFileInfoSpecial(SpecialItem: TShellItem; Selected, Open: boolean;
{$ENDIF}
   Attrs: DWORD; AlwaysUseAttrs: boolean; var Descr: string): integer;
var
  pidl: PItemIDList;
  ShellMalloc: IMalloc;
begin
  SHGetMalloc(ShellMalloc);
  SHGetSpecialFolderLocation(GetValidHandle(NIL), SI2API(SpecialItem),
     pidl);
  try
    {$IFDEF DFS_COMPILER_4_UP}
    Result := GetFileInfo(pidl, Selected, Open, Attrs, AlwaysUseAttrs, Descr);
    {$ELSE}
    Result := GetFileInfoPIDL(pidl, Selected, Open, Attrs, AlwaysUseAttrs, Descr);
    {$ENDIF}
  finally
    ShellMalloc.Free(pidl);
    {$IFNDEF DFS_NO_COM_CLEANUP} // Delphi 2 won't free automatically, 3 and up will
    ShellMalloc.Release;
    {$ENDIF}
  end;
end;


end.