peresource.pas

East make Tray Icon in delphi

  RsPeResMessageTable = 'Message table';
  RsPeResString = 'String';
  RsPeResVersion = 'Version';
  RsNeutralLang = '[Neutral]';
  RsUnknownLang = '[Unknown]';

  RsTranslations = 'Translations:';

var
  JclLocalesList: TJclLocalesList;

function VirtualKeyNameFromCode(KeyCode: Byte): string;
const
  KN002F: array[$00..$2F] of PChar = (
    nil,
    'LBUTTON',
    'RBUTTON',
    'CANCEL',
    'MBUTTON',
    nil, nil, nil, // 05..07
    'BACK',
    'TAB',
    nil, nil, // 0A..0B
    'CLEAR',
    'RETURN',
    nil, nil, // 0E..0F
    'SHIFT ',
    'CONTROL',
    'MENU',
    'PAUSE',
    'CAPITAL',
    'KANA',
    'HANGUL',
    'JUNJA',
    'FINAL',
    'HANJA',
    'KANJI',
    'ESCAPE',
    'CONVERT',
    'NONCONVERT',
    'ACCEPT',
    'MODECHANGE',
    'SPACE',
    'PRIOR',
    'NEXT',
    'END',
    'HOME',
    'LEFT',
    'UP',
    'RIGHT',
    'DOWN',
    'SELECT',
    'PRINT',
    'EXECUTE',
    'SNAPSHOT',
    'INSERT',
    'DELETE',
    'HELP'
    );
  KN5B5D: array[$5B..$5D] of PChar = (
    'LWIN',
    'RWIN',
    'APPS'
    );
  KN6A6F: array[$6A..$6F] of PChar = (
    'MULTIPLY',
    'ADD',
    'SEPARATOR',
    'SUBTRACT',
    'DECIMAL',
    'DIVIDE'
    );
  KNA0A5: array[$A0..$A5] of PChar = (
    'LSHIFT',
    'RSHIFT',
    'LCONTROL',
    'RCONTROL',
    'LMENU',
    'RMENU'
    );
  KNF6FE: array[$F6..$FE] of PChar = (
    'ATTN',
    'CRSEL',
    'EXSEL',
    'EREOF',
    'PLAY',
    'ZOOM',
    'NONAME',
    'PA1',
    'OEM_CLEAR'
    );
begin
  case KeyCode of
    $00..$2F:
      Result := KN002F[KeyCode];
    $30..$39, $41..$5A:
      Result := Chr(KeyCode);
    $5B..$5D:
      Result := KN5B5D[KeyCode];
    $60..$69:
      Result := Format('NUMPAD%d', [KeyCode - $60]);
    $6A..$6F:
      Result := KN6A6F[KeyCode];
    $70..$87:
      Result := Format('F%d', [KeyCode - $6F]);
    $90:
      Result := 'NUMLOCK';
    $91:
      Result := 'SCROLL';
    $A0..$A5:
      Result := KNA0A5[KeyCode];
    $E5:
      Result := 'PROCESSKEY';
    $F6..$FE:
      Result := KNF6FE[KeyCode];
  else
    Result := '';
  end;
  if Result <> '' then Result := 'VK_' + Result;
end;

function LangNameFromName(const Name: string; ShortName: Boolean): string;
var
  LangID: Word;
  Locale: TJclLocaleInfo;
begin
  LangID := PRIMARYLANGID(StrToIntDef(Name, 0));
  if LangID = LANG_NEUTRAL then
    if ShortName then Result := '' else Result := RsNeutralLang
  else
  begin
    Locale := JclLocalesList.ItemFromLangIDPrimary[LangID];
    if Locale <> nil then
      with Locale do if ShortName then
        Result := AbbreviatedLangName else Result := EnglishLangName
    else
      Result := RsUnknownLang;
  end;
end;


