用delphi製作無介面的activex控制元件

Max Woods發表於2014-10-09

首先，您要了解：
•COM的基本原理
•能被網頁呼叫的非可視ActiveX控制元件必須是一種至少實現了IOleObject介面的TAutoObject元件
•利用Delphi嚮導生成的ActiveX控制元件必須繼承自WinControl，所以您不能用Delphi嚮導生成非可視的ActiveX控制元件

 以下例子，實現了一個非可視ActiveX，呼叫此控制元件的exeWB，相當於呼叫IE的列印，預覽，頁面設定等功能。再此基礎上，還可以擴充套件其它的功能。

製作步驟：

1.開啟delphi,新建一個ActiveX包。   File|new|other...|ActiveX|AxtiveX library 2.利用delphi嚮導，新增一個Automation Object。   File|new|other...|ActiveX|Automation Object   我這個專案叫WebPrint 3.在接下來彈出的TLB編輯視窗裡面定義自己需要的介面函式   我新增需要的介面IWebPrint.print(),IWebPrint.preview()等 4.實現IOleObject介面，將程式碼改成如下形式,紅色為修改部分      將Windows新增到uses引用   uses   ComObj, ActiveX, Project1_TLB, Windows;     修改   TWebPrint = class(TAutoObject,IWebPrint)   為   TWebPrint = class(TAutoObject,IOleObject , IWebPrint)     新增下段程式碼到TWebPrint的private段     private     FOleClientSite: IOleClientSite;

  新增下段程式碼到TWebPrint的public段

public

    {IOleObject}     
　　function SetClientSite(const clientSite: IOleClientSite): HResult;stdcall;
   function GetClientSite(out clientSite: IOleClientSite): HResult;stdcall;
   function SetHostNames(szContainerApp: POleStr;szContainerObj: POleStr): HResult; stdcall;
   function Close(dwSaveOption: Longint): HResult; stdcall;
   function SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;stdcall;
   function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;out mk: IMoniker): HResult; stdcall;
   function InitFromData(const dataObject: IDataObject; fCreation: BOOL;dwReserved: Longint): HResult; stdcall;
   function GetClipboardData(dwReserved: Longint;out dataObject: IDataObject): HResult; stdcall;
   function DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;stdcall;
   function EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; stdcall;
   function Update: HResult; stdcall;
   function IsUpToDate: HResult; stdcall;
   function GetUserClassID(out clsid: TCLSID): HResult; stdcall;
   function GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;stdcall;
   function SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;stdcall;
   function GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;stdcall;
   function Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;stdcall;
   function Unadvise(dwConnection: Longint): HResult; stdcall;
   function EnumAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
   function GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;stdcall;
   function SetColorScheme(const logpal: TLogPalette): HResult; stdcall;

   //在implementation段實現IOleObject的函式功能

implementation

{IOleObject}

function TWebPrint.SetClientSite(const ClientSite: IOleClientSite): HResult; 
begin   
　　if ClientSite <> nil then
　　   begin     
　　　　　　if FOleClientSite <> nil then
　　　　　　　　begin
　　　　　　　　　　Result := E_FAIL;
　　　　　　       Exit;
　　　　　　　　end;
　　　　　　　　FOleClientSite := ClientSite;
　　　　end
　　　　else
　　　　begin
　　　　　　FOleClientSite := nil;   
　　　　end;
　　　　Result := S_OK;
end;

function TWebPrint.GetClientSite(out clientSite: IOleClientSite): HResult;
begin
   ClientSite := FOleClientSite;
   Result := S_OK; 
end;

function TWebPrint.SetHostNames(szContainerApp: POleStr;   szContainerObj: POleStr): HResult;
begin
   Result := S_OK;
end;

function TWebPrint.Close(dwSaveOption: Longint): HResult; 
begin
　　Result := E_NOTIMPL; 
end;

function TWebPrint.SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult; 
begin
   Result := E_NOTIMPL; 
end;

function TWebPrint.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;   out mk: IMoniker): HResult; 
begin
   Result := E_NOTIMPL; 
end;

function TWebPrint.InitFromData(const dataObject: IDataObject; fCreation: BOOL;   dwReserved: Longint): HResult; 
begin   
　　Result := E_NOTIMPL; 
end;

function TWebPrint.GetClipboardData(dwReserved: Longint;   out dataObject: IDataObject): HResult; 
begin
   Result := E_NOTIMPL; 
end;

function TWebPrint.DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;   lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult; 
begin
   Result := E_NOTIMPL; 
end;

function TWebPrint.EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; 
begin   
　　Result := OleRegEnumVerbs(Factory.ClassID, enumOleVerb); 
end;

function TWebPrint.Update: HResult; 
begin
   Result := S_OK; 
end;

function TWebPrint.IsUpToDate: HResult; 
begin   
　　Result := S_OK; 
end;

function TWebPrint.GetUserClassID(out clsid: TCLSID): HResult; 
begin   
　　clsid := Factory.ClassID;   
　　Result := S_OK; 
end;

function TWebPrint.GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult; 
begin
   Result := OleRegGetUserType(Factory.ClassID, dwFormOfType, pszUserType); 
