iconlibrary.pas

灰鸽子VIP1.2经典源代码

//             ____                 __    _ __
//            /  _/________  ____  / /   (_) /_  _________ ________  __
//            / // ___/ __ \/ __ \/ /   / / __ \/ ___/ __ `/ ___/ / / /
//          _/ // /__/ /_/ / / / / /___/ / /_/ / /  / /_/ / /  / /_/ /
//         /___/\___/\____/_/ /_/_____/_/_.___/_/   \__,_/_/   \__, /
//                                                            /____/

(*******************************************************************************
* IconTools 1.5                                                                *
*                                                                              *
* This file is part of the IconTools class library                             *
*                                                                              *
********************************************************************************
*                                                                              *
* If you find bugs, has ideas for missing featurs, feel free to contact me     *
*                           [e-mail]                                     *
*                                                                              *
* The latest version of TShelltree can be found at:                            *
*     http://members.tripod.com/~JPStotz/IconTools/IconTools.html              *
********************************************************************************
* Date last modified:   May 12, 1999                                           *
*******************************************************************************)

unit IconLibrary;

interface

{.$Define Overseer}

{$IfDEF Overseer}
  {$DEFINE Writer16}
{$EndIf}

uses
{$IfDEF Overseer}
  udbg,
{$EndIf}
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IconTools, IconTypes, ShellAPI;

(********************************************************************)
(**                      TIconLibrary declaration                  **)
(********************************************************************)

type
  TIconLibrary = class
  private
    FFilename : String;
  protected
    FIcons : TStringList;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure LoadFromFile(Filename : String);
    procedure SaveToFile(Filename : String);

    property Icons : TStringList read FIcons;
    property Filename : String read FFilename;
  end;

(********************************************************************)
(**                TICLReader abstract declaration                 **)
(********************************************************************)

type
  TICLReader = class
  private
  protected
    FFilename : String;
    FIcons : TStringList;
  public
    constructor Create(Filename : String); virtual;
    destructor Destroy; override;
    function Execute : Boolean; virtual; abstract;
    property Icons : TStringList read FIcons;
  end;

(********************************************************************)
(**                    T32BitReader declaration                    **)
(********************************************************************)

type
  T32BitReader = class(TICLReader)
  private
  protected
    Instance : THandle;
    FreeLib  : Boolean;
    procedure IconResFound(ResName : PChar);
  public
    constructor Create(Filename : String); override;
    function Execute : Boolean; override;
    destructor Destroy; override;
  end;

(********************************************************************)
(**                     TICL32Icon declaration                     **)
(********************************************************************)

type
  TICL32Icon = class(TResourceIcon)
  private

  protected
    FIconData : TMemoryStream;
    procedure BufferIconData;
    procedure LoadIconResInfos(Stream : TStream;Var Valid : Boolean;Var Count : Word); override;
    function  GetHIcon(Index : Word) : HIcon; override;
  public
    procedure WriteIconDataToStream(Stream : TStream;Index : Integer); override;
    destructor Destroy; override;
  end;

(********************************************************************)
(**                    T16BitReader declaration                    **)
(********************************************************************)

type
  T16BitReader = class(TICLReader)
  private
    FStream : TStream;
    FAlignShift         : Word;
    FWin16Offset        : Word;
    FResourceTableStart : DWord;
    FNamestableStart    : DWord;
    FIconCount          : Word;
    FGroupIconCount     : Word;
    FICLName            : String;
    FIconsRes           : PNameRecArray;
    FGroupIconsRes      : PNameRecArray;
  protected
    procedure ReadFileHeader;
    procedure ReadResourceTable;
    procedure ReadTypeInfo;
    procedure ReadResourceNames;
  public
    constructor Create(AFilename : String); override;
    destructor Destroy; override;
    function Execute : Boolean; override;
    function GetResourceIndex(ID : Word;GroupIcon : Boolean) : Integer;
    procedure ReadResource(Index : Word;GroupIcon : Boolean;Stream : TStream;Var ResName : String);
    property IconCount : Word read FGroupIconCount;
  end;