function GetResItemKind(Item: TJclPeResourceItem; var Kind: TPeResKind): Boolean;
begin
  Result := True;
  Kind := rkUnknown;
  with Item do
    case ResourceType of
      rtAccelerators:
        Kind := rkAccelerator;
      rtCursorEntry, rtIconEntry, rtFont:
        Result := False;
      rtUserDefined:
        begin
          if Name = 'AVI' then Kind := rkAvi;
          if Name = '2110' then Kind := rkHTML;
        end;
      rtBitmap:
        Kind := rkBitmap;
      rtMenu:
        Kind := rkMenu;
      rtDialog:
        Kind := rkDialog;
      rtString:
        Kind := rkString;
      rtRCData:
        Kind := rkData;
      rtMessageTable:
        Kind := rkMessageTable;
      rtCursor:
        Kind := rkCursor;
      rtIcon:
        Kind := rkIcon;
      rtVersion:
        Kind := rkVersion;
      rtHmtl:
        Kind := rkHTML;
    end;
end;

const
  ResItemClasses: array [TPeResKind] of TJclReResItemClass = (
    TPeResAccelerator,
    TPeResAvi,
    TPeResBitmap,
    TPeResCursor,
    TPeResRCData,
    TPeResDialog,
    TPeResHTML,
    TPeResIcon,
    TPeResMenu,
    TPeMessageTable,
    TPeResString,
    TPeResVersion,
    TPeResUnknown
    );

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;

{ TPeResItem }

constructor TPeResItem.Create(AResImage: TPeResImage; AResourceItem: TJclPeResourceItem);
begin
  FList := TObjectList.Create(True);
  FResImage := AResImage;
  FResourceItem := AResourceItem;
end;

procedure TPeResItem.CreateList;
var
  I, J: Integer;
  Item: TPeResItem;
  ResItem: TJclPeResourceItem;
begin
  with FResourceItem.List do
    for I := 0 to Count - 1 do
    begin
      ResItem := Items[I];
      for J := 0 to ResItem.List.Count - 1 do
      begin
        Item := ResItemClasses[Self.FKind].Create(FResImage, ResItem.List[J]);
        Item.FKind := Self.FKind;
        FList.Add(Item);
      end;
    end;
end;

destructor TPeResItem.Destroy;
begin
  FreeAndNil(FList);
  FreeAndNil(FStream);
  inherited;
end;

function TPeResItem.GetItemCount: Integer;
begin
  if IsList then
  begin
    if FList.Count = 0 then CreateList;
    Result := FList.Count;
  end else
    Result := -1;
end;

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

function TPeResItem.GetStream: TJclPeResourceRawStream;
begin
  if not Assigned(FStream) then
    FStream := TJclPeResourceRawStream.Create(FResourceItem);
  Result := FStream;
end;

function TPeResItem.IsList: Boolean;
begin
  Result := FResourceItem.IsDirectory;
end;

function TPeResItem.Offset: Integer;
begin
  if IsList then
    Result := FResourceItem.Entry^.OffsetToData and not (IMAGE_RESOURCE_DATA_IS_DIRECTORY)
  else
    Result := FResourceItem.DataEntry^.OffsetToData
end;

function TPeResItem.RawData: Pointer;
begin
  Result := FResourceItem.RawEntryData;
end;

function TPeResItem.ResName: string;
const
  ResNames: array [TPeResKind] of PResStringRec = (
    @RsPeResAccelerator,
    @RsPeResAVI,
    @RsPeResBitmap,
    @RsPeResCursor,
    @RsPeResData,
    @RsPeResDialog,
    @RsPeResHTML,
    @RsPeResIcon,
    @RsPeResMenu,
    @RsPeResMessageTable,
    @RsPeResString,
    @RsPeResVersion,
    nil
    );
begin
  if FKind = rkUnknown then
    Result := FResourceItem.ResourceTypeStr
  else
    Result := LoadResString(ResNames[FKind]);
end;

function TPeResItem.ResType: TJclPeResourceKind;
begin
  Result := FResourceItem.ResourceType;
end;

procedure TPeResItem.SaveToStream(Stream: TStream);
begin
  if not IsList then
    Stream.WriteBuffer(RawData^, Size);
end;

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

{ TPeResUnknown }

function TPeResUnknown.FileExt: string;
begin
  Result := 'bin';
end;

