在Delphi中动态创建ActiveX组件

最近一个项目需要程序能动态的创建ActiveX组件，并在当前窗口显示出来，google了一下，未能找到前辈们的指点，就只能自己动手了，研究了一下Delphi中ActiveX相关单元的源码后，自己编写了一个类，可以实现动态创建ActiveX组件，放在这里自娱自乐一下，也免后来者重蹈我的覆辙。

unit DynamicOleControl;

interface

uses Windows, Classes, ActiveX, OleCtrls, ComObj;

type
  TDynamicOleControl = class(TOleControl)
  private
    FClassID: TGUID;
    FIntf: IUnknown;

    function  GetControlInterface: IUnknown;
  protected
    procedure CreateControl;
    procedure InitControlData; override;
  public
    constructor CreateFromClassID(AOwner: TComponent; AClassID: TGUID); overload;
    constructor CreateFromClassID(AOwner: TComponent; AClassID: string); overload;
    constructor CreateFromProgID(AOwner: TComponent; AProgID: string);

    property  ControlInterface: IUnknown read GetControlInterface;
    property  DefaultInterface: IUnknown read GetControlInterface;

  published
    property Anchors;
  end;

implementation

constructor TDynamicOleControl.CreateFromClassID(AOwner: TComponent;
  AClassID: TGUID);
begin
  FClassID := AClassID;

  inherited Create(AOwner);
end;

constructor TDynamicOleControl.CreateFromClassID(AOwner: TComponent; AClassID: string);
begin
  FClassID := StringToGUID(AClassID);
  inherited Create(AOwner);
end;

constructor TDynamicOleControl.CreateFromProgID(AOwner: TComponent;
  AProgID: string);
begin
  FClassID := ProgIDToClassID(AProgID);
  inherited Create(AOwner);
end;

procedure TDynamicOleControl.InitControlData;
const
  CControlData: TControlData2 = (
    ClassID: '';
    EventIID: '';
    EventCount: 0;
    LicenseKey: nil;
    Flags: $00000000; //$0000001D
    Version: 401
    );
begin
  CopyMemory(@CControlData.ClassID, @FClassID, SizeOf(TGUID));
  ControlData := @CControlData;
end;

procedure TDynamicOleControl.CreateControl;

  procedure DoCreate;
  begin
    FIntf := IUnknown(OleObject) as IUnknown;
  end;

begin
  if FIntf = nil then DoCreate;
end;

function TDynamicOleControl.GetControlInterface: IUnknown;
begin
  CreateControl;
  Result := FIntf;
end;

end.

例子程序运行效果如下图所示：

DynamicOleControl.pas单元的使用比较简单，该例子的源码如下，大家一看就明白：

unit MainUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, DynamicOleControl, StdCtrls, Buttons, ExtCtrls, ComObj;

type
  TMainForm = class(TForm)
    pnl1: TPanel;
    pnlContainer: TPanel;
    lbl1: TLabel;
    edtClassID: TEdit;
    btnLoad: TBitBtn;
    btnFree: TBitBtn;
    Label1: TLabel;
    edtProgID: TEdit;
    Label2: TLabel;
    procedure btnFreeClick(Sender: TObject);
    procedure btnLoadClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FMyOleControl: TDynamicOleControl;

    procedure FreeOleControl;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}
          
procedure TMainForm.FormCreate(Sender: TObject);
begin
  FMyOleControl := nil;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FreeOleControl;
end;

procedure TMainForm.FreeOleControl;
begin
  if Assigned(FMyOleControl) then
    FreeAndNil(FMyOleControl);
end;

procedure TMainForm.btnFreeClick(Sender: TObject);
begin
  FreeOleControl;
end;

procedure TMainForm.btnLoadClick(Sender: TObject);
begin
  FreeOleControl;

  try
    if Trim(edtClassID.Text) <> '' then
      FMyOleControl := TDynamicOleControl.CreateFromClassID(Self,
        Trim(edtClassID.Text))
    else if Trim(edtProgID.Text) <> '' then
      FMyOleControl := TDynamicOleControl.CreateFromProgID(Self,
        Trim(edtProgID.Text));

    if Assigned(FMyOleControl) then
    begin
      pnlContainer.InsertControl(FMyOleControl);
      FMyOleControl.Align := alClient;
    end;
  except
    on e: EOleSysError do
      Application.MessageBox(PChar(e.Message), '错误', MB_OK + MB_ICONERROR);
  end;
end;

end.

后记：

     最近忙得有点天昏地暗，以后有时间再封装一下对动态加载后的ActiveX组件的相关操作方法。