(********************************************************************)
(**                    T16BitWriter declaration                    **)
(********************************************************************)

type
  T16BitWriter = class
  private
    FShiftAlignOffs : DWord;
    FNamesTableOffs : DWord;
    FOfs_Icons  : PDWordArray;
    FOfs_GIcons : PDWordArray;
    FIcons      : Integer;
    FIconLib    : TIconLibrary;
    FAlignShift : Word;
    FStream : TMemoryStream;
    Null    : ARRAY[1..256] OF Char;
  protected
    procedure WriteShiftAlign;
    procedure UpdateTableEntry(EntryPos : DWord;StartOffset,EndOffset : DWord);
    procedure WriteHeader;
    procedure WriteResTable;
    procedure WriteNameTable;
    procedure WriteIconData;
    procedure Align;
    property Stream : TMemoryStream read FStream;
  public
    constructor Create(AIconLib : TIconLibrary);
    destructor Destroy; override;
    procedure SaveToFile(Filename : String);
    property IconLib : TIconLibrary read FIconLib;
  end;

(********************************************************************)
(**                      TICL16Icon declaration                    **)
(********************************************************************)

type
  TICL16Icon = class(TMultiIcon)
  private
    FResName : String;
    FICLReader : T16BitReader;
    function GeTICL16IconResInfo(Index : Word) : TFileIconResInfo;
  protected
    Icons : TMemoryStream;
    function GetHIcon(Index : Word) : HIcon; override;
    function GetIconSize(Index : Word) : TSize; override;
    procedure LoadIconResInfos(Stream : TStream;Var Valid : Boolean;Var Count : Word);override;
    function GetIconResInfo(Index : Word) : TIconResInfo; override;
  public
    procedure WriteIconDataToStream(Stream : TStream;Index : Integer); override;
    constructor ICLCreate(ICLReader : T16BitReader;Index : Word);
    destructor Destroy; override;
    property ResName : String read FResName;
    property ICLIconResInfo[Index : Word] : TFileIconResInfo read GeTICL16IconResInfo;
  end;

implementation

{$R-}

type
  EICLReadError  = class (Exception);
  EICLWriteError = class (Exception);

const
  IMAGE_DOS_SIGNATURE    = $5A4D;       { MZ }
  IMAGE_IM_SIGNATURE     = $4D49;       { IM }
  IMAGE_OS2_SIGNATURE    = $454E;       { NE }
  IMAGE_W32_SIGNATURE    = $4550;       { PE }
  IMAGE_NAMETABLE_ICL  : ARRAY[0..3] OF Char = 'ICL'+#0;

  E_R_InvWin16Offs    = 'Invalid Windows 16 Offset';
  E_R_InvWin16Header  = 'Invalid Windows 16 Header';
  E_R_NotValid16Bit   = 'Not a valid ICL File';
  E_R_NoResources     = 'No Resources in file';
  E_R_NoNamesTable    = 'Names Table not found';
  E_R_IconResNotFound = 'Icon Resource Not Found';
  E_R_ResTableError   = 'ResourceTable has an Error';
  E_W_NoIcons         = 'Unable to write Iconlibrary with no icons';
  E_W_TooManyIcons    = 'Iconlibraries with more than 32767 are not possible';

procedure ICLReadError(const ErrMsg: string);
begin
  raise EICLReadError.Create(ErrMsg);
end;

procedure ICLWriteError(const ErrMsg: string);
begin
  raise EICLReadError.Create(ErrMsg);
end;

function IsValidLib(Filename : String;Var Is32Bit : Boolean) : Boolean;
Var
  F : TFileStream;
  Sig : Word;
begin
  Result:=False;
  F:=TFileStream.Create(Filename,fmOpenRead or fmShareDenyWrite);
  With F DO
  try
    Read(Sig,SizeOf(Sig));
    IF (Sig <>IMAGE_DOS_SIGNATURE) Then exit;
    Seek($3C,soFromBeginning);
    Read(Sig,SizeOf(Sig));
    Seek(Sig,soFromBeginning);
    Read(Sig,SizeOf(Sig));
    Result:=(Sig = IMAGE_W32_SIGNATURE) OR (Sig = IMAGE_OS2_SIGNATURE);
    Is32Bit:=(Sig = IMAGE_W32_SIGNATURE);
  finally
    F.Free;
  end;