function TPeResUnknown.IsList: Boolean;
begin
  Result := False;
end;

function TPeResUnknown.ResName: string;
begin
  if StrToIntDef(FResourceItem.Name, 0) = LANG_NEUTRAL then
    Result := FResourceItem.ParentItem.Name
  else
    Result := Format('%s > %s', [FResourceItem.ParentItem.Name, LangNameFromName(FResourceItem.Name)]);
end;

{ TPeResUnkStrings }

procedure TPeResUnkStrings.AssignTo(Dest: TPersistent);
begin
  if (Dest is TStrings) then
    with TStrings(Dest) do
    begin
      BeginUpdate;
      try
        Clear;
        FillStrings(TStrings(Dest));
      finally
        EndUpdate;
      end;
    end
  else
    inherited;
end;

function TPeResUnkStrings.FileExt: string;
begin
  Result := 'txt';
end;

{ TPeResAccelTable }

procedure TPeResAccelerator.FillStrings(Strings: TStrings; StripCrLf: Boolean);
var
  TableEntry: PAccelTableEntry;
  IsLast: Boolean;
  S: string;

  function AnsiToChar(A: Word): string;
  begin
    if A >= 32 then Result := Chr(A) else Result := '';
  end;

begin
  Strings.BeginUpdate;
  try
    TableEntry := RawData;
    repeat
      with TableEntry^ do
      begin
        IsLast := fFlags and $80 <> 0;
        if fFlags and FVIRTKEY <> 0 then
        begin
          S := Format('Virtual Key: %.2u "%s" ', [wAnsi, VirtualKeyNameFromCode(wAnsi)]);
          if fFlags and FSHIFT <> 0 then S := S + 'SHIFT ';
          if fFlags and FCONTROL <> 0 then S := S + 'CTRL ';
          if fFlags and FALT <> 0 then S := S + 'ALT ';
        end else
          S := Format('ANSI character: %.2u "%s" ', [wAnsi, AnsiToChar(wAnsi)]);
        if fFlags and FNOINVERT <> 0 then S := S + 'NOINVERT';
      end;
      Strings.Add(TrimRight(S));
      Inc(TableEntry);
    until IsLast;
  finally
    Strings.EndUpdate;
  end;    
end;

{ TPeResAvi }

{$HINTS OFF}
type
  TDirtyComponent = class(TPersistent)
  private
    FOwner: TComponent;
    FName: TComponentName;
    FTag: Longint;
    FComponents: TList;
    FFreeNotifies: TList;
    FDesignInfo: Longint;
    FVCLComObject: Pointer;
    FComponentState: TComponentState;
  end;
{$HINTS ON}

procedure TPeResAvi.AssignTo(Dest: TPersistent);
begin
  if Dest is TAnimate then
  begin
    Include(TDirtyComponent(Dest).FComponentState, csLoading);
    TAnimate(Dest).ResHandle := FResImage.LibHandle;
    TAnimate(Dest).ResName := FResourceItem.ParentItem.ParameterName;
    Exclude(TDirtyComponent(Dest).FComponentState, csLoading);
    TAnimate(Dest).Reset;
  end
  else
    inherited;
end;

function TPeResAvi.FileExt: string;
begin
  Result := 'avi';
end;

{ TPeResBitmap }

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

function TPeResBitmap.FileExt: string;
begin
  Result := 'bmp';
end;

function TPeResBitmap.GraphicProperties: TPeGraphicProperties;
var
  BI: PBitmapInfoHeader;
  BC: PBitmapCoreHeader;
begin
  BI := PBitmapInfoHeader(RawData);
  if BI.biSize = SizeOf(TBitmapInfoHeader) then
  begin
    Result.Width := BI.biWidth;
    Result.Height := BI.biHeight;
    Result.BitsPerPixel := BI.biPlanes * BI.biBitCount;
  end else
  begin
    BC := PBitmapCoreHeader(RawData);
    Result.Width := BC.bcWidth;
    Result.Height := BC.bcHeight;
    Result.BitsPerPixel := BC.bcPlanes * BC.bcBitCount;
  end;
end;

procedure TPeResBitmap.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;