end;

function TWebPrint.SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult; 
begin
   Result := E_NOTIMPL; 
end;

function TWebPrint.GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult; 
begin
  Result := E_NOTIMPL; 
end;

function TWebPrint.Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult; 
begin  
　　Result := E_NOTIMPL; 
end;

function TWebPrint.Unadvise(dwConnection: Longint): HResult; 
begin
   Result := E_NOTIMPL; 
end;

function TWebPrint.EnumAdvise(out enumAdvise: IEnumStatData): HResult; 
begin
  Result := E_NOTIMPL; 
end;

function TWebPrint.GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult; 
begin
   Result := E_NOTIMPL; 
end;

function TWebPrint.SetColorScheme(const logpal: TLogPalette): HResult; 
begin
   Result := E_NOTIMPL; 
end;

5.實現您自己定義的介面函式功能

{ITWebPrint}

procedure TWebPrint.exeWB(cmdID:TOleEnum); 
var
  spDoc:IHTMLDocument2;
  spContainer:IOleContainer;
  spIE:IWebBrowser2; 
begin   
　　FOleClientSite.GetContainer(spContainer);
   if not Assigned(spContainer) then   
　　begin
　　  messagebox(0,'此物件必須作為OLE物件使用','使用方法錯誤',0);     
　　　exit;
   end;
  if spContainer.QueryInterface(IID_IHTMLDocument2,spDoc)=S_OK then
  begin
　　 if (spDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp, IWebBrowser2, spIE)=S_OK then
    begin
　　　　if spIE.QueryStatusWB(cmdID)=3 then
          spIE.ExecWB(cmdID, OLECMDEXECOPT_DODEFAULT,EmptyParam,EmptyParam);      
　　end 
　　else
　　　　begin
         messagebox(0,'請使用IE5.5以上版本','執行環境不正確',0);
         exit;
   　　end;
   end 
　　else
　　 begin
　　     messagebox(0,'找不到網頁內容','使用方法錯誤',0);     
　　　　　　exit;
   end;

end;

全部原始碼如下：

unit Unit1;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses   ComObj, ActiveX, Project1_TLB, Windows;

type

　　TWebPrint = class(TAutoObject,IOleObject , IWebPrint) 
　　private
　　   FOleClientSite: IOleClientSite; 
　　public
     {IOleObject}
     function SetClientSite(const clientSite: IOleClientSite): HResult; stdcall;
     function GetClientSite(out clientSite: IOleClientSite): HResult;       stdcall;     function SetHostNames(szContainerApp: POleStr;       szContainerObj: POleStr): HResult; stdcall;     function Close(dwSaveOption: Longint): HResult; stdcall;     function SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;       stdcall;     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;       out mk: IMoniker): HResult; stdcall;     function InitFromData(const dataObject: IDataObject; fCreation: BOOL;       dwReserved: Longint): HResult; stdcall;     function GetClipboardData(dwReserved: Longint;       out dataObject: IDataObject): HResult; stdcall;     function DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;       lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;       stdcall;     function EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; stdcall;     function Update: HResult; stdcall;     function IsUpToDate: HResult; stdcall;     function GetUserClassID(out clsid: TCLSID): HResult; stdcall;     function GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;       stdcall;     function SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;       stdcall;     function GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;       stdcall;     function Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;       stdcall;     function Unadvise(dwConnection: Longint): HResult; stdcall;     function EnumAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;     function GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;       stdcall;     function SetColorScheme(const logpal: TLogPalette): HResult; stdcall;         {IWebPrint}     procedure exeWB(cmdID:TOleEnum);

implementation

{IOleObject}

function TWebPrint.SetClientSite(const ClientSite: IOleClientSite): HResult; begin   if ClientSite <> nil then   begin     if FOleClientSite <> nil then     begin       Result := E_FAIL;       Exit;     end;     FOleClientSite := ClientSite;   end else   begin     FOleClientSite := nil;   end;   Result := S_OK; end;

function TWebPrint.GetClientSite(out clientSite: IOleClientSite): HResult; begin   ClientSite := FOleClientSite;   Result := S_OK; end;

function TWebPrint.SetHostNames(szContainerApp: POleStr;   szContainerObj: POleStr): HResult; begin   Result := S_OK; end;

function TWebPrint.Close(dwSaveOption: Longint): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;   out mk: IMoniker): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.InitFromData(const dataObject: IDataObject; fCreation: BOOL;   dwReserved: Longint): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.GetClipboardData(dwReserved: Longint;   out dataObject: IDataObject): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;   lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; begin   Result := OleRegEnumVerbs(Factory.ClassID, enumOleVerb); end;

function TWebPrint.Update: HResult; begin   Result := S_OK; end;

function TWebPrint.IsUpToDate: HResult; begin   Result := S_OK; end;

function TWebPrint.GetUserClassID(out clsid: TCLSID): HResult; begin   clsid := Factory.ClassID;   Result := S_OK; end;

function TWebPrint.GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult; begin   Result := OleRegGetUserType(Factory.ClassID, dwFormOfType, pszUserType); end;

function TWebPrint.SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult; begin  Result := E_NOTIMPL; end;