end;

(********************************************************************)
(**                  TIconLibrary implementation                   **)
(********************************************************************)

constructor TIconLibrary.Create;
begin
  FIcons := TStringList.Create;
end;

destructor TIconLibrary.Destroy;
Var
  I : Integer;
begin
  FOR I:=1 TO Icons.Count Do TMultiIcon(Icons.Objects[I-1]).Free;
  FIcons.Free;
end;

procedure TIconLibrary.LoadFromFile(Filename : String);
Var
  LoadedIcons,IconCount : Integer;
  Is32Bit : Boolean;
  Reader : TICLReader;
begin
  LoadedIcons:=0;
  IconCount:=ExtractIcon(HInstance,PChar(Filename),dword(-1));
  IF (IconCount=0) Then exit;
  IF NOT IsValidLib(Filename,Is32Bit) Then exit;
  FFilename:=Filename;
  IF NOT Is32Bit Then
    Reader:=T16BitReader.Create(Filename)
  else
    Reader:=T32BitReader.Create(Filename);
  try
    IF Reader.Execute Then begin
      LoadedIcons:=Reader.Icons.Count;
      Icons.Assign(Reader.Icons);
    end;
  finally
    Reader.Free;
  end;
  IF LoadedIcons<>IconCount Then begin
    beep;
  end;  
end;

procedure TIconLibrary.SaveToFile(Filename : String);
Var
  ICLFile  : T16BitWriter;
begin
  IF Icons.Count=0 Then ICLWriteError(E_W_NoIcons);
  IF Icons.Count>=$8000 Then ICLWriteError(E_W_TooManyIcons);
  ICLFile:=T16BitWriter.Create(self);
  try
    ICLFile.SaveToFile(Filename);
  finally
    ICLFile.Free;
  end;
end;

(********************************************************************)
(**                  TICLReader implementation                     **)
(********************************************************************)

constructor TICLReader.Create(Filename : String);
begin
  FIcons:=TStringList.Create;
  FFilename:=Filename;
end;

destructor TICLReader.Destroy;
begin
  IF Assigned(FIcons) Then FIcons.free;
  inherited;
end;

(********************************************************************)
(**                 T32BitReader implementation                    **)
(********************************************************************)

function EnumResNameProc(hModule : THandle;lpszType,lpszName : PChar;lParam : lParam) : Bool; stdcall;
begin
  Result:=True;
  T32BitReader(lParam).IconResFound(lpszName);
end;

constructor T32BitReader.Create(Filename : String);
begin
  inherited;
  FreeLib:=False;
  Instance:=0;
end;

function T32BitReader.Execute : Boolean;
begin
  Result:=False;
  try
    Instance:= windows.LoadLibraryEx(PChar(FFilename), 0, LOAD_LIBRARY_AS_DATAFILE);
  finally
  end;
  IF Instance=0 then exit;
  FreeLib:=True;
  Result:=True;
  EnumResourcenames(Instance,RT_GROUP_ICON,@EnumResNameProc,Integer(self));
end;

procedure T32BitReader.IconResFound(ResName : PChar);
Var
  Ico : TICL32Icon;
  IsID : Boolean;
  RName : String;
begin
  IsID:=IsBadStringPtr(ResName,63);
  IF IsID Then begin
    Ico:=TICL32Icon.CreateFromID(Instance,Loword(Integer(ResName)));
    RName:=InttoStr(Integer(Resname));
  end else begin
    Ico:=TICL32Icon.Create(Instance,Strpas(ResName));
    Rname:=Strpas(ResName);
  end;
  FIcons.AddObject(RName,Ico);
end;

destructor T32BitReader.Destroy;
begin
  inherited;
  IF FreeLib Then FreeLibrary(Instance);
end;

(********************************************************************)
(**                   TICL32Icon implementation                    **)
(********************************************************************)

