动态加载和动态注册类技术的深入探索_Delphi程序_学习笔记★闵涛★计算机学习电脑编程软硬件技巧


	转至繁体中文版	\| 网站首页 \| 图文教程 \| 资源下载 \| 站长博客 \| 图片素材 \| 武汉seo \| 武汉网站优化 \|

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

作者：闵涛文章来源：闵涛的学习笔记点击数：2158 更新时间：2009/4/23 18:44:50

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] 下一页

没有相关教程

教程录入：mintao 责任编辑：mintao

上一篇教程： [Tips]设置双击时间

下一篇教程：所见及所得的类分析跟踪器

【字体：小大】【发表评论】【加入收藏】【告诉好友】【打印此文】【关闭窗口】

注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网]

　网友评论：（只显示最新10条。评论内容只代表网友观点，与本站立场无关！）

同类栏目

· C语言系列 · VB.NET程序
· JAVA开发 · Delphi程序
· 脚本语言

热门推荐

没有教程

赞助链接

闵涛博文

500 - 内部服务器错误。

您查找的资源存在问题，因而无法显示。

鄂公网安备 42011102001154号

站长：MinTao ICP备案号：鄂ICP备11006601号-18

闵涛站盟:医药大全-武穴网。A打造B、C、D……