rxresexp.pas

rxlib2.75控件包

{*******************************************************}
{                                                       }
{         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';