procedure TICL32Icon.BufferIconData;
Var
  I : Integer;
  RStream : TResourceStream;
  SPos : DWord;
begin
  FIconData:=TMemoryStream.Create;
  With FIconData DO begin
    Clear;
    Seek(IconCount*SizeOf(DWord),soFromBeginning);
    FOR I:=1 TO IconCount DO
      With PResourceIconDirList(IconDirList)^[I-1] do begin
        RStream:=TResourceStream.CreateFromID(Instance,ID,RT_ICON);
        try
          SPos:=Position;
          Position:=SizeOf(DWord)*(I-1);
          Write(SPos,SizeOf(DWord));
          Position:=SPos;
          ResInfo.BytesInRes:=RStream.Size;
          CopyFrom(RStream,RStream.Size);
        finally
          RStream.Free;
        end;
      end;
  end;
end;

function TICL32Icon.GetHIcon(Index : Word) : HIcon;
Var
  DW : DWord;
begin
  Result:=0;
  IF Index>=IconCount Then exit;
  IF IconHandleList^[Index]=0 Then begin
    with ResourceIconResInfo[Index] do begin
      FIconData.Position:=Index*SizeOf(DWord);
      FIcondata.Read(DW,SizeOf(DWord));
      FIconData.Position:=DW;
      Result:=CreateIconFromStream(FIconData,ResInfo.BytesInRes,ResInfo);
      IconHandleList^[Index]:=Result;
    end;
  end else
    Result:=IconHandleList^[Index];
end;

procedure TICL32Icon.WriteIconDataToStream(Stream : TStream;Index : Integer);
Var
  DW : DWord;
begin
  IF Index>=IconCount Then exit;
  with ResourceIconResInfo[Index] do begin
    FIconData.Position:=Index*SizeOf(DWord);
    FIcondata.Read(DW,SizeOf(DWord));
    FIconData.Position:=DW;
    Stream.CopyFrom(FIconData,ResInfo.BytesInRes);
  end;
end;

procedure TICL32Icon.LoadIconResInfos(Stream : TStream;Var Valid : Boolean;Var Count : Word);
begin
  inherited;
  BufferIconData;
end;

destructor TICL32Icon.Destroy;
begin
  IF Assigned(FIconData) Then FIconData.Free;
  inherited;
end;

(********************************************************************)
(**                  T16BitReader implementation                   **)
(********************************************************************)

function T16BitReader.GetResourceIndex(ID : Word;GroupIcon : Boolean) : Integer;
Var
  Res : PNameRecArray;
  I,IMax : Integer;
begin
  Result:=-1;
  IF GroupIcon Then begin
    Res:=FGroupIconsRes;
    IMax:=FGroupIconCount;
  end else begin
    Res:=FIconsRes;
    IMax:=FIconCount;
  end;
  I:=0;
  While (I<IMax) DO begin
    IF (((Res^[I].rnID) XOR $8000)=ID) Then begin
      Result:=I;
      break;
    end;
    INC(I);
  end;
  IF Result>=0 Then exit;
  ICLReadError(E_R_IconResNotFound);
end;


procedure T16BitReader.ReadResource(Index : Word;GroupIcon : Boolean;
          Stream : TStream;Var ResName : String);
Var
  Namerec : TNameRec;
  ResStartPos : Longint;
  ResLength   : Longint;
begin
  IF GroupIcon Then NameRec:=FGroupIconsRes^[Index]
    else NameRec:=FIconsRes^[Index];
  ResName:=Format('%s %0.3d',[FICLName,Index+1]);
  ResStartPos:=NameRec.rnOffset shl FAlignShift;
  ResLength  :=NameRec.rnLength shl FAlignShift;
  FStream.Position:=ResStartPos;
  Stream.CopyFrom(FStream,ResLength);
end;

constructor T16BitReader.Create(AFilename : String);
begin
  inherited;
  FStream:=TFileStream.Create(AFilename,fmOpenRead or fmShareDenyWrite);
  FStream.Position:=0;
  FICLName:=ExtractFilename(AFilename);
  Delete(FICLName,Length(FICLName)-Length(ExtractFileExt(FICLname))+1,30);
end;