home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Chip 2001 September
/
Chip_2001-09_cd1.bin
/
zkuste
/
delphi
/
kolekce
/
d6
/
RX275D6.ZIP
/
Units
/
Rxresexp.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2001-06-24
|
67KB
|
2,366 lines
{*******************************************************}
{ }
{ Delphi VCL Extensions (RX) }
{ }
{ Copyright (c) 1997, 1998 Master-Bank }
{ }
{*******************************************************}
unit RxResExp;
interface
{$I RX.INC}
{$IFNDEF RX_D3}
ERROR! This unit is intended for Delphi 3.0 or higher only!
{ Resource expert doesn't work properly in Delphi 2.0 and in
C++Builder 1.0 and I don't know why. }
{$ENDIF}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IniFiles, ComCtrls, EditIntf, ExptIntf, ToolIntf, Menus, StdCtrls, Placemnt;
type
TRxProjectResExpert = class;
TResourceType = (rtpCustom, rtpCursor, rtpGroupCursor, rtpBitmap,
rtpIcon, rtpGroupIcon, rtpRCData, rtpVersion, rtpAniCursor,
rtpPredefined);
TResSelection = record
ResName: string;
ResType: string;
end;
TAddInNotifier = class(TIAddInNotifier)
private
FProjectResources: TRxProjectResExpert;
public
constructor Create(AProjectResources: TRxProjectResExpert);
procedure FileNotification(NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean); override;
{$IFDEF RX_D3}
procedure EventNotification(NotifyCode: TEventNotification;
var Cancel: Boolean); override;
{$ENDIF}
end;
TProjectNotifier = class(TIModuleNotifier)
private
FProjectResources: TRxProjectResExpert;
public
constructor Create(AProjectResources: TRxProjectResExpert);
procedure Notify(NotifyCode: TNotifyCode); override;
procedure ComponentRenamed(const AComponent: TComponent;
const OldName, NewName: string); override;
end;
TResourceEntry = class(TObject)
private
FHandle: Pointer;
FName: string;
FType: string;
FNameId: Word;
FTypeId: Word;
FSize: Integer;
FEntryNode: TTreeNode;
FResType: TResourceType;
FChildren: TList;
FParent: TResourceEntry;
function GetBitmap(ResFile: TIResourceFile): TBitmap;
function GetCursorOrIcon(ResFile: TIResourceFile; IsIcon: Boolean): HIcon;
public
constructor Create(AEntry: TIResourceEntry);
destructor Destroy; override;
function Rename(ResFile: TIResourceFile; const NewName: string): Boolean;
function GetGraphic(ResFile: TIResourceFile): TGraphic;
procedure GetData(ResFile: TIResourceFile; Stream: TStream);
procedure GetIconData(ResFile: TIResourceFile; Stream: TStream);
function GetName: string;
function GetTypeName: string;
function GetResourceName: PChar;
function GetResourceType: PChar;
function EnableEdit: Boolean;
function EnableRenameDelete: Boolean;
end;
TRxProjectResExpert = class(TIExpert)
private
ProjectResourcesItem: TIMenuItemIntf;
AddInNotifier: TAddInNotifier;
ProjectNotifier: TProjectNotifier;
ProjectModule: TIModuleInterface;
FResourceList: TStringList;
FSelection: TResSelection;
FResFileName: string;
FProjectName: string;
FLockCount: Integer;
procedure FindChildren(ResFile: TIResourceFile; Entry: TResourceEntry);
procedure LoadProjectResInfo;
procedure ClearProjectResInfo;
procedure UpdateProjectResInfo;
procedure OpenProject(const FileName: string);
procedure CloseProject;
{$IFNDEF RX_D4}
procedure LoadDesktop(const FileName: string);
procedure SaveDesktop(const FileName: string);
{$ENDIF}
procedure ProjectResourcesClick(Sender: TIMenuItemIntf);
public
constructor Create;
destructor Destroy; override;
function GetName: string; override;
function GetAuthor: string; override;
function GetComment: string; override;
function GetPage: string; override;
function GetGlyph: HICON; override;
function GetMenuText: string; override;
function GetState: TExpertState; override;
function GetStyle: TExpertStyle; override;
function GetIDString: string; override;
procedure Execute; override;
procedure BeginUpdate;
procedure EndUpdate;
procedure MarkModified;
function GetResFile: TIResourceFile;
function UniqueName(ResFile: TIResourceFile; ResType: PChar;
var Index: Integer): string;
procedure CheckRename(ResFile: TIResourceFile; ResType, NewName: PChar);
function DeleteEntry(ResFile: TIResourceFile; Entry: TResourceEntry): Boolean;
procedure CreateEntry(ResFile: TIResourceFile; ResType, ResName: PChar;
ADataSize: Integer; AData: Pointer; SetToEntry: Boolean);
procedure NewBinaryRes(ResFile: TIResourceFile; ResName, ResType: PChar;
Stream: TMemoryStream);
procedure EditBinaryRes(Entry: TResourceEntry; Stream: TMemoryStream);
procedure NewBitmapRes(ResFile: TIResourceFile; ResName: PChar;
Bitmap: TBitmap);
procedure EditBitmapRes(Entry: TResourceEntry; Bitmap: TBitmap);
procedure NewCursorIconRes(ResFile: TIResourceFile; ResName: PChar;
IsIcon: Boolean; Stream: TStream);
procedure EditCursorIconRes(Entry: TResourceEntry; IsIcon: Boolean;
Stream: TStream);
end;
TRxResourceEditor = class(TForm)
StatusBar: TStatusBar;
ResTree: TTreeView;
PopupMenu: TPopupMenu;
NewItem: TMenuItem;
EditItem: TMenuItem;
RenameItem: TMenuItem;
DeleteItem: TMenuItem;
TreeImages: TImageList;
N1: TMenuItem;
NewBitmapItem: TMenuItem;
NewIconItem: TMenuItem;
NewCursorItem: TMenuItem;
NewUserDataItem: TMenuItem;
OpenDlg: TOpenDialog;
SaveDlg: TSaveDialog;
Placement: TFormStorage;
PreviewItem: TMenuItem;
SaveItem: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure ResTreeExpanded(Sender: TObject; Node: TTreeNode);
procedure ResTreeCollapsed(Sender: TObject; Node: TTreeNode);
procedure ResTreeEditing(Sender: TObject; Node: TTreeNode;
var AllowEdit: Boolean);
procedure ResTreeEdited(Sender: TObject; Node: TTreeNode;
var S: string);
procedure PopupMenuPopup(Sender: TObject);
procedure RenameItemClick(Sender: TObject);
procedure EditItemClick(Sender: TObject);
procedure DeleteItemClick(Sender: TObject);
procedure NewBitmapItemClick(Sender: TObject);
procedure NewIconItemClick(Sender: TObject);
procedure NewCursorItemClick(Sender: TObject);
procedure NewUserDataItemClick(Sender: TObject);
procedure ResTreeKeyPress(Sender: TObject; var Key: Char);
procedure ResTreeDblClick(Sender: TObject);
procedure ResTreeChange(Sender: TObject; Node: TTreeNode);
procedure FormDestroy(Sender: TObject);
procedure PreviewItemClick(Sender: TObject);
procedure StatusBarDrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
procedure SaveItemClick(Sender: TObject);
private
{ Private declarations }
FExpert: TRxProjectResExpert;
function GetResourceTypeName: string;
procedure CheckResourceType(Sender: TObject; var TypeName: string;
var Apply: Boolean);
public
{ Public declarations }
end;
var
RxResourceEditor: TRxResourceEditor = nil;
procedure RegisterResourceExpert;
implementation
uses Consts, VCLUtils, rxStrUtils, MaxMin, PictEdit
{$IFDEF RX_D4}, ImgList {$ENDIF};
{$R *.DFM}
{$R *.R32}
{$D-}
{$I RXRESEXP.INC}
const
sExpertID = 'RX.ProjectResourceExpert';
sVisible = 'Visible';
{ Library registration }
procedure RegisterResourceExpert;
begin
RegisterLibraryExpert(TRxProjectResExpert.Create);
end;
{ TInputBox }
type
TApplyEvent = procedure(Sender: TObject; var Value: string;
var Apply: Boolean) of object;
TInputBox = class(TForm)
private
FPrompt: TLabel;
FEdit: TComboBox;
FValue: string;
FOnApply: TApplyEvent;
function GetPrompt: string;
procedure SetPrompt(const Value: string);
function GetStrings: TStrings;
procedure SetStrings(Value: TStrings);
procedure OkButtonClick(Sender: TObject);
public
function Execute: Boolean;
constructor Create(AOwner: TComponent); override;
property Caption;
property Value: string read FValue write FValue;
property Prompt: string read GetPrompt write SetPrompt;
property Strings: TStrings read GetStrings write SetStrings;
property OnApply: TApplyEvent read FOnApply write FOnApply;
end;
constructor TInputBox.Create(AOwner: TComponent);
var
DialogUnits: TPoint;
ButtonTop, ButtonWidth, ButtonHeight: Integer;
begin
{$IFDEF CBUILDER}
inherited CreateNew(AOwner, 0);
{$ELSE}
inherited CreateNew(AOwner);
{$ENDIF}
Canvas.Font := Self.Font;
DialogUnits := GetAveCharSize(Canvas);
BorderStyle := bsDialog;
ClientWidth := MulDiv(180, DialogUnits.X, 4);
ClientHeight := MulDiv(63, DialogUnits.Y, 8);
Position := poScreenCenter;
FPrompt := TLabel.Create(Self);
with FPrompt do begin
Parent := Self;
AutoSize := True;
Left := MulDiv(8, DialogUnits.X, 4);
Top := MulDiv(8, DialogUnits.Y, 8);
end;
FEdit := TComboBox.Create(Self);
with FEdit do begin
Parent := Self;
Left := FPrompt.Left;
Top := MulDiv(19, DialogUnits.Y, 8);
Width := MulDiv(164, DialogUnits.X, 4);
MaxLength := 255;
Style := csDropDown;
end;
FPrompt.FocusControl := FEdit;
ButtonTop := MulDiv(41, DialogUnits.Y, 8);
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
with TButton.Create(Self) do begin
Parent := Self;
Caption := SMsgDlgOK;
ModalResult := mrNone;
OnClick := OkButtonClick;
Default := True;
SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
ButtonHeight);
end;
with TButton.Create(Self) do begin
Parent := Self;
Caption := SMsgDlgCancel;
ModalResult := mrCancel;
Cancel := True;
SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,
ButtonHeight);
end;
end;
procedure TInputBox.OkButtonClick(Sender: TObject);
var
Apply: Boolean;
Value: string;
begin
Apply := True;
if Assigned(FOnApply) then begin
Value := FEdit.Text;
FOnApply(Self, Value, Apply);
if FEdit.Text <> Value then FEdit.Text := Value;
end;
if Apply then ModalResult := mrOk;
end;
function TInputBox.Execute: Boolean;
begin
with FEdit do begin
Text := FValue;
SelectAll;
end;
Result := ShowModal = mrOk;
if Result then FValue := FEdit.Text;
end;
function TInputBox.GetPrompt: string;
begin
Result := FPrompt.Caption;
end;
procedure TInputBox.SetPrompt(const Value: string);
begin
FPrompt.Caption := Value;
end;
function TInputBox.GetStrings: TStrings;
begin
Result := FEdit.Items;
end;
procedure TInputBox.SetStrings(Value: TStrings);
begin
if Value = nil then FEdit.Items.Clear
else FEdit.Items.Assign(Value);
end;
{ Utility routines }
{$IFNDEF RX_D3}
const
RT_ANICURSOR = MakeIntResource(21);
RT_ANIICON = MakeIntResource(22);
{$ENDIF}
const
FIRST_CUSTOM_RESTYPE = 25;
function IsValidIdent(const Ident: string): Boolean;
const
Numeric = ['0'..'9'];
AlphaNumeric = Numeric + ['A'..'Z', 'a'..'z', '_', '.'];
var
I: Integer;
begin
Result := False;
if (Length(Ident) = 0) then Exit;
for I := 1 to Length(Ident) do
if not (Ident[I] in AlphaNumeric) then Exit;
Result := True;
end;
function IsValidResType(const Ident: string): Boolean;
var
Val: Longint;
begin
Result := IsValidIdent(Ident);
if Result then begin
Val := StrToIntDef(Ident, FIRST_CUSTOM_RESTYPE);
Result := (Val >= FIRST_CUSTOM_RESTYPE) and (Val <= High(Word));
end;
end;
procedure CreateForm(InstanceClass: TComponentClass; var Reference);
begin
if TComponent(Reference) = nil then begin
TComponent(Reference) := TComponent(InstanceClass.NewInstance);
try
TComponent(Reference).Create(Application);
except
TComponent(Reference).Free;
TComponent(Reference) := nil;
raise;
end;
end;
end;
function PadUp(Value: Longint): Longint;
begin
Result := Value + (Value mod 4);
end;
function StrText(P: PChar): string;
begin
if HiWord(Longint(P)) = 0 then
Result := IntToStr(LoWord(Longint(P)))
else Result := StrPas(P);
end;
function ResIdent(const Name: string): PChar;
var
Id: Word;
Code: Integer;
begin
Val(Name, Id, Code);
if Code = 0 then Result := MakeIntResource(Id)
else Result := PChar(AnsiUpperCase(Name));
end;
function CheckResType(ResType: Integer): TResourceType;
begin
case ResType of
Integer(RT_CURSOR): Result := rtpCursor;
Integer(RT_BITMAP): Result := rtpBitmap;
Integer(RT_ICON): Result := rtpIcon;
Integer(RT_RCDATA): Result := rtpRCData;
Integer(RT_GROUP_CURSOR): Result := rtpGroupCursor;
Integer(RT_GROUP_ICON): Result := rtpGroupIcon;
Integer(RT_VERSION): Result := rtpVersion;
Integer(RT_ANICURSOR): Result := rtpAniCursor;
else Result := rtpCustom; { user-defined resource type }
end;
if (Result = rtpCustom) and (ResType > 0) and
(ResType < FIRST_CUSTOM_RESTYPE) then
Result := rtpPredefined;
end;
function ResourceTypeName(ResType: Integer): string;
begin
case ResType of
Integer(RT_CURSOR): Result := 'CURSOR';
Integer(RT_BITMAP): Result := 'BITMAP';
Integer(RT_ICON): Result := 'ICON';
Integer(RT_MENU): Result := 'MENU';
Integer(RT_DIALOG): Result := 'DIALOG';
Integer(RT_STRING): Result := 'STRINGS';
Integer(RT_FONTDIR): Result := 'FONTDIR';
Integer(RT_FONT): Result := 'FONT';
Integer(RT_ACCELERATOR): Result := 'ACCELERATOR';
Integer(RT_RCDATA): Result := 'RCDATA';
Integer(RT_MESSAGETABLE): Result := 'MESSAGE TABLE';
Integer(RT_GROUP_CURSOR): Result := 'CURSOR';
Integer(RT_GROUP_ICON): Result := 'ICON';
Integer(RT_VERSION): Result := 'VERSIONINFO';
Integer(RT_DLGINCLUDE): Result := 'DLGINCLUDE';
Integer(RT_PLUGPLAY): Result := 'PLUG-AND-PLAY';
Integer(RT_VXD): Result := 'VXD';
Integer(RT_ANICURSOR): Result := 'ANICURSOR';
Integer(RT_ANIICON): Result := 'ANIICON';
else Result := IntToStr(ResType);
end;
end;
function ResTypeName(ResType: PChar): string;
begin
if HiWord(Longint(ResType)) = 0 then
Result := ResourceTypeName(LoWord(Longint(ResType)))
else Result := StrPas(ResType);
end;
function FindNode(TreeView: TCustomTreeView; Node: TTreeNode;
const ResName, ResType: string): TTreeNode;
function SearchNodes(Node: TTreeNode): TTreeNode;
var
ChildNode: TTreeNode;
Entry: TResourceEntry;
begin
Result := nil;
if Node = nil then Exit;
Entry := TResourceEntry(Node.Data);
if ((Entry <> nil) and (Entry.GetName = ResName) and
(Entry.GetTypeName = ResType)) or ((Entry = nil) and (ResName = '') and
(Node.Text = ResType)) then
Result := Node
else
begin
ChildNode := Node.GetFirstChild;
while ChildNode <> nil do begin
Result := SearchNodes(ChildNode);
if Result <> nil then Break
else ChildNode := Node.GetNextChild(ChildNode);
end;
end;
end;
begin
if Node = nil then Node := TTreeView(TreeView).Items.GetFirstNode;
Result := SearchNodes(Node);
end;
const
ResImages: array[TResourceType] of Integer = (2, 4, 4, 5, 3, 3, 2, 8, 4, 2);
AllMenuFlags = [mfInvalid, mfEnabled, mfVisible, mfChecked, mfBreak,
mfBarBreak, mfRadioItem];
const
MOVEABLE = $0010;
PURE = $0020;
PRELOAD = $0040;
DISCARDABLE = $1000;
const
rc3_StockIcon = 0;
rc3_Icon = 1;
rc3_Cursor = 2;
type
PCursorOrIcon = ^TCursorOrIcon;
TCursorOrIcon = packed record
Reserved: Word;
wType: Word;
Count: Word;
end;
PIconDirectory = ^TIconDirectory;
TIconDirectory = packed record
case Integer of
rc3_Cursor:
(cWidth: Word;
cHeight: Word);
rc3_Icon:
(Width: Byte;
Height: Byte;
Colors: Byte;
Reserved: Byte;
Planes: Word;
BitCount: Word;
BytesInRes: Longint;
NameOrdinal: Word);
end;
PCursorHeader = ^TCursorHeader;
TCursorHeader = packed record
xHotspot: Word;
yHotspot: Word;
end;
PDirectory = ^TDirectory;
TDirectory = array[0..64] of TIconDirectory;
PIconRec = ^TIconRec;
TIconRec = packed record
Width: Byte;
Height: Byte;
Colors: Word;
Reserved1: Word; { xHotspot }
Reserved2: Word; { yHotspot }
DIBSize: Longint;
DIBOffset: Longint;
end;
PIconList = ^TIconList;
TIconList = array[0..64] of TIconRec;
procedure InvalidIcon; near;
begin
raise EInvalidGraphic.Create(ResStr(SInvalidIcon));
end;
{ TIconData }
type
TIconData = class
private
FHeader: TCursorOrIcon;
FList: Pointer;
FNames: PWordArray;
FData: TList;
procedure Clear;
public
constructor Create;
destructor Destroy; override;
function GetCount: Integer;
procedure LoadFromStream(Stream: TStream);
procedure SaveToStream(Stream: TStream);
function BuildResourceGroup(var Size: Integer): Pointer;
function BuildResourceItem(Index: Integer; var Size: Integer): Pointer;
procedure LoadResourceGroup(Data: Pointer; Size: Integer);
procedure LoadResourceItem(Index: Integer; Data: Pointer; Size: Integer);
procedure SetNameOrdinal(Index: Integer; Name: Word);
end;
constructor TIconData.Create;
begin
inherited Create;
FData := TList.Create;
end;
destructor TIconData.Destroy;
begin
Clear;
FData.Free;
inherited Destroy;
end;
procedure TIconData.Clear;
begin
if FNames <> nil then FreeMem(FNames);
FNames := nil;
if FList <> nil then FreeMem(FList);
FList := nil;
while FData.Count > 0 do begin
if Pointer(FData[0]) <> nil then FreeMem(Pointer(FData[0]));
FData.Delete(0);
end;
FillChar(FHeader, SizeOf(FHeader), 0);
end;
function TIconData.GetCount: Integer;
begin
Result := FData.Count;
end;
function TIconData.BuildResourceGroup(var Size: Integer): Pointer;
var
P: PDirectory;
List: PIconList;
I: Integer;
BI: PBitmapInfoHeader;
begin
Size := SizeOf(FHeader) + SizeOf(TIconDirectory) * FHeader.Count;
Result := AllocMem(Size);
try
Move(FHeader, Result^, SizeOf(FHeader));
P := PDirectory(PChar(Result) + SizeOf(FHeader));
List := PIconList(FList);
for I := 0 to FHeader.Count - 1 do begin
BI := PBitmapInfoHeader(Pointer(FData[I]));
with P^[I] do begin
if FHeader.wType = rc3_Cursor then begin
cWidth := List^[I].Width;
cHeight := List^[I].Height * 2;
end
else begin
Width := List^[I].Width;
Height := List^[I].Height;
Colors := List^[I].Colors;
Reserved := 0;
end;
Planes := BI^.biPlanes;
BitCount := BI^.biBitCount;
BytesInRes := List^[I].DIBSize;
if FHeader.wType = rc3_Cursor then
Inc(BytesInRes, SizeOf(TCursorHeader));
NameOrdinal := 0;
if FNames <> nil then NameOrdinal := FNames^[I];
end;
end;
except
FreeMem(Result);
raise;
end;
end;
function TIconData.BuildResourceItem(Index: Integer;
var Size: Integer): Pointer;
var
Icon: PIconRec;
P: Pointer;
begin
Icon := @(PIconList(FList)^[Index]);
Size := Icon^.DIBSize;
if FHeader.wType = rc3_Cursor then Inc(Size, SizeOf(TCursorHeader));
Result := AllocMem(Size);
try
P := Result;
if FHeader.wType = rc3_Cursor then begin
with PCursorHeader(Result)^ do begin
xHotspot := Icon^.Reserved1;
yHotspot := Icon^.Reserved2;
end;
Inc(PChar(P), SizeOf(TCursorHeader));
end;
Move(Pointer(FData[Index])^, P^, Icon^.DIBSize);
except
FreeMem(Result);
raise;
end;
end;
procedure TIconData.SetNameOrdinal(Index: Integer; Name: Word);
begin
if (FNames <> nil) and (Index >= 0) and (Index < FData.Count) then
FNames^[Index] := Name;
end;
procedure TIconData.LoadResourceGroup(Data: Pointer; Size: Integer);
var
P: PDirectory;
List: PIconList;
I: Integer;
begin
FHeader.Count := (Size - SizeOf(FHeader)) div SizeOf(TIconDirectory);
Move(Data^, FHeader, SizeOf(FHeader));
if FList <> nil then FreeMem(FList);
FList := AllocMem(SizeOf(TIconRec) * FHeader.Count);
while FData.Count > 0 do begin
if Pointer(FData[0]) <> nil then FreeMem(Pointer(FData[0]));
FData.Delete(0);
end;
P := PDirectory(PChar(Data) + SizeOf(FHeader));
List := PIconList(FList);
if FNames <> nil then FreeMem(FNames);
FNames := AllocMem(FHeader.Count * SizeOf(Word));
for I := 0 to FHeader.Count - 1 do begin
with List^[I] do begin
if FHeader.wType = rc3_Cursor then begin
Width := P^[I].cWidth;
Height := P^[I].cHeight div 2;
end
else begin
Width := P^[I].Width;
Height := P^[I].Height;
Colors := P^[I].Colors;
end;
DIBSize := P^[I].BytesInRes;
if FHeader.wType = rc3_Cursor then Dec(DIBSize, SizeOf(TCursorHeader));
Reserved1 := 0;
Reserved2 := 0;
end;
FData.Add(nil);
SetNameOrdinal(I, P^[I].NameOrdinal);
end;
end;
procedure TIconData.LoadResourceItem(Index: Integer; Data: Pointer;
Size: Integer);
var
P: Pointer;
Rec: PIconRec;
BI: PBitmapInfoHeader;
begin
if (Index < 0) or (Index >= FData.Count) then Exit;
Rec := @(PIconList(FList)^[Index]);
P := Data;
if FHeader.wType = rc3_Cursor then begin
with Rec^ do begin
Reserved1 := PCursorHeader(Data).xHotspot;
Reserved2 := PCursorHeader(Data).yHotspot;
end;
Inc(PChar(P), SizeOf(TCursorHeader));
Dec(Size, SizeOf(TCursorHeader));
end;
FData[Index] := AllocMem(Size);
Move(P^, Pointer(FData[Index])^, Min(Rec^.DIBSize, Size));
BI := PBitmapInfoHeader(Pointer(FData[Index]));
case BI^.biBitCount of
1, 4, 8: Rec^.Colors := (1 shl BI^.biBitCount) * BI^.biPlanes;
else Rec^.Colors := BI^.biBitCount * BI^.biPlanes;
end;
end;
procedure TIconData.SaveToStream(Stream: TStream);
var
I, J: Integer;
Data: Pointer;
begin
FHeader.Count := FData.Count;
Stream.WriteBuffer(FHeader, SizeOf(FHeader));
for I := 0 to FHeader.Count - 1 do begin
PIconList(FList)^[I].DIBOffset := SizeOf(FHeader) + (SizeOf(TIconRec) *
FHeader.Count);
for J := 0 to I - 1 do
Inc(PIconList(FList)^[I].DIBOffset, PIconList(FList)^[I - 1].DIBSize);
end;
Stream.WriteBuffer(FList^, SizeOf(TIconRec) * FHeader.Count);
for I := 0 to FHeader.Count - 1 do begin
Data := FData[I];
Stream.WriteBuffer(Data^, PIconList(FList)^[I].DIBSize);
end;
end;
procedure TIconData.LoadFromStream(Stream: TStream);
var
I: Integer;
Data: Pointer;
begin
Clear;
Stream.ReadBuffer(FHeader, SizeOf(FHeader));
if (not (FHeader.wType in [rc3_Icon, rc3_Cursor])) or
(FHeader.Count < 1) then InvalidIcon;
FList := AllocMem(SizeOf(TIconRec) * FHeader.Count);
try
Stream.ReadBuffer(FList^, SizeOf(TIconRec) * FHeader.Count);
for I := 0 to FHeader.Count - 1 do begin
Stream.Seek(PIconList(FList)^[I].DIBOffset, 0);
Data := AllocMem(PIconList(FList)^[I].DIBSize);
try
FData.Add(TObject(Data));
except
FreeMem(Data);
raise;
end;
Stream.ReadBuffer(Data^, PIconList(FList)^[I].DIBSize);
end;
FNames := AllocMem(FData.Count * SizeOf(Word));
FillChar(FNames^, FData.Count * SizeOf(Word), 0);
except
Clear;
raise;
end;
end;
{ TAddInNotifier }
procedure EnableMenuItem(Expert: TRxProjectResExpert;
AEnable: Boolean);
begin
with Expert.ProjectResourcesItem do
if (Expert.FResFileName <> '') and AEnable then
SetFlags(AllMenuFlags, GetFlags + [mfEnabled])
else
SetFlags(AllMenuFlags, GetFlags - [mfEnabled]);
end;
constructor TAddInNotifier.Create(AProjectResources: TRxProjectResExpert);
begin
inherited Create;
FProjectResources := AProjectResources;
end;
procedure TAddInNotifier.FileNotification(NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean);
begin
if FProjectResources = nil then Exit;
case NotifyCode of
fnProjectOpened:
begin
FProjectResources.OpenProject(FileName);
EnableMenuItem(FProjectResources, True);
end;
{$IFNDEF RX_D4}
fnProjectDesktopLoad:
FProjectResources.LoadDesktop(FileName);
fnProjectDesktopSave:
FProjectResources.SaveDesktop(FileName);
{$ENDIF}
end;
end;
{$IFDEF RX_D3}
procedure TAddInNotifier.EventNotification(NotifyCode: TEventNotification;
var Cancel: Boolean);
begin
{ Nothing to do here but needs to be overridden anyway }
end;
{$ENDIF}
{ TProjectNotifier }
constructor TProjectNotifier.Create(AProjectResources: TRxProjectResExpert);
begin
inherited Create;
FProjectResources := AProjectResources;
end;
procedure TProjectNotifier.Notify(NotifyCode: TNotifyCode);
begin
if FProjectResources = nil then Exit;
case NotifyCode of
ncModuleDeleted:
begin
if RxResourceEditor <> nil then RxResourceEditor.Close;
EnableMenuItem(FProjectResources, False);
FProjectResources.CloseProject;
end;
ncModuleRenamed, ncProjResModified:
begin
FProjectResources.UpdateProjectResInfo;
EnableMenuItem(FProjectResources, True);
end;
end;
end;
procedure TProjectNotifier.ComponentRenamed(const AComponent: TComponent;
const OldName, NewName: string);
begin
{ Nothing to do here but needs to be overridden anyway }
end;
{ TResourceEntry }
constructor TResourceEntry.Create(AEntry: TIResourceEntry);
var
P: PChar;
begin
inherited Create;
FChildren := TList.Create;
FHandle := AEntry.GetEntryHandle;
P := AEntry.GetResourceType;
if HiWord(Longint(P)) = 0 then begin
FResType := CheckResType(LoWord(Longint(P)));
FTypeId := LoWord(Longint(P));
end;
FType := ResTypeName(P);
P := AEntry.GetResourceName;
if HiWord(Longint(P)) = 0 then
FNameId := LoWord(Longint(P));
FName := StrText(P);
FSize := AEntry.GetDataSize;
end;
destructor TResourceEntry.Destroy;
begin
FChildren.Free;
inherited Destroy;
end;
function TResourceEntry.GetResourceName: PChar;
begin
if FNameId > 0 then Result := MakeIntResource(FNameId)
else Result := PChar(FName);
end;
function TResourceEntry.GetResourceType: PChar;
begin
if FTypeId > 0 then Result := MakeIntResource(FTypeId)
else Result := PChar(FType);
end;
function TResourceEntry.GetName: string;
begin
Result := FName;
end;
function TResourceEntry.GetTypeName: string;
begin
Result := FType;
end;
function TResourceEntry.EnableEdit: Boolean;
begin
Result := FResType in [rtpGroupCursor, rtpBitmap, rtpGroupIcon, rtpRCData,
rtpAniCursor, rtpCustom];
end;
function TResourceEntry.EnableRenameDelete: Boolean;
begin
Result := FResType in [rtpCustom, rtpGroupCursor, rtpBitmap, rtpGroupIcon,
rtpRCData, rtpAniCursor, rtpPredefined];
if (FResType = rtpGroupIcon) then
Result := CompareText(GetName, 'MAINICON') <> 0;
end;
function TResourceEntry.GetCursorOrIcon(ResFile: TIResourceFile;
IsIcon: Boolean): HIcon;
var
Entry, ChildEntry: TIResourceEntry;
I: Integer;
begin
Result := 0;
if not (FResType in [rtpGroupIcon, rtpGroupCursor]) then Exit;
Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
try
I := LookupIconIdFromDirectory(Entry.GetData, IsIcon);
if I > 0 then begin
if IsIcon then
ChildEntry := ResFile.FindEntry(RT_ICON, PChar(I))
else
ChildEntry := ResFile.FindEntry(RT_CURSOR, PChar(I));
if ChildEntry <> nil then
try
with ChildEntry do
Result := CreateIconFromResourceEx(GetData, GetDataSize,
IsIcon, $30000, 0, 0, $80);
finally
ChildEntry.Free;
end;
end;
finally
Entry.Free;
end;
end;
procedure TResourceEntry.GetIconData(ResFile: TIResourceFile; Stream: TStream);
var
Data: TIconData;
Entry: TIResourceEntry;
I: Integer;
P: PChar;
begin
if not (FResType in [rtpGroupIcon, rtpGroupCursor]) then Exit;
Data := TIconData.Create;
try
Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
try
Data.LoadResourceGroup(Entry.GetData, Entry.GetDataSize);
finally
Entry.Free;
end;
for I := 0 to Data.FHeader.Count - 1 do begin
P := MakeIntResource(Data.FNames^[I]);
if FResType = rtpGroupIcon then
Entry := ResFile.FindEntry(RT_ICON, P)
else {rtpGroupCursor}
Entry := ResFile.FindEntry(RT_CURSOR, P);
try
Data.LoadResourceItem(I, Entry.GetData, Entry.GetDataSize);
finally
Entry.Free;
end;
end;
Data.SaveToStream(Stream);
finally
Data.Free;
end;
end;
function TResourceEntry.GetBitmap(ResFile: TIResourceFile): TBitmap;
function GetDInColors(BitCount: Word): Integer;
begin
case BitCount of
1, 4, 8: Result := 1 shl BitCount;
else Result := 0;
end;
end;
var
Header: PBitmapFileHeader;
BI: PBitmapInfoHeader;
BC: PBitmapCoreHeader;
Entry: TIResourceEntry;
Mem: TMemoryStream;
ClrUsed: Integer;
begin
Result := nil;
if FResType <> rtpBitmap then Exit;
Mem := TMemoryStream.Create;
try
Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
try
Mem.SetSize(Entry.GetDataSize + SizeOf(TBitmapFileHeader));
Move(Entry.GetData^, Pointer(PChar(Mem.Memory) +
SizeOf(TBitmapFileHeader))^, Mem.Size);
Header := PBitmapFileHeader(Mem.Memory);
BI := PBitmapInfoHeader(PChar(Mem.Memory) + SizeOf(TBitmapFileHeader));
{ fill header }
with Header^ do begin
if BI^.biSize = SizeOf(TBitmapInfoHeader) then begin
ClrUsed := BI^.biClrUsed;
if ClrUsed = 0 then ClrUsed := GetDInColors(BI^.biBitCount);
bfOffBits := ClrUsed * SizeOf(TRGBQuad) +
SizeOf(TBitmapInfoHeader) + SizeOf(TBitmapFileHeader);
end
else begin
BC := PBitmapCoreHeader(PChar(Mem.Memory) +
SizeOf(TBitmapFileHeader));
ClrUsed := GetDInColors(BC^.bcBitCount);
bfOffBits := ClrUsed * SizeOf(TRGBTriple) +
SizeOf(TBitmapCoreHeader) + SizeOf(TBitmapFileHeader);
end;
bfSize := bfOffBits + BI^.biSizeImage;
bfType := $4D42; { BM }
end;
finally
Entry.Free;
end;
Result := TBitmap.Create;
try
Result.LoadFromStream(Mem);
except
Result.Free;
raise;
end;
finally
Mem.Free;
end;
end;
procedure TResourceEntry.GetData(ResFile: TIResourceFile; Stream: TStream);
var
Entry: TIResourceEntry;
begin
Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
try
Stream.WriteBuffer(Entry.GetData^, Entry.GetDataSize);
finally
Entry.Free;
end;
end;
function TResourceEntry.GetGraphic(ResFile: TIResourceFile): TGraphic;
begin
Result := nil;
case FResType of
rtpBitmap: Result := GetBitmap(ResFile);
rtpGroupIcon:
begin
Result := TIcon.Create;
try
TIcon(Result).Handle := GetCursorOrIcon(ResFile, True);
except
Result.Free;
raise;
end;
end;
end;
end;
function TResourceEntry.Rename(ResFile: TIResourceFile;
const NewName: string): Boolean;
var
P: PChar;
AName: string;
Id: Word;
Code: Integer;
Entry: TIResourceEntry;
begin
Result := False;
Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
try
Val(NewName, Id, Code);
if Code = 0 then P := MakeIntResource(Id)
else begin
if not IsValidIdent(NewName) then
raise Exception.Create(Format(sInvalidName, [NewName]));
AName := AnsiUpperCase(NewName);
P := PChar(AName);
end;
Result := Entry.Change(Entry.GetResourceType, P);
if Result then begin
P := Entry.GetResourceName;
if HiWord(Longint(P)) = 0 then FNameId := LoWord(Longint(P));
FName := StrText(P);
end;
finally
Entry.Free;
end;
end;
{ TRxProjectResExpert }
constructor TRxProjectResExpert.Create;
var
MainMenu: TIMainMenuIntf;
ProjSrcMenu: TIMenuItemIntf;
ViewMenu: TIMenuItemIntf;
MenuItems: TIMenuItemIntf;
begin
inherited Create;
FResourceList := TStringList.Create;
if Assigned(ToolServices) then begin
MainMenu := ToolServices.GetMainMenu;
if MainMenu <> nil then
try
MenuItems := MainMenu.GetMenuItems;
if MenuItems <> nil then
try
ProjSrcMenu := MainMenu.FindMenuItem('ViewPrjSourceItem');
if ProjSrcMenu <> nil then
try
ViewMenu := ProjSrcMenu.GetParent;
if ViewMenu <> nil then
try
ProjectResourcesItem := ViewMenu.InsertItem(
ProjSrcMenu.GetIndex, GetMenuText, 'ViewPrjResourceItem',
'', 0, 0, 0, [mfVisible], ProjectResourcesClick);
finally
ViewMenu.Free;
end;
finally
ProjSrcMenu.Free;
end;
finally
MenuItems.Free;
end;
finally
MainMenu.Free;
end;
AddInNotifier := TAddInNotifier.Create(Self);
{$IFDEF RX_D4}
ToolServices.AddNotifierEx(AddInNotifier);
{$ELSE}
ToolServices.AddNotifier(AddInNotifier);
{$ENDIF}
end;
end;
destructor TRxProjectResExpert.Destroy;
begin
if RxResourceEditor <> nil then RxResourceEditor.Free;
ToolServices.RemoveNotifier(AddInNotifier);
CloseProject;
ProjectResourcesItem.Free;
AddInNotifier.Free;
FResourceList.Free;
inherited Destroy;
end;
function TRxProjectResExpert.GetName: string;
begin
Result := sExpertName;
end;
function TRxProjectResExpert.GetAuthor: string;
begin
Result := '';
end;
function TRxProjectResExpert.GetComment: string;
begin
Result := '';
end;
function TRxProjectResExpert.GetPage: string;
begin
Result := '';
end;
function TRxProjectResExpert.GetGlyph: HICON;
begin
Result := 0;
end;
function TRxProjectResExpert.GetMenuText: string;
begin
Result := sMenuItemCaption;
end;
function TRxProjectResExpert.GetState: TExpertState;
begin
Result := [esEnabled];
end;
function TRxProjectResExpert.GetStyle: TExpertStyle;
begin
Result := esAddIn;
end;
function TRxProjectResExpert.GetIDString: string;
begin
Result := sExpertID;
end;
procedure TRxProjectResExpert.Execute;
begin
end;
procedure TRxProjectResExpert.BeginUpdate;
begin
Inc(FLockCount);
end;
procedure TRxProjectResExpert.EndUpdate;
begin
Dec(FLockCount);
if FLockCount = 0 then UpdateProjectResInfo;
end;
function TRxProjectResExpert.GetResFile: TIResourceFile;
begin
if ProjectModule.IsProjectModule then
Result := ProjectModule.GetProjectResource
else Result := nil;
end;
procedure TRxProjectResExpert.FindChildren(ResFile: TIResourceFile;
Entry: TResourceEntry);
var
I, Idx: Integer;
Header: PCursorOrIcon;
Directory: PDirectory;
Data: Pointer;
Child: TResourceEntry;
ResEntry: TIResourceEntry;
begin
if Entry = nil then Exit;
if Entry.FResType in [rtpGroupCursor, rtpGroupIcon] then begin
ResEntry := ResFile.GetEntryFromHandle(Entry.FHandle);
if ResEntry <> nil then
try
Data := ResEntry.GetData;
if Data <> nil then begin
Header := PCursorOrIcon(Data);
Directory := PDirectory(PChar(Data) + SizeOf(TCursorOrIcon));
for I := 0 to Header^.Count - 1 do begin
for Idx := 0 to FResourceList.Count - 1 do begin
Child := TResourceEntry(FResourceList.Objects[Idx]);
if (Child <> nil) and (Child.FParent = nil) and
(((Entry.FResType = rtpGroupIcon) and (Child.FResType = rtpIcon)) or
((Entry.FResType = rtpGroupCursor) and (Child.FResType = rtpCursor)))
and (Child.GetName = IntToStr(Directory^[I].NameOrdinal)) then
begin
Entry.FChildren.Add(Child);
Inc(Entry.FSize, Child.FSize);
Child.FParent := Entry;
end;
end;
end;
end;
finally
ResEntry.Free;
end;
end;
end;
procedure TRxProjectResExpert.LoadProjectResInfo; //!!!!!
var
I, Cnt: Integer;
RootNode, TypeNode: TTreeNode;
Entry: TResourceEntry;
ResEntry: TIResourceEntry;
TypeList: TStringList;
ResourceFile: TIResourceFile;
{$IFDEF RX_V110}
EditInt: TIEditorInterface;
IsNewProject: Boolean;
{$ENDIF}
begin
Cnt := -1;
try
ResourceFile := GetResFile;
except
ResourceFile := nil;
end;
try
if ResourceFile <> nil then
with ResourceFile do begin
FResFileName := FileName;
{$IFDEF RX_V110}
EditInt := ProjectModule.GetEditorInterface;
try
IsNewProject := not FileExists(EditInt.FileName);
finally
EditInt.Free;
end;
if IsNewProject or FileExists(FResFileName) then begin
try
Cnt := GetEntryCount;
if not FileExists(FResFileName) and (Cnt = 0) then begin
Cnt := -1;
FResFileName := '';
end;
except
Cnt := -1;
FResFileName := '';
end;
{ Access violation error is occured when specified }
{ resource file doesn't exist }
end
else begin
Cnt := -1;
FResFileName := '';
end;
{$ELSE}
Cnt := GetEntryCount;
{$ENDIF}
for I := 0 to Cnt - 1 do begin
ResEntry := GetEntry(I);
if ResEntry <> nil then begin
try
Entry := TResourceEntry.Create(ResEntry);
finally
ResEntry.Free;
end;
FResourceList.AddObject(Entry.GetName, Entry);
end;
end;
for I := 0 to FResourceList.Count - 1 do begin
Entry := TResourceEntry(FResourceList.Objects[I]);
FindChildren(ResourceFile, Entry);
end;
end;
if (RxResourceEditor <> nil) and (ResourceFile <> nil) and (Cnt >= 0) then
begin
with RxResourceEditor do begin
StatusBar.Panels[0].Text := FResFileName;
ResTree.Items.BeginUpdate;
try
TypeList := TStringList.Create;
try
TypeList.Sorted := True;
TypeList.Duplicates := dupIgnore;
RootNode := ResTree.Items.Add(nil, ExtractFileName(FResFileName));
RootNode.ImageIndex := 9; { Delphi Project }
RootNode.SelectedIndex := RootNode.ImageIndex;
for I := 0 to FResourceList.Count - 1 do begin
Entry := TResourceEntry(FResourceList.Objects[I]);
if (Entry = nil) or (Entry.FParent <> nil) then
Continue; { ignore cursors and icons, use groups }
Cnt := TypeList.IndexOf(Entry.GetTypeName);
if Cnt < 0 then begin
TypeNode := ResTree.Items.AddChildObject(RootNode,
Entry.GetTypeName, nil);
TypeNode.ImageIndex := 0; { Collapsed Folder }
TypeNode.SelectedIndex := TypeNode.ImageIndex;
TypeList.AddObject(Entry.GetTypeName, TypeNode);
end
else
TypeNode := TTreeNode(TypeList.Objects[Cnt]);
Entry.FEntryNode := ResTree.Items.AddChildObject(TypeNode,
Entry.GetName, Entry);
Entry.FEntryNode.ImageIndex := ResImages[Entry.FResType];
Entry.FEntryNode.SelectedIndex := Entry.FEntryNode.ImageIndex;
end;
RootNode.Expanded := True;
finally
TypeList.Free;
end;
finally
ResTree.Items.EndUpdate;
end;
end;
end;
finally
ResourceFile.Free;
end;
end;
procedure TRxProjectResExpert.ClearProjectResInfo;
var
I: Integer;
begin
FResFileName := '';
if RxResourceEditor <> nil then begin
RxResourceEditor.ResTree.Items.Clear;
RxResourceEditor.StatusBar.Panels[0].Text := '';
end;
for I := 0 to FResourceList.Count - 1 do
TResourceEntry(FResourceList.Objects[I]).Free;
FResourceList.Clear;
end;
procedure TRxProjectResExpert.UpdateProjectResInfo;
var
TreeState: TStringList;
Node, ChildNode: TTreeNode;
I: Integer;
begin
if FLockCount > 0 then Exit;
if RxResourceEditor <> nil then
RxResourceEditor.ResTree.Items.BeginUpdate;
try
TreeState := TStringList.Create;
try
if RxResourceEditor <> nil then begin
if FSelection.ResType = '' then begin
{ save selection }
Node := RxResourceEditor.ResTree.Selected;
if Node <> nil then begin
if (Node.Data <> nil) then begin
FSelection.ResName := TResourceEntry(Node.Data).GetName;
FSelection.ResType := TResourceEntry(Node.Data).GetTypeName;
end
else begin
FSelection.ResName := '';
FSelection.ResType := Node.Text;
end;
end;
end;
{ save tree state }
Node := RxResourceEditor.ResTree.Items.GetFirstNode;
if Node <> nil then ChildNode := Node.GetFirstChild
else ChildNode := nil;
while ChildNode <> nil do begin
TreeState.AddObject(ChildNode.Text, TObject(ChildNode.Expanded));
ChildNode := Node.GetNextChild(ChildNode);
end;
end;
Inc(FLockCount);
try
ClearProjectResInfo;
try
LoadProjectResInfo;
except
ClearProjectResInfo;
end;
finally
Dec(FLockCount);
end;
if (RxResourceEditor <> nil) then begin
{ restore tree state }
Node := RxResourceEditor.ResTree.Items.GetFirstNode;
if Node <> nil then begin
ChildNode := Node.GetFirstChild;
while ChildNode <> nil do begin
I := TreeState.IndexOf(ChildNode.Text);
if I >= 0 then
ChildNode.Expanded := Boolean(TreeState.Objects[I]);
ChildNode := Node.GetNextChild(ChildNode);
end;
end;
if (FSelection.ResName <> '') or (FSelection.ResType <> '') then
begin { restore selection }
with FSelection do
Node := FindNode(RxResourceEditor.ResTree, nil, ResName, ResType);
if Node <> nil then begin
if Node.Parent <> nil then Node.Parent.Expanded := True;
Node.Selected := True;
end;
end;
end;
finally
TreeState.Free;
with FSelection do begin
ResName := '';
ResType := '';
end;
end;
finally
if RxResourceEditor <> nil then
RxResourceEditor.ResTree.Items.EndUpdate;
end;
end;
procedure TRxProjectResExpert.OpenProject(const FileName: string);
begin
CloseProject;
ProjectModule := ToolServices.GetModuleInterface(FileName);
if ProjectModule <> nil then begin
ProjectNotifier := TProjectNotifier.Create(Self);
ProjectModule.AddNotifier(ProjectNotifier);
try
LoadProjectResInfo;
FProjectName := FileName;
except
ClearProjectResInfo;
end;
end;
end;
procedure TRxProjectResExpert.CloseProject;
begin
if ProjectModule <> nil then begin
ClearProjectResInfo;
ProjectModule.RemoveNotifier(ProjectNotifier);
ProjectNotifier.Free;
ProjectModule.Free;
ProjectNotifier := nil;
ProjectModule := nil;
FProjectName := '';
end;
end;
{$IFNDEF RX_D4}
procedure TRxProjectResExpert.LoadDesktop(const FileName: string);
var
Desktop: TIniFile;
begin
Desktop := TIniFile.Create(FileName);
try
if DeskTop.ReadBool(sExpertName, sVisible, False) then
ProjectResourcesClick(nil)
else if RxResourceEditor <> nil then RxResourceEditor.Close;
finally
Desktop.Free;
end;
end;
procedure TRxProjectResExpert.SaveDesktop(const FileName: string);
var
Desktop: TIniFile;
Visible: Boolean;
begin
Desktop := TIniFile.Create(FileName);
try
Visible := (RxResourceEditor <> nil) and RxResourceEditor.Visible;
DeskTop.WriteBool(sExpertName, sVisible, Visible);
finally
Desktop.Free;
end;
end;
{$ENDIF}
procedure TRxProjectResExpert.ProjectResourcesClick(Sender: TIMenuItemIntf);
var
Reopen: Boolean;
ProjectName: string;
ResourceFile: TIResourceFile;
begin
ResourceFile := GetResFile;
try
if Assigned(ResourceFile) then begin
Reopen := RxResourceEditor = nil;
CreateForm(TRxResourceEditor, RxResourceEditor);
RxResourceEditor.FExpert := Self;
ProjectName := ToolServices.GetProjectName;
if Reopen or (FProjectName <> ProjectName) then begin
if ProjectName <> '' then OpenProject(ProjectName);
end;
RxResourceEditor.Show;
end;
finally
ResourceFile.Free;
end;
end;
procedure TRxProjectResExpert.MarkModified;
var
EditorInterface: TIEditorInterface;
begin
if ProjectModule <> nil then begin
EditorInterface := ProjectModule.GetEditorInterface;
try
EditorInterface.MarkModified;
finally
EditorInterface.Free;
end;
end;
end;
procedure TRxProjectResExpert.CheckRename(ResFile: TIResourceFile;
ResType, NewName: PChar);
var
Entry: TIResourceEntry;
begin
Entry := ResFile.FindEntry(ResType, NewName);
try
if Entry <> nil then
raise Exception.Create(Format(sCannotRename, [NewName]));
finally
Entry.Free;
end;
end;
function TRxProjectResExpert.UniqueName(ResFile: TIResourceFile;
ResType: PChar; var Index: Integer): string;
var
N: Integer;
Entry: TIResourceEntry;
procedure CheckItemName;
begin
if (ResType = RT_ICON) or (ResType = RT_CURSOR) then begin
Result := IntToStr(N);
Entry := ResFile.FindEntry(ResType, PChar(N));
end
else begin
Result := Format(ResTypeName(ResType) + '_%d', [N]);
Entry := ResFile.FindEntry(ResType, PChar(Result));
end;
end;
begin
N := 1;
Index := 0;
CheckItemName;
while Entry <> nil do begin
Entry.Free;
Inc(N);
CheckItemName;
end;
if (ResType = RT_ICON) or (ResType = RT_CURSOR) then Index := N;
end;
function TRxProjectResExpert.DeleteEntry(ResFile: TIResourceFile;
Entry: TResourceEntry): Boolean;
var
I: Integer;
P: Pointer;
Child: TResourceEntry;
ResourceFile: TIResourceFile;
begin
Result := False;
if ResFile = nil then ResourceFile := GetResFile
else ResourceFile := ResFile;
try
if (ResourceFile <> nil) and (Entry <> nil) then begin
BeginUpdate;
try
P := Entry.FHandle;
Result := ResourceFile.DeleteEntry(P);
if Result then
try
{ delete children }
for I := 0 to Entry.FChildren.Count - 1 do begin
Child := TResourceEntry(Entry.FChildren[I]);
if Child <> nil then
ResourceFile.DeleteEntry(Child.FHandle);
end;
finally
MarkModified;
end;
finally
EndUpdate;
end;
end;
finally
if ResFile = nil then ResourceFile.Free;
end;
end;
procedure TRxProjectResExpert.CreateEntry(ResFile: TIResourceFile;
ResType, ResName: PChar; ADataSize: Integer; AData: Pointer;
SetToEntry: Boolean);
var
I: Integer;
S: string;
ResourceFile: TIResourceFile;
Entry: TIResourceEntry;
begin
BeginUpdate;
try
if ResFile = nil then ResourceFile := GetResFile
else ResourceFile := ResFile;
try
if ResName = nil then begin
S := UniqueName(ResourceFile, ResType, I);
if I > 0 then ResName := PChar(I)
else ResName := PChar(S);
end;
if not IsValidIdent(StrText(ResName)) then
raise Exception.Create(Format(sInvalidName, [StrText(ResName)]));
CheckRename(ResourceFile, ResType, ResName);
{$IFNDEF RX_D3}
if ResourceFile.GetEntryCount > 0 then begin
for I := 0 to ResourceFile.GetEntryCount - 1 do
ResourceFile.GetEntry(I).Free;
end;
{$ENDIF}
Entry := ResourceFile.CreateEntry(ResType, ResName,
MOVEABLE or DISCARDABLE, LANG_NEUTRAL, 0, 0, 0);
if (Entry = nil) then
raise Exception.Create(Format(sCannotRename, [StrText(ResName)]));
with Entry do
try
if SetToEntry then begin
FSelection.ResName := StrText(GetResourceName);
FSelection.ResType := ResTypeName(GetResourceType);
end;
SetDataSize(PadUp(ADataSize));
FillChar(GetData^, GetDataSize, 0);
if GetDataSize < ADataSize then ADataSize := GetDataSize;
Move(AData^, GetData^, ADataSize);
finally
Free;
end;
MarkModified;
finally
if ResFile = nil then ResourceFile.Free;
end;
finally
EndUpdate;
end;
end;
procedure TRxProjectResExpert.NewCursorIconRes(ResFile: TIResourceFile;
ResName: PChar; IsIcon: Boolean; Stream: TStream);
var
ResType: PChar;
Data: TIconData;
ResData: Pointer;
I, ResSize, NameOrd: Integer;
ResourceFile: TIResourceFile;
GroupName: string;
begin
Data := TIconData.Create;
try
Data.LoadFromStream(Stream);
if IsIcon then Data.FHeader.wType := rc3_Icon
else Data.FHeader.wType := rc3_Cursor;
if Data.GetCount > 0 then begin
BeginUpdate;
try
if ResFile = nil then ResourceFile := GetResFile
else ResourceFile := ResFile;
try
if IsIcon then ResType := RT_ICON
else ResType := RT_CURSOR;
for I := 0 to Data.GetCount - 1 do begin
ResData := Data.BuildResourceItem(I, ResSize);
try
UniqueName(ResourceFile, ResType, NameOrd);
CreateEntry(ResourceFile, ResType, PChar(NameOrd), ResSize,
ResData, False);
Data.SetNameOrdinal(I, NameOrd);
finally
FreeMem(ResData);
end;
end;
if IsIcon then ResType := RT_GROUP_ICON
else ResType := RT_GROUP_CURSOR;
if ResName = nil then begin
GroupName := UniqueName(ResourceFile, ResType, NameOrd);
ResName := PChar(GroupName);
end;
ResData := Data.BuildResourceGroup(ResSize);
try
CreateEntry(ResourceFile, ResType, ResName, ResSize,
ResData, True);
finally
FreeMem(ResData);
end;
finally
if ResFile = nil then ResourceFile.Free;
end;
finally
EndUpdate;
end;
end;
finally
Data.Free;
end;
end;
procedure TRxProjectResExpert.EditCursorIconRes(Entry: TResourceEntry;
IsIcon: Boolean; Stream: TStream);
var
ResFile: TIResourceFile;
CI: TCursorOrIcon;
begin
BeginUpdate;
try
ResFile := GetResFile;
try
if not Entry.EnableRenameDelete { 'MAINICON' } then begin
Stream.ReadBuffer(CI, SizeOf(CI));
Stream.Seek(-SizeOf(CI), soFromCurrent);
if (CI.Count < 1) or not (CI.wType in [rc3_Icon, rc3_Cursor]) then
InvalidIcon;
end;
DeleteEntry(ResFile, Entry);
NewCursorIconRes(ResFile, Entry.GetResourceName, IsIcon, Stream);
finally
ResFile.Free;
end;
finally
EndUpdate;
end;
end;
procedure TRxProjectResExpert.NewBitmapRes(ResFile: TIResourceFile;
ResName: PChar; Bitmap: TBitmap);
var
Mem: TMemoryStream;
begin
Mem := TMemoryStream.Create;
try
Bitmap.SaveToStream(Mem);
Mem.Position := 0;
CreateEntry(ResFile, RT_BITMAP, ResName, Mem.Size - SizeOf(TBitmapFileHeader),
Pointer(PChar(Mem.Memory) + SizeOf(TBitmapFileHeader)), True);
finally
Mem.Free;
end;
end;
procedure TRxProjectResExpert.EditBitmapRes(Entry: TResourceEntry;
Bitmap: TBitmap);
var
ResFile: TIResourceFile;
begin
BeginUpdate;
try
ResFile := GetResFile;
try
DeleteEntry(ResFile, Entry);
NewBitmapRes(ResFile, Entry.GetResourceName, Bitmap);
finally
ResFile.Free;
end;
finally
EndUpdate;
end;
end;
procedure TRxProjectResExpert.NewBinaryRes(ResFile: TIResourceFile;
ResName, ResType: PChar; Stream: TMemoryStream);
begin
Stream.Position := 0;
CreateEntry(ResFile, ResType, ResName, Stream.Size, Stream.Memory, True);
end;
procedure TRxProjectResExpert.EditBinaryRes(Entry: TResourceEntry;
Stream: TMemoryStream);
var
ResFile: TIResourceFile;
begin
BeginUpdate;
try
ResFile := GetResFile;
try
DeleteEntry(ResFile, Entry);
NewBinaryRes(ResFile, Entry.GetResourceName, Entry.GetResourceType,
Stream);
finally
ResFile.Free;
end;
finally
EndUpdate;
end;
end;
{ TRxResourceEditor }
procedure TRxResourceEditor.FormCreate(Sender: TObject);
{$IFDEF RX_D4}
var
I: Integer;
{$ENDIF}
begin
TreeImages.ResourceLoad(rtBitmap, 'RXRESEXPIMG', clFuchsia);
{$IFDEF RX_D3}
ResTree.RightClickSelect := True;
{$ENDIF}
{$IFDEF RX_D4}
PopupMenu.Images := TreeImages;
for I := 0 to PopupMenu.Items.Count - 1 do
if PopupMenu.Items[I].Tag > 0 then
PopupMenu.Items[I].ImageIndex := PopupMenu.Items[I].Tag;
for I := 0 to NewItem.Count - 1 do
if NewItem.Items[I].Tag > 0 then
NewItem.Items[I].ImageIndex := NewItem.Items[I].Tag;
{$ENDIF RX_D4}
with Placement do begin
IniFileName := ToolServices.GetBaseRegistryKey;
IniSection := sExpertID;
end;
end;
procedure TRxResourceEditor.FormDestroy(Sender: TObject);
begin
RxResourceEditor := nil;
end;
procedure TRxResourceEditor.ResTreeExpanded(Sender: TObject;
Node: TTreeNode);
begin
if Node.ImageIndex = 0 then begin
Node.ImageIndex := 1;
Node.SelectedIndex := Node.ImageIndex;
end;
end;
procedure TRxResourceEditor.ResTreeCollapsed(Sender: TObject;
Node: TTreeNode);
begin
if Node.ImageIndex = 1 then begin
Node.ImageIndex := 0;
Node.SelectedIndex := Node.ImageIndex;
end;
end;
procedure TRxResourceEditor.ResTreeEditing(Sender: TObject;
Node: TTreeNode; var AllowEdit: Boolean);
var
Entry: TResourceEntry;
begin
if (Node.Data = nil) then AllowEdit := False
else begin
Entry := TResourceEntry(Node.Data);
AllowEdit := Entry.EnableRenameDelete;
end;
end;
procedure TRxResourceEditor.ResTreeEdited(Sender: TObject; Node: TTreeNode;
var S: string);
var
Entry: TResourceEntry;
RF: TIResourceFile;
begin
if (Node.Data <> nil) then begin
Entry := TResourceEntry(Node.Data);
Inc(FExpert.FLockCount);
try
RF := FExpert.GetResFile;
try
S := AnsiUpperCase(S);
FExpert.CheckRename(RF, Entry.GetResourceType, ResIdent(S));
if Entry.Rename(RF, S) then begin
Node.Text := Entry.GetName;
FExpert.MarkModified;
end
else Beep;
finally
RF.Free;
end;
finally
Dec(FExpert.FLockCount);
S := Node.Text;
end;
end;
end;
procedure TRxResourceEditor.PopupMenuPopup(Sender: TObject);
var
Node: TTreeNode;
Entry: TResourceEntry;
begin
Node := ResTree.Selected;
if (Node <> nil) and (Node.Data <> nil) then begin
Entry := TResourceEntry(Node.Data);
EditItem.Enabled := Entry.EnableEdit;
RenameItem.Enabled := Entry.EnableRenameDelete;
DeleteItem.Enabled := RenameItem.Enabled;
PreviewItem.Enabled := Entry.FResType in [rtpBitmap, rtpGroupIcon,
rtpGroupCursor];
SaveItem.Enabled := Entry.FResType in [rtpGroupCursor, rtpGroupIcon,
rtpBitmap, rtpAniCursor, rtpRCData, rtpCustom];
ResTree.Selected := Node;
end
else begin
EditItem.Enabled := False;
RenameItem.Enabled := False;
DeleteItem.Enabled := False;
PreviewItem.Enabled := False;
SaveItem.Enabled := False;
end;
end;
procedure TRxResourceEditor.RenameItemClick(Sender: TObject);
var
Node: TTreeNode;
begin
Node := ResTree.Selected;
if Node <> nil then Node.EditText;
end;
procedure TRxResourceEditor.EditItemClick(Sender: TObject);
var
Node: TTreeNode;
ResFile: TIResourceFile;
Entry: TResourceEntry;
Graphic: TGraphic;
Stream: TStream;
begin
Node := ResTree.Selected;
if Node <> nil then begin
Entry := TResourceEntry(Node.Data);
if (Entry <> nil) and Entry.EnableEdit then begin
case Entry.FResType of
rtpGroupCursor,
rtpGroupIcon:
begin
if Entry.FResType = rtpGroupCursor then
OpenDlg.Filter := sCursorFilesFilter
else
OpenDlg.Filter := sIconFilesFilter + '|' + sCursorFilesFilter;
OpenDlg.FileName := '';
if OpenDlg.Execute then begin
Stream := TFileStream.Create(OpenDlg.FileName, fmOpenRead +
fmShareDenyNone);
try
FExpert.EditCursorIconRes(Entry, Entry.FResType =
rtpGroupIcon, Stream);
finally
Stream.Free;
end;
end;
end;
rtpBitmap:
begin
ResFile := FExpert.GetResFile;
try
Graphic := Entry.GetGraphic(ResFile);
finally
ResFile.Free;
end;
try
if EditGraphic(Graphic, nil, Entry.GetName) then begin
if not Graphic.Empty then
FExpert.EditBitmapRes(Entry, TBitmap(Graphic))
else if Entry.EnableRenameDelete then
FExpert.DeleteEntry(nil, Entry);
end;
finally
Graphic.Free;
end;
end;
rtpAniCursor,
rtpRCData,
rtpCustom:
begin
if Entry.FResType = rtpAniCursor then
OpenDlg.Filter := sAniCursorFilesFilter
else
OpenDlg.Filter := sAllFilesFilter;
OpenDlg.FileName := '';
if OpenDlg.Execute then begin
Stream := TMemoryStream.Create;
try
TMemoryStream(Stream).LoadFromFile(OpenDlg.FileName);
FExpert.EditBinaryRes(Entry, TMemoryStream(Stream));
finally
Stream.Free;
end;
end;
end;
else Exit;
end;
end;
end;
end;
procedure TRxResourceEditor.DeleteItemClick(Sender: TObject);
var
Node: TTreeNode;
Entry: TResourceEntry;
begin
Node := ResTree.Selected;
if Node <> nil then begin
Entry := TResourceEntry(Node.Data);
if (Entry <> nil) and Entry.EnableRenameDelete then
FExpert.DeleteEntry(nil, Entry);
end;
end;
procedure TRxResourceEditor.NewBitmapItemClick(Sender: TObject);
var
Bitmap: TBitmap;
begin
Bitmap := TBitmap.Create;
try
if EditGraphic(Bitmap, TBitmap, sNewBitmap) then begin
if not Bitmap.Empty then
FExpert.NewBitmapRes(nil, nil, Bitmap);
end;
finally
Bitmap.Free;
end;
end;
procedure TRxResourceEditor.NewIconItemClick(Sender: TObject);
var
Stream: TStream;
begin
OpenDlg.Filter := sIconFilesFilter + '|' + sCursorFilesFilter;
OpenDlg.FileName := '';
if OpenDlg.Execute then begin
Stream := TFileStream.Create(OpenDlg.FileName, fmOpenRead +
fmShareDenyNone);
try
FExpert.NewCursorIconRes(nil, nil, True, Stream);
finally
Stream.Free;
end;
end;
end;
procedure TRxResourceEditor.NewCursorItemClick(Sender: TObject);
var
Stream: TStream;
begin
OpenDlg.Filter := sCursorFilesFilter + '|' + sAniCursorFilesFilter;
OpenDlg.FileName := '';
if OpenDlg.Execute then begin
if AnsiCompareText(ExtractFileExt(OpenDlg.FileName), '.ani') = 0 then begin
Stream := TMemoryStream.Create;
try
TMemoryStream(Stream).LoadFromFile(OpenDlg.FileName);
FExpert.NewBinaryRes(nil, nil, RT_ANICURSOR, TMemoryStream(Stream));
finally
Stream.Free;
end;
end
else begin
Stream := TFileStream.Create(OpenDlg.FileName, fmOpenRead +
fmShareDenyNone);
try
FExpert.NewCursorIconRes(nil, nil, False, Stream);
finally
Stream.Free;
end;
end;
end;
end;
procedure TRxResourceEditor.CheckResourceType(Sender: TObject;
var TypeName: string; var Apply: Boolean);
begin
TypeName := AnsiUpperCase(TypeName);
Apply := IsValidResType(TypeName) or (TypeName = ResTypeName(RT_RCDATA));
if not Apply then
raise Exception.Create(Format(sInvalidType, [TypeName]));
end;
function TRxResourceEditor.GetResourceTypeName: string;
var
I: Integer;
Entry: TResourceEntry;
begin
Result := ResTypeName(RT_RCDATA);
with TInputBox.Create(Application) do
try
Value := Result;
Caption := SNewResource;
Prompt := sResType;
OnApply := CheckResourceType;
with FExpert do
for I := 0 to FResourceList.Count - 1 do begin
Entry := TResourceEntry(FResourceList.Objects[I]);
if (Entry <> nil) and (Entry.FResType in [rtpCustom, rtpRCData]) then
if Strings.IndexOf(ResTypeName(Entry.GetResourceType)) < 0 then
Strings.Add(ResTypeName(Entry.GetResourceType));
end;
if Execute then Result := Value
else Result := '';
finally
Free;
end;
end;
procedure TRxResourceEditor.NewUserDataItemClick(Sender: TObject);
var
Mem: TMemoryStream;
TypeName: string;
Code: Integer;
Id: Word;
P: PChar;
begin
TypeName := AnsiUpperCase(GetResourceTypeName);
if TypeName = '' then Exit;
Val(TypeName, Id, Code);
if TypeName = ResTypeName(RT_RCDATA) then P := RT_RCDATA
else if Code = 0 then P := MakeIntResource(Id)
else P := PChar(TypeName);
OpenDlg.Filter := sAllFilesFilter;
OpenDlg.FileName := '';
if OpenDlg.Execute then begin
Mem := TMemoryStream.Create;
try
Mem.LoadFromFile(OpenDlg.FileName);
FExpert.NewBinaryRes(nil, nil, P, Mem);
finally
Mem.Free;
end;
end;
end;
procedure TRxResourceEditor.PreviewItemClick(Sender: TObject);
begin
{ not implemented yet, item is invisible }
end;
procedure TRxResourceEditor.SaveItemClick(Sender: TObject);
var
Node: TTreeNode;
ResFile: TIResourceFile;
Entry: TResourceEntry;
Graphic: TGraphic;
Stream: TStream;
begin
{ save resource }
Node := ResTree.Selected;
if Node <> nil then begin
Entry := TResourceEntry(Node.Data);
if (Entry <> nil) then begin
with SaveDlg do begin
case Entry.FResType of
rtpGroupCursor:
begin
Filter := sCursorFilesFilter + '|' + sAllFilesFilter;
DefaultExt := 'cur';
end;
rtpGroupIcon:
begin
Filter := sIconFilesFilter + '|' + sAllFilesFilter;
DefaultExt := GraphicExtension(TIcon);
end;
rtpBitmap:
begin
Filter := GraphicFilter(TBitmap) + '|' + sAllFilesFilter;
DefaultExt := GraphicExtension(TBitmap);
end;
rtpAniCursor:
begin
Filter := sAniCursorFilesFilter + '|' + sAllFilesFilter;
DefaultExt := 'ani';
end;
else
begin
Filter := sAllFilesFilter;
DefaultExt := '';
end;
end;
FileName := '';
end;
if SaveDlg.Execute then begin
ResFile := FExpert.GetResFile;
try
case Entry.FResType of
rtpBitmap:
begin
Graphic := Entry.GetGraphic(ResFile);
try
Graphic.SaveToFile(SaveDlg.FileName);
finally
Graphic.Free;
end;
end;
rtpGroupCursor, rtpGroupIcon,
rtpAniCursor, rtpRCData, rtpCustom:
begin
Stream := TFileStream.Create(SaveDlg.FileName, fmCreate);
try
if Entry.FResType in [rtpGroupCursor, rtpGroupIcon] then
Entry.GetIconData(ResFile, Stream)
else Entry.GetData(ResFile, Stream);
finally
Stream.Free;
end;
end;
else Exit;
end;
finally
ResFile.Free;
end;
end;
end;
end;
end;
procedure TRxResourceEditor.ResTreeKeyPress(Sender: TObject;
var Key: Char);
begin
if (Key = Char(VK_RETURN)) then begin
EditItemClick(Sender);
Key := #0;
end;
end;
procedure TRxResourceEditor.ResTreeDblClick(Sender: TObject);
begin
EditItemClick(Sender);
end;
procedure TRxResourceEditor.ResTreeChange(Sender: TObject;
Node: TTreeNode);
var
Entry: TResourceEntry;
S: string;
begin
S := '';
if Node <> nil then begin
Entry := TResourceEntry(Node.Data);
if Entry <> nil then begin
if Entry.FResType in [rtpGroupCursor, rtpGroupIcon] then
S := Format('%d image(s) ', [Entry.FChildren.Count]);
S := S + Format('%d byte(s)', [Entry.FSize]);
end;
end;
if S = '' then S := FExpert.FResFileName;
StatusBar.Panels[0].Text := S;
end;
procedure TRxResourceEditor.StatusBarDrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
var
Offset: Integer;
begin
with StatusBar do begin
Offset := Max(0, (HeightOf(Rect) - Canvas.TextHeight('Wg')) div 2);
WriteText(Canvas, Rect, Offset, Offset, MinimizeText(Panels[0].Text,
Canvas, WidthOf(Rect) - Height), taLeftJustify, False);
end;
end;
initialization
RxResourceEditor := nil;
end.