动态加载和动态注册类技术的深入探索(2)

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 }
{ }

标签：

版权申明：本站文章部分自网络，如有侵权，请联系：west999com@outlook.com
特别注意：本站所有转载文章言论不代表本站观点，本站所提供的摄影照片，插画，设计作品，如需使用，请与原作者联系，版权归原作者所有