compresupdate.pas

源代码

  PEOptHeader: PImageOptionalHeader;
  PESectionHeaders: PPESectionHeaderArray;
  SectionVirtualAddr, SectionPhysOffset: Cardinal;
  I: Integer;
  Ofs: Cardinal;
  DataEntry: TImageResourceDataEntry;
  VersRes: Pointer;
begin
  PEOptHeader := nil;
  PESectionHeaders := nil;
  VersRes := nil;
  F := TFile.Create(Filename, fdOpenExisting, faReadWrite, fsNone);
  try
    { Read DOS header }
    F.ReadBuffer(EXESig, SizeOf(EXESig));
    if EXESig <> $5A4D {'MZ'} then
      Error('File isn''t an EXE file (1)');
    F.Seek($3C);
    F.ReadBuffer(PEHeaderOffset, SizeOf(PEHeaderOffset));
    if PEHeaderOffset = 0 then
      Error('File isn''t a PE file (1)');

    { Read PE header & optional header }
    F.Seek(PEHeaderOffset);
    F.ReadBuffer(PESig, SizeOf(PESig));
    if PESig <> $00004550 {'PE'#0#0} then
      Error('File isn''t a PE file (2)');
    F.ReadBuffer(PEHeader, SizeOf(PEHeader));
    GetMem(PEOptHeader, PEHeader.SizeOfOptionalHeader);
    F.ReadBuffer(PEOptHeader^, PEHeader.SizeOfOptionalHeader);

    { Scan section headers for resource section }
    if (PEOptHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress = 0) or
       (PEOptHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].Size = 0) then
      Error('No resources (1)');
    SectionVirtualAddr := PEOptHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress;
    GetMem(PESectionHeaders, PEHeader.NumberOfSections * SizeOf(PESectionHeaders[0]));
    F.ReadBuffer(PESectionHeaders^, PEHeader.NumberOfSections * SizeOf(PESectionHeaders[0]));
    SectionPhysOffset := 0;
    for I := 0 to PEHeader.NumberOfSections-1 do
      with PESectionHeaders[I] do
        if (VirtualAddress = SectionVirtualAddr) and (SizeOfRawData <> 0) then begin
          SectionPhysOffset := PointerToRawData;
          Break;
        end;
    if SectionPhysOffset = 0 then
      Error('No resources (2)');

    { Scan the resource directory }
    F.Seek(SectionPhysOffset);
    if not FindResOffset(False, Cardinal(RT_VERSION), True, Ofs) then
      Error('Can''t find version resource (1)');
    F.Seek(SectionPhysOffset + Ofs);
    if not FindResOffset(False, 1, True, Ofs) then
      Error('Can''t find version resource (2)');
    F.Seek(SectionPhysOffset + Ofs);
    if not FindResOffset(True, 0, False, Ofs) then
      Error('Can''t find version resource (3).');
    F.Seek(SectionPhysOffset + Ofs);
    F.ReadBuffer(DataEntry, SizeOf(DataEntry));

    { Read the resource }
    F.Seek(SectionPhysOffset + (DataEntry.OffsetToData - SectionVirtualAddr));
    GetMem(VersRes, DataEntry.Size);
    F.ReadBuffer(VersRes^, DataEntry.Size);

    { Update the resource }
    UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'040904e4'#0'CompanyName'#0, NewCompanyName);
    UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'040904e4'#0'FileDescription'#0, NewFileDescription);
    UpdateStringValue(VersRes, 'VS_VERSION_INFO'#0'StringFileInfo'#0'040904e4'#0'FileVersion'#0, NewTextFileVersion);
    UpdateFixedFileInfo(VersRes, 'VS_VERSION_INFO'#0, NewBinaryFileVersion);

    { Write the updated resource }
    F.Seek(SectionPhysOffset + (DataEntry.OffsetToData - SectionVirtualAddr));
    F.WriteBuffer(VersRes^, DataEntry.Size);
  finally
    F.Free;
    FreeMem(VersRes);
    FreeMem(PESectionHeaders);
    FreeMem(PEOptHeader);
  end;
end;

function EnumLangsFunc(hModule: Cardinal; lpType, lpName: PAnsiChar; wLanguage: Word; lParam: Integer): BOOL; stdcall;
begin
  PWord(lParam)^ := wLanguage;
  Result := False;
end;

function GetResourceLanguage(hModule: Cardinal; lpType, lpName: PAnsiChar; var wLanguage: Word): Boolean;
begin
  wLanguage := 0;
  EnumResourceLanguages(hModule, lpType, lpName, @EnumLangsFunc, Integer(@wLanguage));
  Result := True;
end;

procedure UpdateIcons(const FileName, IcoFileName: String);
type
  PIcoItemHeader = ^TIcoItemHeader;
  TIcoItemHeader = packed record
    Width: Byte;
    Height: Byte;
    Colors: Byte;
    Reserved: Byte;
    Planes: Word;
    BitCount: Word;
    ImageSize: DWORD;
  end;
  PIcoItem = ^TIcoItem;
  TIcoItem = packed record
    Header: TIcoItemHeader;
    Offset: DWORD;
  end;
  PIcoHeader = ^TIcoHeader;
  TIcoHeader = packed record
    Reserved: Word;
    Typ: Word;
    ItemCount: Word;
    Items: array [0..MaxInt shr 4 - 1] of TIcoItem;
  end;
  PGroupIconDirItem = ^TGroupIconDirItem;
  TGroupIconDirItem = packed record
    Header: TIcoItemHeader;
    Id: Word;
  end;
  PGroupIconDir = ^TGroupIconDir;
  TGroupIconDir = packed record
    Reserved: Word;
    Typ: Word;
    ItemCount: Word;
    Items: array [0..MaxInt shr 4 - 1] of TGroupIconDirItem;
  end;

  function IsValidIcon(P: Pointer; Size: Cardinal): Boolean;
  var
    ItemCount: Cardinal;
  begin
    Result := False;
    if Size < SizeOf(Word) * 3 then
      Exit;
    if (PChar(P)[0] = 'M') and (PChar(P)[1] = 'Z') then
      Exit;
    ItemCount := PIcoHeader(P).ItemCount;
    if Size < (SizeOf(Word) * 3) + (ItemCount * SizeOf(TIcoItem)) then
      Exit;
    P := @PIcoHeader(P).Items;
    while ItemCount > 0 do begin
      if (PIcoItem(P).Offset + PIcoItem(P).Header.ImageSize < PIcoItem(P).Offset) or
         (PIcoItem(P).Offset + PIcoItem(P).Header.ImageSize > Size) then
        Exit;
      Inc(PIcoItem(P));
      Dec(ItemCount);
    end;
    Result := True;
  end;

var
  H: THandle;
  M: HMODULE;
  R: HRSRC;
  Res: HGLOBAL;
  GroupIconDir, NewGroupIconDir: PGroupIconDir;
  I: Integer;
  wLanguage: Word;
  F: TFile;
  Ico: PIcoHeader;
  N: Cardinal;
  NewGroupIconDirSize: LongInt;
begin
  if Win32Platform <> VER_PLATFORM_WIN32_NT then
    Error('Only supported on Windows NT and above');

  Ico := nil;

  try
    { Load the icons }
    F := TFile.Create(IcoFileName, fdOpenExisting, faRead, fsRead);
    try
      N := F.CappedSize;
      if Cardinal(N) > Cardinal($100000) then  { sanity check }
        Error('Icon file is too large');
      GetMem(Ico, N);
      F.ReadBuffer(Ico^, N);
    finally
      F.Free;
    end;

    { Ensure the icon is valid }
    if not IsValidIcon(Ico, N) then
      Error('Icon file is invalid');

    { Update the resources }
    H := BeginUpdateResource(PChar(FileName), False);
    if H = 0 then
      ErrorWithLastError('BeginUpdateResource failed (1)');
    try
      M := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
      if M = 0 then
        ErrorWithLastError('LoadLibraryEx failed (1)');
      try
      	{ Load the 'MAINICON' group icon resource }
        R := FindResource(M, 'MAINICON', RT_GROUP_ICON);
        if R = 0 then
          ErrorWithLastError('FindResource failed (1)');
        Res := LoadResource(M, R);
        if Res = 0 then
          ErrorWithLastError('LoadResource failed (1)');
        GroupIconDir := LockResource(Res);
        if GroupIconDir = nil then
          ErrorWithLastError('LockResource failed (1)');

        { Delete 'MAINICON' }
        if not GetResourceLanguage(M, RT_GROUP_ICON, 'MAINICON', wLanguage) then
          Error('GetResourceLanguage failed (1)');
        if not UpdateResource(H, RT_GROUP_ICON, 'MAINICON', wLanguage, nil, 0) then
          ErrorWithLastError('UpdateResource failed (1)');

        { Delete the RT_ICON icon resources that belonged to 'MAINICON' }
        for I := 0 to GroupIconDir.ItemCount-1 do begin
          if not GetResourceLanguage(M, RT_ICON, MakeIntResource(GroupIconDir.Items[I].Id), wLanguage) then
            Error('GetResourceLanguage failed (2)');
          if not UpdateResource(H, RT_ICON, MakeIntResource(GroupIconDir.Items[I].Id), wLanguage, nil, 0) then
            ErrorWithLastError('UpdateResource failed (2)');
        end;

        { Build the new group icon resource }
        NewGroupIconDirSize := 3*SizeOf(Word)+Ico.ItemCount*SizeOf(TGroupIconDirItem);
        GetMem(NewGroupIconDir, NewGroupIconDirSize);
        try
          { Build the new group icon resource }
          NewGroupIconDir.Reserved := GroupIconDir.Reserved;
          NewGroupIconDir.Typ := GroupIconDir.Typ;
          NewGroupIconDir.ItemCount := Ico.ItemCount;
          for I := 0 to NewGroupIconDir.ItemCount-1 do begin
            NewGroupIconDir.Items[I].Header := Ico.Items[I].Header;
            NewGroupIconDir.Items[I].Id := I+1; //assumes that there aren't any icons left
          end;

          { Update 'MAINICON' }
          for I := 0 to NewGroupIconDir.ItemCount-1 do
            if not UpdateResource(H, RT_ICON, MakeIntResource(NewGroupIconDir.Items[I].Id), 1033, Pointer(DWORD(Ico) + Ico.Items[I].Offset), Ico.Items[I].Header.ImageSize) then
              ErrorWithLastError('UpdateResource failed (3)');

          { Update the icons }
          if not UpdateResource(H, RT_GROUP_ICON, 'MAINICON', 1033, NewGroupIconDir, NewGroupIconDirSize) then
            ErrorWithLastError('UpdateResource failed (4)');
        finally
          FreeMem(NewGroupIconDir);
        end;
      finally
        FreeLibrary(M);
      end;
    except
      EndUpdateResource(H, True);  { discard changes }
      raise;
    end;
    if not EndUpdateResource(H, False) then
      ErrorWithLastError('EndUpdateResource failed');
  finally
    FreeMem(Ico);
  end;
end;

end.