Delphi的包是Delphi IDE的核心技術，沒有包也就沒有了Delphi的可視化編程。包也可以用在我們開發的項目中，其好處是可以代碼共享，減小工程尺寸，單純通過替換包文件就能實現工程的升級和補丁。但是我們要加載包，就要知道包中已經存在的類。關於如何動態加載包的資料比比皆是我就不想就此問題討論了。但是Delphi的IDE很是特殊，它無需事先知道你的包有哪些類就能注冊組建，創建組建。但是Borland沒有公開BPL文件的格式。我們自己是否可以實現IDE的功能呢？
首先我們知道。一個組件包想要能在IDE中使用就要進行注冊也就是要創建一個過程例如：
Procedure Register；
Begin
RegisterComponents(IDE中的頁面, [組件類]);
End;
在IDE加載時就要調用這個過程進行注冊。
其次我們通過Borland的文檔又知道BPL只是一種特殊格式的DLL文件。那麼既然IDE可以調用得到注冊過程那麼注冊過程一定要是導出類型（exports）的才行。既然如此我們可以想辦法弄明白。寫一個包文件。裡面包含Test、和TestBtn兩個單元。兩個單元分別都有注冊過程，然後編譯成BPL文件。好了我們可以用EXESCOPE這個工具來弄清楚其中的奧秘。
我們可以看到一個函數@Test@Register$qqrv。幾乎可以肯定這個函數就是BPL把Test單元中的Register導出的注冊函數，而那個@Testbtn@Register$QQrv就一定是Testbtn這個單元的注冊函數。可以做一個實驗來證明我們的想法，在Test單元的Register的函數中加上ShowMessage(‘你好，你調用了注冊函數’);
然後在我們來調用一下包中的函數@Test@Register$QQrv，隨便寫一個工程看看是不是可以調用得到Test單元中的Register過程。
var
H : Integer;
regproc : procedure();
begin
H := 0;
H := LoadPackage('TestPackage.bpl');
try
if H <> 0 then
begin
RegProc := GetProcAddress(H,'@Test@Register$QQrv');//載入包中的函數
if Assigned(RegProc) then
begin
regproc();//調用函數
end;
end;
finally
if H <> 0 then
begin
UnloadPackage(H);
H := 0;
end;
end;
end;
調用的結果，果然調用到了包中Terst單元的Register過程。但是如何得到注冊了哪些類呢？注冊組件要用RegisterComponents函數。好在VCL體系的源代碼是開放的，我們看看RegisterComponents是如何實現的吧。
在Classes單元我們可以看到：
procedure RegisterComponents(const Page: string;
const ComponentClasses: array of TComponentClass);
begin
if Assigned(RegisterComponentsProc) then
RegisterComponentsProc(Page, ComponentClasses)
else
raise EComponentError.CreateRes(@SRegisterError);
end;
畫線的是一個函數指針，Delphi的IDE就是在這個指針所指的函數裡去作具體的工作。我們也可以利用它來實現我們的注冊。
procedure MyRegComponentsProc(const Page: string;
const ComponentClasses: array of TComponentClass);
var
I : Integer;
IDEInfo : PIDEInfo;
begin
for i := 0 to High(ComponentClasses) do
begin
RegisterClass(ComponentClasses[I]);
end;
end;
然後一條語句RegisterComponentsProc:= @MyRegComponentsProc;似乎就解決問題了。
慢著！RegisterComponentsProc是在Classes單元。但是BPL中的Classes單元是在另一個運行時的包VCL.BPL裡面。而我們工程所修改的RegisterComponentsProc的指針是編譯在我們的工程中，空間是不同的。所以我們的工程一定要編譯成帶運行時包VCL.BPL的才行。但是這樣一來的話我們也就只能載入和我們所用的編譯器相同版本編譯器編譯出來的BPL文件了，也就是說Delphi6只能載入Delphi6或者BCB6編譯出來的BPL文件以此類推。
但是還有一個問題沒有解決，那就是如何知道一個包中到底有那些各單元呢？可以通過GetPackageInfo過程來獲得。
我已經把加載包的過程封裝到了一個類中。整個程序的代碼如下：
{ *********************************************************************** }
{ }
{ 動態加載Package的類 }
{ }
{ wr960204(王銳)2003-2-20 }
{ }
{ *********************************************************************** }
unit UnitPackageInfo;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
PIDEInfo = ^TIDEInfo;
TIDEInfo = record
iClass: TComponentClass;
iPage: string;
end;
type
TPackage = class(TObject)
private
FPackHandle: THandle;
FPackageFileName: string;
FPageInfos: TList;
FContainsUnit: TStrings; //單元名
FRequiresPackage: TStrings; //需要的的包
FDcpBpiName: TStrings; //
procedure ClearPageInfo;
procedure LoadPackage;
function GetIDEInfo(Index: Integer): TIDEInfo;
function GetIDEInfoCount: Integer;
public
constructor Create(const FileName: string); overload;
constructor Create(const PackageHandle: THandle); overload;
destructor Destroy; override;
function RegClassInPackage: Boolean;
property IDEInfo[Index: Integer]: TIDEInfo read GetIDEInfo;
property IDEInfoCount: Integer read GetIDEInfoCount;
property ContainsUnit: TStrings read FContainsUnit;
property RequiresPackage: TStrings read FRequiresPackage;
property DcpBpiName: TStrings read FDcpBpiName;
end;
implementation
var
CurrentPackage : TPackage;
procedure RegComponentsProc(const Page: string;
const ComponentClasses: array of TComponentClass);
var
I : Integer;
IDEInfo : PIDEInfo;
begin
for i := 0 to High(ComponentClasses) do
begin
RegisterClass(ComponentClasses[I]);
new(IDEInfo);
IDEInfo.iPage := Page;
IDEInfo.iClass := ComponentClasses[I];
CurrentPackage.FPageInfos.Add(IDEInfo);
end;
end;
procedure EveryUnit(const Name: string; NameType: TNameType; Flags: Byte; Param:
Pointer);
begin
case NameType of
ntContainsUnit:
CurrentPackage.FContainsUnit.Add(Name);
ntDcpBpiName:
CurrentPackage.FDcpBpiName.Add(Name);
ntRequiresPackage:
CurrentPackage.FRequiresPackage.Add(Name);
end;
end;
{ TPackage }
constructor TPackage.Create(const FileName: string);
begin
FPackageFileName := FileName;
LoadPackage;
end;
procedure TPackage.ClearPageInfo;
var
I:Integer;
IDEInfo:PIDEInfo;
begin
for i:=FPageInfos.Count-1 downto 0 do
begin
IDEInfo:=FPageInfos[I];
Dispose(IDEInfo);
FPageInfos.Delete(I);
end;
FPageInfos.Clear;
end;
constructor TPackage.Create(const PackageHandle: THandle);
begin
FPackageFileName := GetModuleName(PackageHandle);
LoadPackage;
end;
destructor TPackage.Destroy;
var
I : Integer;
begin
FContainsUnit.Free;
FRequiresPackage.Free;
FDcpBpiName.Free;
if FPackHandle <> 0 then
begin
UnRegisterModuleClasses(FPackHandle);
ClearPageInfo;
FPageInfos.Free;
UnloadPackage(FPackHandle);
FPackHandle := 0;
end;
inherited Destroy;
end;
function TPackage.GetIDEInfoCount: Integer;
begin
Result := FPageInfos.Count;
end;
function 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
Width = 240
Height = 224
Align = alRight
Caption = '類'
TabOrder = 0
object ListBox1: TListBox
Left = 2
Top = 15
Width = 236
Height = 207
Align = alClIEnt
ItemHeight = 13
TabOrder = 0
end
end
object Panel1: TPanel
Left = 0
Top = 224
Width = 510
Height = 124
Align = alBottom
Color = clCream
TabOrder = 1
end
object Button1: TButton
Left = 8
Top = 8
Width = 249
Height = 25
Caption = '載入包'
TabOrder = 2
OnClick = Button1Click
end
object Button2: TButton
Left = 8
Top = 40
Width = 249
Height = 25
Caption = '創建所選中的類的實例在Panel上'
TabOrder = 3
OnClick = Button2Click
end
object Memo1: TMemo
Left = 8
Top = 72
Width = 257
Height = 145
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 4
end
object OpenDialog1: TOpenDialog
Filter = '*.BPL|*.BPL'
Left = 200
Top = 16
end
end
在這些基礎上我們完全可以建立一個自己的Delphi的IDE，對象的屬性的獲得和設置用TYPInfo單元的RTTI類函數完全可以輕松搞定，我就不在這裡多費口舌了。
記住了，編譯時一定要用攜帶VCL.BPL 包的方式.
