ion TPackage.GetIDEInfo(Index: Integer): TIDEInfo;
begin
if (Index in [0..(FPageInfos.Count - 1)]) then
begin
Result := TIDEInfo(FPageInfos[Index]^);
end;
end;
procedure TPackage.LoadPackage;
var
Flags : Integer;
I : Integer;
UnitName : string;
begin
FPageInfos := TList.Create;
FContainsUnit := TStringList.Create;
FRequiresPackage := TStringList.Create;
FDcpBpiName := TStringList.Create;
FPackHandle := SysUtils.LoadPackage(FPackageFileName);
CurrentPackage := Self;
GetPackageInfo(FPackHandle, @FPackHandle, Flags, EveryUnit);
end;
function TPackage.RegClassInPackage: Boolean;
//该函数只能在工程文件需要VCL，RTL两个包文件时才能用
//因为我们需要把全局的函数指针Classes.RegisterComponentsProc指向我们自己
//函数（该函数为IDE准备，IDE会为它设定函数而我们的程序也要模仿IDE为它设定函数）。
//如果不是带VCL和RTL两个包，那么我们设置的只是我们本身Classes单元的函数指针
//而不是包括Package的全局的。
//
//而有趣的是如果我们的工程不带包运行，那么我们基本上可以同时用它来查看最近几个版本的
//Borland编译器所产生的包文件而不会产生异常，但是控件不能够注册了。
var
I : Integer;
oldProc : Pointer;
RegProc : procedure();
RegProcName, UnitName: string;
begin
oldProc := @Classes.RegisterComponentsProc;
Classes.RegisterComponentsProc := @RegComponentsProc;
FPageInfos.Clear;
try
try
for i := 0 to FContainsUnit.Count - 1 do
begin
RegProc := nil;
UnitName := FContainsUnit[I];
RegProcName := ''''@'''' + UpCase(UnitName[1])
+ LowerCase(Copy(UnitName, 2, Length(UnitName))) + ''''@Register$qqrv'''';
//后面这个字符串@Register$qqrv是Borland定死了的，Delphi5，6，7，BCB5，6都是这样子的
//Delphi3是Name + ''''.Register@51F89FF7''''。而Delphi4手里没有，不曾试验过
RegProc := GetProcAddress(FPackHandle,
PChar(RegProcName));
if Assigned(RegProc) then
begin
CurrentPackage := Self;
RegProc;
end;
end;
except
UnRegisterModuleClasses(FPackHandle);
ClearPageInfo;
Result := True;
Exit;
end;
finally
Classes.RegisterComponentsProc := oldProc;
end;
end;
end.
调用如下
{ *********************************************************************** }
{ }
{ 程序主窗体单元 }
{ }
{ wr960204(王锐)2003-2-20 }
{ }
{ *********************************************************************** }
unit Unit1;
interface
uses
UnitPackageInfo,
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
GroupBox1: TGroupBox;
Panel1: TPanel;
ListBox1: TListBox;
Button1: TButton;
Button2: TButton;
OpenDialog1: TOpenDialog;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
FPack: TPackage;
procedure FreePack;
public
{ Public declarations }
end;
var
Form1 : TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
I : Integer;
begin
if OpenDialog1.Execute then
begin
FreePack;
FPack := TPackage.Create(OpenDialog1.FileName);
FPack.RegClassInPackage;
end;
ListBox1.Items.Clear;
for i := 0 to FPack.IDEInfoCount - 1 do
begin
ListBox1.Items.Add(FPack.IDEInfo[I].iClass.ClassName);
end;
Memo1.Lines.Clear;
Memo1.Lines.Add(''''------ContainsUnitList:-------'''');
for i := 0 to FPack.ContainsUnit.Count - 1 do
begin
Memo1.Lines.Add(FPack.ContainsUnit[I]);
end;
Memo1.Lines.Add(''''------DcpBpiNameList:-------'''');
for i := 0 to FPack.DcpBpiName.Count - 1 do
begin
Memo1.Lines.Add(FPack.DcpBpiName[I]);
end;
Memo1.Lines.Add(''''--------RequiresPackageList:---------'''');
for i := 0 to FPack.RequiresPackage.Count - 1 do
begin
Memo1.Lines.Add(FPack.RequiresPackage[I]);
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreePack;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Ctrl : TControl;
begin
if (ListBox1.ItemIndex <> -1) and (FPack <> nil) then
begin //判断如果不是TControl的子类创建了也看不见，就不创建了
if (FPack.IDEInfo[ListBox1.ItemIndex].iClass.InheritsFrom(TControl)) then
begin
Ctrl := nil;
try
Ctrl := TControl(FPack.IDEInfo[ListBox1.ItemIndex].iClass.Create(Self));
Ctrl.Parent := Panel1;
Ctrl.SetBounds(0, 0, 100, 100);
Ctrl.Visible := True;
except
end;
end;
end;
end;
procedure TForm1.FreePack;
var
I : Integer;
begin
for i := Panel1.ControlCount - 1 downto 0 do
Panel1.Controls[i].Free;
FreeAndNil(FPack);
end;
end.
窗体文件如下：
object Form1: TForm1
Left = 87
Top = 120
Width = 518
Height = 375
Caption = ''''Form1''''
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = ''''MS Sans Serif''''
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
PixelsPerInch = 96
TextHeight = 13
object GroupBox1: TGroupBox
Left = 270
Top = 0
上一页 [1] [2] [3] 下一页 |
