Delphi 5 for Professionals/DELPHI5.iso/Runimage/Delphi50/Demos/Resxplor/exeimage.pas

Pascal/Delphi Source File | 1999-08-11 | 20.7 KB | 805 lines

unit ExeImage;

interface

uses
  TypInfo, Classes, SysUtils, Windows, Graphics, RXTypes;

type

{ Exceptions }

  EExeError = class(Exception);

{ Forward Declarations }

  TResourceItem = class;
  TResourceClass = class of TResourceItem;
  TResourceList = class;

{ TExeImage }

  TExeImage = class(TComponent)
  private
    FFileName: string;
    FFileHandle: THandle;
    FFileMapping: THandle;
    FFileBase: Pointer;
    FDosHeader: PIMAGE_DOS_HEADER;
    FNTHeader: PIMAGE_NT_HEADERS;
    FResourceList: TResourceList;
    FIconResources: TResourceItem;
    FCursorResources: TResourceItem;
    FResourceBase: Longint;
    FResourceRVA: Longint;
    function GetResourceList: TResourceList;
    function GetSectionHdr(const SectionName: string;
      var Header: PIMAGE_SECTION_HEADER): Boolean;
  public
    constructor CreateImage(AOwner: TComponent; const AFileName: string);
    destructor Destroy; override;
    property FileName: string read FFileName;
    property Resources: TResourceList read GetResourceList;
  end;

{ TResourceItem }

  TResourceItem = class(TComponent)
  private
    FList: TResourceList;
    FDirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
    function DataEntry: PIMAGE_RESOURCE_DATA_ENTRY;
    function FExeImage: TExeImage;
    function FirstChildDirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
    function GetResourceItem(Index: Integer): TResourceItem;
    function GetResourceType: TResourceType;
  protected
    function GetName: string; virtual;
    function GetResourceList: TResourceList; virtual;
  public
    constructor CreateItem(AOwner: TComponent; ADirEntry: Pointer);
    function IsList: Boolean; virtual;
    function Offset: Integer;
    function Size: Integer;
    function RawData: Pointer;
    function ResTypeStr: string;
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream); virtual;
    property Items[Index: Integer]: TResourceItem read GetResourceItem; default;
    property List: TResourceList read GetResourceList;
    property Name: string read GetName;
    property ResType: TResourceType read GetResourceType;
  end;

{ TIconResource }

  TIconResource = class(TResourceItem)
  protected
    function GetResourceList: TResourceList; override;
  public
    function IsList: Boolean; override;
  end;

{ TIconResEntry }

  TIconResEntry = class(TResourceItem)
  protected
    FResInfo: PIconResInfo;
    function GetName: string; override;
    procedure AssignTo(Dest: TPersistent); override;
  public
    procedure SaveToStream(Stream: TStream); override;
  end;

{ TCursorResource }

  TCursorResource = class(TIconResource)
  protected
    function GetResourceList: TResourceList; override;
  end;

{ TCursorResEntry }

  TCursorResEntry = class(TIconResEntry)
  protected
    FResInfo: PCursorResInfo;
    function GetName: string; override;
  end;

{ TBitmapResource }

  TBitMapResource = class(TResourceItem)
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    procedure SaveToStream(Stream: TStream); override;
  end;

{ TStringResource }

  TStringResource = class(TResourceItem)
  protected
    procedure AssignTo(Dest: TPersistent); override;
  end;

