peresource.pas

East make Tray Icon in delphi

begin
  FillChar(BH, sizeof(BH), #0);
  BH.bfType := $4D42;
  BH.bfSize := 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^, Size);
end;

{ TPeResCursorItem }

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

function TPeResCursorItem.FileExt: string;
begin
  Result := 'cur';
end;

function TPeResCursorItem.GraphicProperties: TPeGraphicProperties;
begin
  with FResInfo^ do
  begin
    Result.Width := ResInfo.Cursor.Width;
    Result.Height := ResInfo.Cursor.Height;
    Result.BitsPerPixel := BitCount * Planes;
  end;
end;

function TPeResCursorItem.ResName: string;
begin
  if FResInfo <> nil then
    with GraphicProperties do
      Result := Format('%d X %d %d bpp', [Width, Height, BitsPerPixel])
  else
    Result := '';
end;

procedure TPeResCursorItem.SaveToStream(Stream: TStream);
begin
  with TIcon.Create do
  try
    Handle := CreateIconFromResource(RawData, Self.Size, ResType = rtIconEntry, $30000);
    SaveToStream(Stream);
  finally
    Free;
  end;
end;
{ TODO : Saving monochrome icons and cursors doesn't work }

{ TPeResCursor }

procedure TPeResCursor.CreateList;
var
  Item: TPeResItem;
  I, J, Cnt: Integer;
  ResData: PResDir;
  ResOrd: DWORD;
  ResList: TJclPeResourceList;
  ItemClass: TJclReResItemClass;
begin
  if ResType = rtCursor then
  begin
    ResList := FResImage.FCursorEntry;
    ItemClass := TPeResCursorItem;
  end else
  begin
    ResList := FResImage.FIconEntry;
    ItemClass := TPeResIconItem;
  end;
  ResData := RawData;
  Cnt := PNewHeader(ResData)^.ResCount;
  Inc(PNewHeader(ResData));
  for I := 1 to Cnt do
  begin
    ResOrd := ResData^.IconCursorId;
    for J := 0 to ResList.Count - 1 do
      if ResOrd = ResList[J].Entry^.Name then
      begin
        Item := ItemClass.Create(FResImage, ResList[J].List[0]);
        Item.FKind := Self.FKind;
        TPeResCursorItem(Item).FResInfo := ResData;
        FList.Add(Item);
      end;
    Inc(ResData);
  end;
end;

function TPeResCursor.GetItems(Index: Integer): TPeResCursorItem;
begin
  Result := TPeResCursorItem(FList[Index]);
end;

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

{ TPeResRCData }

procedure TPeResRCData.AssignTo(Dest: TPersistent);
begin
  if Dest is TStrings then
    with TStrings(Dest) do
    begin
      BeginUpdate;
      try
        Clear;
        case FDataKind of
          dkDFM:
            DFMToStrings(TStrings(Dest));
          dkPackageDescription:
            Add(PWideChar(RawData));
          dkPackageInfo:
            PackageInfoToStrings(TStrings(Dest));
        end;    
      finally
        EndUpdate;
      end;
  end else
    inherited;
end;

procedure TPeResRCData.CheckFormat;
{$IFNDEF DELPHI5_UP}
const
  FilerSignature: array[1..4] of Char = 'TPF0';
var
  Signature: Integer;
{$ENDIF DELPHI5_UP}
begin
  FDataKind := dkUnknown;
  if ResName = 'DESCRIPTION' then
    FDataKind := dkPackageDescription
  else
  if ResName = 'PACKAGEINFO' then
    FDataKind := dkPackageInfo
  else
  begin
    Stream.Seek(0, soFromBeginning);
    {$IFDEF DELPHI5_UP}
    if TestStreamFormat(Stream) = sofBinary then
      FDataKind := dkDFM;
    {$ELSE DELPHI5_UP}
    Signature := 0;
    Stream.Read(Signature, SizeOf(Signature));
    if (Byte(Signature) = $FF) or (Signature = Integer(FilerSignature)) then
      FDataKind := dkDFM;
    {$ENDIF DELPHI5_UP}
  end;
end;

constructor TPeResRCData.Create(AResImage: TPeResImage;
  AResourceItem: TJclPeResourceItem);
begin
  inherited;
  CheckFormat;
end;

procedure TPeResRCData.DFMToStrings(Strings: TStrings);
var
  MemStream: TMemoryStream;
begin
  MemStream := TMemoryStream.Create;
  try
    Stream.Seek(0, soFromBeginning);
    ObjectBinaryToText(Stream, MemStream);
    MemStream.Seek(0, soFromBeginning);
    Strings.LoadFromStream(MemStream);
  finally
    MemStream.Free;
  end;
end;

function TPeResRCData.FileExt: string;
begin
  if DataKind = dkDFM then
    Result := 'dfm'
  else
    Result := inherited FileExt;
end;

procedure TPeResRCData.PackageInfoToStrings(Strings: TStrings);
var
  I: Integer;
begin
  with TJclPePackageInfo.Create(FResImage.LibHandle) do
  try
    Strings.Add('Contains');
    Strings.Add(StringOfChar('-', 80));
    for I := 0 to ContainsCount - 1 do
      Strings.Add(Format('  %s [%s]', [ContainsNames[I], UnitInfoFlagsToString(ContainsFlags[I])]));
    if RequiresCount > 0 then
    begin
      Strings.Add('');
      Strings.Add('Requires');
      Strings.Add(StringOfChar('-', 80));
      for I := 0 to RequiresCount - 1 do
        Strings.Add(Format('  %s', [RequiresNames[I]]));
    end;    
    Strings.Add('');
    Strings.Add('Package Info flags');
    Strings.Add(StringOfChar('-', 80));
    Strings.Add(Format('Options    : %s', [PackageOptionsToString(Flags)]));
    Strings.Add(Format('Module type: %s', [PackageModuleTypeToString(Flags)]));
    Strings.Add(Format('Producer   : %s', [ProducerToString(Flags)]));
  finally
    Free;
  end;
end;

{ TPeResDialog }

function TPeResDialog.CanShowDialog: Boolean;
begin
  Result := Windows.PDlgTemplate(RawData)^.style and DS_CONTROL = 0;
end;

function TPeResDialog.ShowDialog(ParentWnd: HWND): Integer;
var
  LastFocus: HWND;
  MemHandle: THandle;
  P: Windows.PDlgTemplate;

  function DialogProc(hwndDlg: HWND; uMsg: UINT; W: WPARAM; L: LPARAM): BOOL; stdcall;
  begin
    Result := False;
    case uMsg of
      WM_INITDIALOG:
         Result := True;
      WM_LBUTTONDBLCLK:
        EndDialog(hwndDlg, 0);
      WM_RBUTTONUP:
        EndDialog(hwndDlg, 1);
      WM_SYSCOMMAND:
        if W and $FFF0 = SC_CLOSE then
          EndDialog(hwndDlg, 0);
    end;
  end;

begin
  LastFocus := GetFocus;
  MemHandle := GlobalAlloc(GMEM_ZEROINIT, Size);
  P := GlobalLock(MemHandle);
  Move(RawData^, P^, Size);
  GlobalUnlock(MemHandle);
  Result := DialogBoxIndirect(hinstance, Windows.PDlgTemplate(MemHandle)^,
    ParentWnd, @DialogProc);
  GlobalFree(MemHandle);
  SetFocus(LastFocus);
end;

{ TPeResHTML }

function TPeResHTML.FileExt: string;
begin
  Result := Copy(ExtractFileExt(FResourceItem.ParentItem.ParameterName), 2, 20);
end;

function TPeResHTML.ResPath: string;
begin
  Result := Format('res://%s/%s', [FResImage.FileName, FResourceItem.ParentItem.ParameterName]);
end;

{ TPeResIconItem }

function TPeResIconItem.FileExt: string;
begin
  Result := 'ico';
end;

function TPeResIconItem.GraphicProperties: TPeGraphicProperties;
begin
  with FResInfo^ do
  begin
    Result.Width := ResInfo.Icon.Width;
    Result.Height := ResInfo.Icon.Height;
    Result.BitsPerPixel := BitCount * Planes;
  end;
end;

{ TPeResIcon }

function TPeResIcon.GetItems(Index: Integer): TPeResIconItem;
begin
  Result := TPeResIconItem(FList[Index]);
end;

{ TPeMessageTable }

procedure TPeMessageTable.FillStrings(Strings: TStrings; StripCrLf: Boolean);
var
  Count, I: Integer;
  E: DWORD;
  Block: PMessageResourceBlock;
  Entry: PMessageResourceEntry;
  S: string;
  Text: PChar;
  Data: Pointer;
begin
  Data := RawData;
  Count := PMessageResourceData(Data)^.NumberOfBlocks;
  Block := Data;
  Inc(PMessageResourceData(Block));
  for I := 1 to Count do
  begin
    Entry := PMessageResourceEntry(DWORD(Data) + Block^.OffsetToEntries);
    for E := Block^.LowId to Block^.HighId do
    begin
      with Entry^ do
      begin
        Text := PChar(Entry) + Sizeof(TMessageResourceEntry);
        if Flags = 1 then
          S := WideCharToStr(PWideChar(Text), lstrlenW(PWideChar(Text)))
        else
          SetString(S, PAnsiChar(Text), StrLen(Text));
        if StripCrLf then S := StrRemoveChars(S, [AnsiCarriageReturn, AnsiLineFeed]);
        Strings.AddObject(S, Pointer(E));
      end;
      Entry := Pointer(PChar(Entry) + Entry^.Length);
    end;
    Inc(Block);
  end;
end;

{ TPeResString }

procedure TPeResString.FillStrings(Strings: TStrings; StripCrLf: Boolean);
var
  P: PWChar;
  ID: Integer;
  Cnt: Cardinal;
  Len: Word;
  S: string;
begin
  P := RawData;
  Cnt := 0;
  while Cnt < 16 do
  begin
    Len := Word(P^);
    if Len > 0 then
    begin
      Inc(P);
      ID := ((FResourceItem.ParentItem.Entry^.Name - 1) shl 4) + Cnt;
      S := WideCharToStr(P, Len);
      if StripCrLf then S := StrRemoveChars(S, [AnsiCarriageReturn, AnsiLineFeed]);
      Strings.AddObject(S, Pointer(ID));
      Inc(P, Len);
    end else
      Inc(P);
    Inc(Cnt);
  end;
end;

{ TPeResVersion }

procedure TPeResVersion.FillStrings(Strings: TStrings; StripCrLf: Boolean);
var
  I: Integer;
begin
  Strings.Clear;
  with TJclFileVersionInfo.Attach(RawData, Size) do
  try
    for I := 0 to LanguageCount - 1 do
    begin
      LanguageIndex := I;
      Strings.Add(Format('[%s] %s', [LanguageIds[I], LanguageNames[I]]));
      Strings.Add(StringOfChar('-', 80));
      Strings.AddStrings(Items);
      Strings.Add(BinFileVersion);
      Strings.Add(OSIdentToString(FileOS));
      Strings.Add(OSFileTypeToString(FileType, FileSubType));
      Strings.Add('');
    end;
    Strings.Add(RsTranslations);
    for I := 0 to TranslationCount - 1 do
      Strings.Add(VersionLanguageId(Translations[I]));
  finally
    Free;
  end;
end;

{ TPeResImage }

procedure TPeResImage.Clear;
begin
  inherited;
  if Assigned(FPeImage) then
  begin
    if not FImageAttached then FreeAndNil(FPeImage) else FPeImage := nil;
  end;
end;

constructor TPeResImage.Create;
begin
  inherited Create(True);
end;

procedure TPeResImage.CreateList;
var
  I: Integer;
  Kind: TPeResKind;
  Item: TJclPeResourceItem;
  ResItem: TPeResItem;
begin
  with FPeImage.ResourceList do
    for I := 0 to Count - 1 do
    begin
      Item := Items[I];
      if GetResItemKind(Item, Kind) then
      begin
        ResItem := TPeResItem.Create(Self, Item);
        ResItem.FKind := Kind;
        Self.Add(ResItem);
      end else
      case Item.ResourceType of
        rtCursorEntry:
          FCursorEntry := Item.List;
        rtIconEntry:
          FIconEntry := Item.List;
      end;
    end;  
end;

destructor TPeResImage.Destroy;
begin
  UnloadLib;
  inherited;
end;

function TPeResImage.GetFileName: TFileName;
begin
  if Assigned(FPeImage) then Result := FPeImage.FileName else Result := '';
end;

function TPeResImage.GetItems(Index: Integer): TPeResItem;
begin
  Result := TPeResItem(inherited Items[Index]);
end;

function TPeResImage.GetLibHandle: THandle;
begin
  if FLibHandle = 0 then
  begin
    FLibHandle := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
    if FLibHandle = 0 then RaiseLastOSError;
  end;  
  Result := FLibHandle;
end;

procedure TPeResImage.SetFileName(const Value: TFileName);
begin
  if FileName <> Value then
  begin
    Clear;
    FImageAttached := False;
    FPeImage := TJclPeImage.Create;
    FPeImage.FileName := Value;
    CreateList;
  end;
end;

procedure TPeResImage.SetPeImage(const Value: TJclPeImage);
begin
  Clear;
  FPeImage := Value;
  FImageAttached := True;
  CreateList;
end;

procedure TPeResImage.UnloadLib;
begin
  if FLibHandle <> 0 then
  begin
    FreeLibrary(FLibHandle);
    FLibHandle := 0;
  end;
end;

initialization
  JclLocalesList := TJclLocalesList.Create;

finalization
  FreeAndNil(JclLocalesList);

end.