function TWebPrint.Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult; begin  Result := E_NOTIMPL; end;

function TWebPrint.Unadvise(dwConnection: Longint): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.EnumAdvise(out enumAdvise: IEnumStatData): HResult; begin  Result := E_NOTIMPL; end;

function TWebPrint.GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult; begin   Result := E_NOTIMPL; end;

function TWebPrint.SetColorScheme(const logpal: TLogPalette): HResult; begin   Result := E_NOTIMPL; end;

{ITWebPrint}

procedure TWebPrint.exeWB(cmdID:TOleEnum); 
var     
　　spDoc:IHTMLDocument2;
   spContainer:IOleContainer;
　　spIE:IWebBrowser2; 
begin   
　　FOleClientSite.GetContainer(spContainer);
   if not Assigned(spContainer) then
   begin     
　　　　messagebox(0,'此物件必須作為OLE物件使用','使用方法錯誤',0);     
　　　　exit;
  end;
  if spContainer.QueryInterface(IID_IHTMLDocument2,spDoc)=S_OK then   
　begin
      if (spDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp, IWebBrowser2, spIE)=S_OK then
　　   begin
　　      if spIE.QueryStatusWB(cmdID)=3 then
           spIE.ExecWB(cmdID, OLECMDEXECOPT_DODEFAULT,EmptyParam,EmptyParam);
      　　end 
　　　　　　else
      begin
         messagebox(0,'請使用IE5.5以上版本','執行環境不正確',0);  
       exit;     
 end;  
 end 
else
 begin
     messagebox(0,'找不到網頁內容','使用方法錯誤',0);     
　　exit;   
end;

end;

ActiveX 控制元件重繪無效問題,用CClientDC 而不是CPaintDC
2018-06-22
控制元件clientAI
win10activex控制元件怎麼安裝_win10如何安裝activex控制元件
2020-03-04
Win10控制元件
Qt開發Activex筆記（二）：Qt呼叫Qt開發的Activex控制元件
2021-02-14
QT筆記控制元件
MFC---ActiveX控制元件程式設計基礎
2018-07-23
控制元件程式設計
Delphi皮膚控制元件去NAG提示
2024-07-21
控制元件
基於vs2012開發activex（MFC）控制元件
2018-03-08
控制元件
開發ActiveX控制元件的實踐(1)--用VS2010開發一個簡單的TestOcx控制元件
2023-05-18
控制元件
delphi 常用控制元件屬性設定說明
2024-08-17
控制元件
CS系統中分頁控制元件的製作
2021-01-11
控制元件
直播平臺製作，登入頁面的切換
2023-03-09
C#製作可控制介面的windows服務
2021-09-09
C#Windows
用C#建立ActiveX問題
2020-04-05
C#
ActiveX控制元件數字簽名實踐（免費簽名）
2020-04-04
控制元件
delphi 控制元件 LssCalendar V2.0 (支援農曆的月曆控制元件)
2024-08-01
控制元件
DELPHI 使用dbexpress控制元件連線MySQL資料庫方法
2020-04-05
Express控制元件MySql資料庫
頁面的修改、新增，以及驗證控制元件的常見應用
2020-06-25
控制元件
直播帶貨原始碼，普通商城購物頁面的製作
2022-03-23
原始碼
win10 activex部件不能建立物件怎麼辦_win10 activex元件無法建立物件處理方法
2020-07-14
Win10物件元件
windows10系統下IE瀏覽器怎麼開啟activex控制元件
2020-03-27
Windows瀏覽器控制元件
WordpressCMS主題開發08-CMS文章內容頁面的製作
2018-07-08
無需依賴Docker環境製作映象
2023-02-03
Docker
適用於各種活動的邀請函製作教程！無門檻！
2023-02-02
USB3.0介面的工業相機應用
2018-05-07
iOS自定義控制元件：UISegmentedControl+UIScrollView製作QQ音樂主頁面
2019-03-05
iOS控制元件UIView
怎麼用PPT製作一個照片畫冊？PowerPoint製作照片畫冊教程
2018-12-10
從Delphi到Lazarus——Delphi轉換器
2024-12-05
用 Python 製作截圖小工具
2024-05-09
Python
學會用程式碼製作愛心！
2020-12-20
WordpressCMS主題開發06-分類頁面的文章呼叫和sidebar製作
2018-07-08
IDE
QYT-X1S在無人機方面的應用
2021-12-03
無人機
delphi opencv
2024-07-27
OpenCV
delphi多執行緒檔案複製怎麼實現
2024-08-18
執行緒
鴻蒙安全控制元件之位置控制元件簡介
2024-11-28
鴻蒙控制元件
Delphi 技術的優缺點與應用
2022-10-20
用Dreamweaver 定義模板批次製作網頁
2018-05-04
網頁
PageMaker排版製作精彩應用技巧集錦
2018-05-04
用CSS製作三角形.
2018-06-24
CSS
用 Docker 製作的 Laravel 開發環境
2019-12-24
DockerLaravel開發環境
超實用的線上表單製作指南！
2020-08-11

用delphi製作無介面的activex控制元件

相關文章