{ TMenuResource }

  TMenuResource = class(TResourceItem)
  private
    FNestStr: string;
    FNestLevel: Integer;
    procedure SetNestLevel(Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    property NestLevel: Integer read FNestLevel write SetNestLevel;
    property NestStr: string read FNestStr;
  end;

{ TResourceList }

  TResourceList = class(TComponent)
  protected
    FList: TList;
    FResDir: PIMAGE_RESOURCE_DIRECTORY;
    FExeImage: TExeImage;
    FResType: Integer;
    function List: TList; virtual;
    function GetResourceItem(Index: Integer): TResourceItem;
  public
    constructor CreateList(AOwner: TComponent; ResDirOfs: Longint;
      AExeImage: TExeImage);
    destructor Destroy; override;
    function Count: Integer;
    property Items[Index: Integer]: TResourceItem read GetResourceItem; default;
  end;

{ TIconResourceList }

  TIconResourceList = class(TResourceList)
  protected
    function List: TList; override;
  end;

{ TCursorResourceList }

  TCursorResourceList = class(TResourceList)
  protected
    function List: TList; override;
  end;

implementation

{ This function maps a resource type to the associated resource class }

function GetResourceClass(ResType: Integer): TResourceClass;
const
  TResourceClasses: array[TResourceType] of TResourceClass = (
    TResourceItem,      { rtUnknown0 }
    TCursorResEntry,    { rtCursorEntry }
    TBitmapResource,    { rtBitmap }
    TIconResEntry,      { rtIconEntry }
    TMenuResource,      { rtMenu }
    TResourceItem,      { rtDialog }
    TStringResource,    { rtString }
    TResourceItem,      { rtFontDir }
    TResourceItem,      { rtFont }
    TResourceItem,      { rtAccelerators }
    TResourceItem,      { rtRCData }
    TResourceItem,      { rtMessageTable }
    TCursorResource,    { rtGroupCursor }
    TResourceItem,      { rtUnknown13 }
    TIconResource,      { rtIcon }
    TResourceItem,      { rtUnknown15 }
    TResourceItem);     { rtVersion }
begin
  if (ResType >= Integer(Low(TResourceType))) and
    (ResType <= Integer(High(TResourceType))) then
    Result := TResourceClasses[TResourceType(ResType)] else
    Result := TResourceItem;
end;

{ Utility Functions }

function Min(A, B: Integer): Integer;
begin
  if A < B then Result := A
  else Result := B;
end;

{ This function checks if an offset is a string name, or a directory }
{Assumes: IMAGE_RESOURCE_NAME_IS_STRING = IMAGE_RESOURCE_DATA_IS_DIRECTORY}

function HighBitSet(L: Longint): Boolean;
begin
  Result := (L and IMAGE_RESOURCE_DATA_IS_DIRECTORY) <> 0;
end;

function StripHighBit(L: Longint): Longint;
begin
  Result := L and IMAGE_OFFSET_STRIP_HIGH;
end;

function StripHighPtr(L: Longint): Pointer;
begin
  Result := Pointer(L and IMAGE_OFFSET_STRIP_HIGH);
end;

{ This function converts a pointer to a wide char string into a pascal string }

function WideCharToStr(WStr: PWChar; Len: Integer): string;
begin
  if Len = 0 then Len := -1;
  Len := WideCharToMultiByte(CP_ACP, 0, WStr, Len, nil, 0, nil, nil);
  SetLength(Result, Len);
  WideCharToMultiByte(CP_ACP, 0, WStr, Len, PChar(Result), Len, nil, nil);
end;

{ Exceptions }

procedure ExeError(const ErrMsg: string);
begin
  raise EExeError.Create(ErrMsg);
end;

{ TExeImage }

constructor TExeImage.CreateImage(AOwner: TComponent; const AFileName: string);
begin
  inherited Create(AOwner);
  FFileName := AFileName;
  FFileHandle := CreateFile(PChar(FFileName), GENERIC_READ, FILE_SHARE_READ,
    nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if FFileHandle = INVALID_HANDLE_VALUE then ExeError('Couldn''t open: '+FFileName);
    FFileMapping := CreateFileMapping(FFileHandle, nil, PAGE_READONLY, 0, 0, nil);
  if FFileMapping = 0 then ExeError('CreateFileMapping failed');
    FFileBase := MapViewOfFile(FFileMapping, FILE_MAP_READ, 0, 0, 0);
  if FFileBase = nil then ExeError('MapViewOfFile failed');
    FDosHeader := PIMAGE_DOS_HEADER(FFileBase);
  if not FDosHeader.e_magic = IMAGE_DOS_SIGNATURE then
    ExeError('unrecognized file format');
  FNTHeader := PIMAGE_NT_HEADERS(Longint(FDosHeader) + FDosHeader.e_lfanew);
  if IsBadReadPtr(FNTHeader, sizeof(IMAGE_NT_HEADERS)) or
     (FNTHeader.Signature <> IMAGE_NT_SIGNATURE) then
    ExeError('Not a PE (WIN32 Executable) file');
 end;

destructor TExeImage.Destroy;
begin
  if FFileHandle <> INVALID_HANDLE_VALUE then
  begin
    UnmapViewOfFile(FFileBase);
    CloseHandle(FFileMapping);
    CloseHandle(FFileHandle);
  end;
  inherited Destroy;
end;

function TExeImage.GetSectionHdr(const SectionName: string;
  var Header: PIMAGE_SECTION_HEADER): Boolean;
var
  I: Integer;
begin
  Header := PIMAGE_SECTION_HEADER(FNTHeader);
  Inc(PIMAGE_NT_HEADERS(Header));
  Result := True;
  for I := 0 to FNTHeader.FileHeader.NumberOfSections - 1 do
  begin
    if Strlicomp(Header.Name, PChar(SectionName), IMAGE_SIZEOF_SHORT_NAME) = 0 then Exit;
    Inc(Header);
  end;
  Result := False;
end;

function TExeImage.GetResourceList: TResourceList;
var
  ResSectHdr: PIMAGE_SECTION_HEADER;
begin
  if not Assigned(FResourceList) then
  begin
    if GetSectionHdr('.rsrc', ResSectHdr) then
    begin
      FResourceBase := ResSectHdr.PointerToRawData + LongWord(FDosHeader);
      FResourceRVA := ResSectHdr.VirtualAddress;
      FResourceList := TResourceList.CreateList(Self, FResourceBase, Self);
    end
    else
      ExeError('No resources in this file.');
  end;
  Result := FResourceList;
end;

{ TResourceItem }

constructor TResourceItem.CreateItem(AOwner: TComponent; ADirEntry: Pointer);
begin
  inherited Create(AOwner);
  FDirEntry := ADirEntry;
end;

function TResourceItem.DataEntry: PIMAGE_RESOURCE_DATA_ENTRY;
begin
  Result := PIMAGE_RESOURCE_DATA_ENTRY(FirstChildDirEntry.OffsetToData
    + Cardinal(FExeImage.FResourceBase));
end;

function TResourceItem.FirstChildDirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
begin
  Result := PIMAGE_RESOURCE_DIRECTORY_ENTRY(StripHighBit(FDirEntry.OffsetToData) +
    FExeImage.FResourceBase + SizeOf(IMAGE_RESOURCE_DIRECTORY));
end;

function TResourceItem.FExeImage: TExeImage;
begin
  Result := (Owner as TResourceList).FExeImage;
end;

function TResourceItem.GetResourceItem(Index: Integer): TResourceItem;
begin
  Result := List[Index];
end;

function TResourceItem.GetResourceType: TResourceType;
begin
  Result := TResourceType((Owner as TResourceList).FResType);
end;

function TResourceItem.IsList: Boolean;
begin
  Result := HighBitSet(FirstChildDirEntry.OffsetToData);
end;

function TResourceItem.GetResourceList: TResourceList;
begin
  if not IsList then ExeError('ResourceItem is not a list');
  if not Assigned(FList) then
    FList := TResourceList.CreateList(Self, StripHighBit(FDirEntry.OffsetToData) +
      FExeImage.FResourceBase, FExeImage);
  Result := FList;
end;

function TResourceItem.GetName: string;
var
  PDirStr: PIMAGE_RESOURCE_DIR_STRING_U;
begin
  { Check for Level1 entries, these are resource types. }
  if (Owner.Owner = FExeImage) and not HighBitSet(FDirEntry.Name) and
    (FDirEntry.Name <= 16) then
  begin
    Result := Copy(GetEnumName(TypeInfo(TResourceType), FDirEntry.Name), 3, 20);
    Exit;
  end;

  if HighBitSet(FDirEntry.Name) then
  begin
    PDirStr := PIMAGE_RESOURCE_DIR_STRING_U(StripHighBit(FDirEntry.Name) +
      FExeImage.FResourceBase);
    Result := WideCharToStr(@PDirStr.NameString, PDirStr.Length);
    Exit;
  end;
  Result := Format('%d', [FDirEntry.Name]);
end;

function TResourceItem.Offset: Integer;
begin
  if IsList then
    Result := StripHighBit(FDirEntry.OffsetToData)
  else
    Result := DataEntry.OffsetToData;
end;

function TResourceItem.RawData: Pointer;
begin
  with FExeImage do
    Result := pointer(FResourceBase - FResourceRVA + LongInt(DataEntry.OffsetToData));
end;

function TResourceItem.ResTypeStr: string;
begin
  Result := Copy(GetEnumName(TypeInfo(TResourceType), Ord(ResType)), 3, 20);
end;

procedure TResourceItem.SaveToFile(const FileName: string);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmCreate);
  try
    Self.SaveToStream(FS);
  finally
    FS.Free;
  end;
end;

procedure TResourceItem.SaveToStream(Stream: TStream);
begin
  Stream.Write(RawData^, Size);
end;

function TResourceItem.Size: Integer;
begin
  if IsList then
    Result := 0
  else
    Result := DataEntry.Size;
end;

{ TBitmapResource }

procedure TBitmapResource.AssignTo(Dest: TPersistent);
var
  MemStr: TMemoryStream;
  BitMap: TBitMap;
begin
  if (Dest is TPicture) then
  begin
    BitMap := TPicture(Dest).Bitmap;
    MemStr := TMemoryStream.Create;
    try
      SaveToStream(MemStr);
      MemStr.Seek(0,0);
      BitMap.LoadFromStream(MemStr);
    finally
      MemStr.Free;
    end
  end
  else
    inherited AssignTo(Dest);
end;

procedure TBitmapResource.SaveToStream(Stream: TStream);

  function GetDInColors(BitCount: Word): Integer;
  begin
    case BitCount of
      1, 4, 8: Result := 1 shl BitCount;
    else
      Result := 0;
    end;
  end;

var
  BH: TBitmapFileHeader;
  BI: PBitmapInfoHeader;
  BC: PBitmapCoreHeader;
  ClrUsed: Integer;
begin
  FillChar(BH, sizeof(BH), #0);
  BH.bfType := $4D42;
  BH.bfSize := Self.Size + sizeof(BH);
  BI := PBitmapInfoHeader(RawData);
  if BI.biSize = sizeof(TBitmapInfoHeader) then
  begin
    ClrUsed := BI.biClrUsed;
    if ClrUsed = 0 then
      ClrUsed := GetDInColors(BI.biBitCount);
    BH.bfOffBits :=  ClrUsed * SizeOf(TRgbQuad) +
      sizeof(TBitmapInfoHeader) + sizeof(BH);
  end
  else
  begin
    BC := PBitmapCoreHeader(RawData);
    ClrUsed := GetDInColors(BC.bcBitCount);
    BH.bfOffBits :=  ClrUsed * SizeOf(TRGBTriple) +
      sizeof(TBitmapCoreHeader) + sizeof(BH);
  end;
  Stream.Write(BH, SizeOf(BH));
  Stream.Write(RawData^, Self.Size);
end;


{ TIconResource }

function TIconResource.GetResourceList: TResourceList;
begin
  if not Assigned(FList) then
    FList := TIconResourceList.CreateList(Owner, LongInt(RawData), FExeImage);
  Result := FList;
end;

function TIconResource.IsList: Boolean;
begin
  Result := True;
end;

{ TIconResEntry }

procedure TIconResEntry.AssignTo(Dest: TPersistent);
var
  hIco: HIcon;
begin
  if Dest is TPicture then
  begin
    hIco := CreateIconFromResource(RawData, Size, (ResType = rtIconEntry), $30000);
    TPicture(Dest).Icon.Handle := hIco;
  end
  else
    inherited AssignTo(Dest);
end;

function TIconResEntry.GetName: string;
begin
  if Assigned(FResInfo) then
    with FResInfo^ do
      Result := Format('%d X %d %d Colors', [bWidth, bHeight, bColorCount])
  else
    Result := inherited GetName;
end;

procedure TIconResEntry.SaveToStream(Stream: TStream);
begin
  with TIcon.Create do
  try
    Handle := CreateIconFromResource(RawData, Self.Size, (ResType <> rtIcon), $30000);
    SaveToStream(Stream);
  finally
    Free;
  end;
end;

{ TCursorResource }

function TCursorResource.GetResourceList: TResourceList;
begin
  if not Assigned(FList) then
    FList := TCursorResourceList.CreateList(Owner, LongInt(RawData), FExeImage);
  Result := FList;
end;

{ TCursorResEntry }

function TCursorResEntry.GetName: string;
begin
  if Assigned(FResInfo) then
    with FResInfo^ do
      Result := Format('%d X %d %d Bit(s)', [wWidth, wWidth, wBitCount])
  else
    Result := inherited GetName;
end;

{ TStringResource }

procedure TStringResource.AssignTo(Dest: TPersistent);
var
  P: PWChar;
  ID: Integer;
  Cnt: Cardinal;
  Len: Word;
begin
  if (Dest is TStrings) then
    with TStrings(Dest) do
    begin
      BeginUpdate;
      try
        Clear;
        P := RawData;
        Cnt := 0;
        while Cnt < StringsPerBlock do
        begin
          Len := Word(P^);
          if Len > 0 then
          begin
            Inc(P);
            ID := ((FDirEntry.Name - 1) shl 4) + Cnt;
            Add(Format('%d,  "%s"', [ID, WideCharToStr(P, Len)]));
            Inc(P, Len);
          end;
          Inc(Cnt);
        end;
      finally
        EndUpdate;
      end;
    end
  else
    inherited AssignTo(Dest);
end;

{ TMenuResource }

procedure TMenuResource.SetNestLevel(Value: Integer);
begin
  FNestLevel := Value;
  SetLength(FNestStr, Value * 2);
  FillChar(FNestStr[1], Value * 2, ' ');
end;

procedure TMenuResource.AssignTo(Dest: TPersistent);
var
  IsPopup: Boolean;
  Len: Word;
  MenuData: PWord;
  MenuEnd: PChar;
  MenuText: PWChar;
  MenuID: Word;
  MenuFlags: Word;
  S: string;
begin
  if (Dest is TStrings) then
    with TStrings(Dest) do
    begin
      BeginUpdate;
      try
        Clear;
        MenuData := RawData;
        MenuEnd := PChar(RawData) + Size;
        Inc(MenuData, 2);
        NestLevel := 0;
        while PChar(MenuData) < MenuEnd do
        begin
          MenuFlags := MenuData^;
          Inc(MenuData);
          IsPopup := (MenuFlags and MF_POPUP) = MF_POPUP;
          MenuID := 0;
          if not IsPopup then
          begin
            MenuID := MenuData^;
            Inc(MenuData);
          end;
          MenuText := PWChar(MenuData);
          Len := lstrlenw(MenuText);
          if Len = 0 then
            S := 'MENUITEM SEPARATOR'
          else
          begin
            S := WideCharToStr(MenuText, Len);
            if IsPopup then
              S := Format('POPUP "%s"', [S]) else
              S := Format('MENUITEM "%s",  %d', [S, MenuID]);
          end;
          Inc(MenuData, Len + 1);
          Add(NestStr + S);
          if (MenuFlags and MF_END) = MF_END then
          begin
            NestLevel := NestLevel - 1;
            Add(NestStr + 'ENDPOPUP');
          end;
          if IsPopup then
            NestLevel := NestLevel + 1;
        end;
      finally
        EndUpdate;
      end;
    end
  else
    inherited AssignTo(Dest);
end;

{ TResourceList }

constructor TResourceList.CreateList(AOwner: TComponent; ResDirOfs: Longint;
  AExeImage: TExeImage);
var
  DirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
begin
  inherited Create(AOwner);
  FExeImage := AExeImage;
  FResDir := Pointer(ResDirOfs);
  if AOwner <> AExeImage then
    if AOwner.Owner.Owner = AExeImage then
    begin
      DirEntry := PIMAGE_RESOURCE_DIRECTORY_ENTRY(FResDir);
      inc(PIMAGE_RESOURCE_DIRECTORY(DirEntry));
      FResType := TResourceItem(Owner).FDirEntry.Name;
    end
    else
      FResType := (AOwner.Owner.Owner as TResourceList).FResType;
end;

destructor TResourceList.Destroy;
begin
  inherited Destroy;
  FList.Free;
end;

function TResourceList.List: TList;
var
  I: Integer;
  DirEntry: PIMAGE_RESOURCE_DIRECTORY_ENTRY;
  DirCnt: Integer;
  ResItem: TResourceItem;
begin
  if not Assigned(FList) then
  begin
    FList := TList.Create;
    DirEntry := PIMAGE_RESOURCE_DIRECTORY_ENTRY(FResDir);
    inc(PIMAGE_RESOURCE_DIRECTORY(DirEntry));
    DirCnt := FResDir.NumberOfNamedEntries + FResDir.NumberOfIdEntries - 1;
    for I := 0 to DirCnt do
    begin
      { Handle Cursors and Icons specially }
      ResItem := GetResourceClass(FResType).CreateItem(Self, DirEntry);
      if Owner = FExeImage then
        if (TResourceType(DirEntry.Name) in [rtCursorEntry, rtIconEntry]) then
        begin
          if TResourceType(DirEntry.Name) = rtCursorEntry then
            FExeImage.FCursorResources := ResItem else
            FExeImage.FIconResources := ResItem;
          Inc(DirEntry);
          Continue;
        end;
      FList.Add(ResItem);
      Inc(DirEntry);
    end;
  end;
  Result := FList;
end;

function TResourceList.Count: Integer;
begin
  Result := List.Count;
end;

function TResourceList.GetResourceItem(Index: Integer): TResourceItem;
begin
  Result := List[Index];
end;

{ TIconResourceList }

function TIconResourceList.List: TList;
var
  I,  J, Cnt: Integer;
  ResData: PIconResInfo;
  ResList: TResourceList;
  ResOrd: Cardinal;
  IconResource: TIconResEntry;
begin
  if not Assigned(FList) then
  begin
    FList := TList.Create;
    Cnt := PIconHeader(FResDir).wCount;
    PChar(ResData) := PChar(FResDir) + SizeOf(TIconHeader);
    ResList := FExeImage.FIconResources.List;
    for I := 0 to Cnt - 1 do
    begin
      ResOrd := ResData.wNameOrdinal;
      for J := 0 to ResList.Count - 1 do
      begin
        if ResOrd = ResList[J].FDirEntry.Name then
        begin
          IconResource := ResList[J] as TIconResEntry;
          IconResource.FResInfo := ResData;
          FList.Add(IconResource);
        end;
      end;
      Inc(ResData);
    end;
  end;
  Result := FList;
end;

{ TCursorResourceList }

function TCursorResourceList.List: TList;
var
  I, J, Cnt: Integer;
  ResData: PCursorResInfo;
  ResList: TResourceList;
  ResOrd: Cardinal;
  CursorResource: TCursorResEntry;
begin
  if not Assigned(FList) then
  begin
    FList := TList.Create;
    Cnt := PIconHeader(FResDir).wCount;
    PChar(ResData) := PChar(FResDir) + SizeOf(TIconHeader);
    ResList := FExeImage.FCursorResources.List;
    for I := 0 to Cnt - 1 do
    begin
      ResOrd := ResData.wNameOrdinal;
      for J := 0 to ResList.Count - 1 do
      begin
        if ResOrd = ResList[J].FDirEntry.Name then
        begin
          CursorResource := ResList[J] as TCursorResEntry;
          CursorResource.FResInfo := ResData;
          FList.Add(CursorResource);
        end;
      end;
      Inc(ResData);
    end;
  end;
  Result := FList;
end;

end.