客服电话
APP下载
迪恩网络APP
随时随地掌握行业动态
官方微信
扫描二维码
关注迪恩网络微信公众号
|
我们首先要建立一个ActiveX Library。将其保存为MailIEBand.Dpr；然后建立一个COM Object，将其保存为BandUnit.pas；然后建立一个Form，这个窗口将作为子窗口显示在IE工具栏中，将窗口的BorderStyle属性改为bsNone，添加一个TButton组件和一个TComboBox组件，将TButton的Caption属性改为获取全部，然后将窗口文件其保存为IEForm.pas。 在BandUnit中，需要建立一个实现上面提到的接口的TComObject对象。如下： TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)
下面的程序清单1-6到1-8是实现COM服务器的全部程序代码：
library MailIEBand;
uses ComServ, BandUnit in 'BandUnit.pas', , MailIEBand_TLB in 'MailIEBand_TLB.pas'; exports DllGetClassObject, DllCanUnloadNow, DllRegisterServer, DllUnregisterServer; begin end. 程序清单1-7 BandUnit.pas unit BandUnit; interface uses Windows, Sysutils, Messages, Registry, Shellapi, ActiveX, Classes, ComObj, Shlobj, Dialogs, Commctrl,ShDocVW,IEForm; type TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit) private frmIE:TForm1; m_pSite:IInputObjectSite; m_hwndParent:HWND; m_hWnd:HWND; m_dwViewMode:Integer; m_dwBandID:Integer; protected public function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo): HResult; stdcall; function ShowDW(fShow: BOOL): HResult; stdcall; function CloseDW(dwReserved: DWORD): HResult; stdcall; function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown; fReserved: BOOL): HResult; stdcall; function GetWindow(out wnd: HWnd): HResult; stdcall; function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; function SetSite(const pUnkSite: IUnknown ):HResult; stdcall; function GetSite(const riid: TIID; out site: IUnknown):HResult;stdcall; function GetClassID(out classID: TCLSID): HResult; stdcall; function IsDirty: HResult; stdcall; function InitNew: HResult; stdcall; function Load(const stm: IStream): HResult; stdcall; function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall; function GetSizeMax(out cbSize: Largeint): HResult; stdcall; end; const Class_GetMailBand: TGUID = '{954F618B-0DEC-4D1A-9317-E0FC96F87865}'; //以下是系统接口的IID IID_IUnknown: TGUID = ( D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46)); IID_IOleObject: TGUID = ( D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46)); IID_IOleWindow: TGUID = ( D1:$00000114;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46)); IID_IInputObjectSite : TGUID = ( D1:$f1db8392;D2:$7331;D3:$11d0;D4:($8C,$99,$00,$A0,$C9,$2D,$BF,$E8)); sSID_SInternetExplorer : TGUID = '{0002DF05-0000-0000-C000-000000000046}'; sIID_IWebBrowserApp : TGUID= '{0002DF05-0000-0000-C000-000000000046}'; //面板所允许的最小宽度和高度。 MIN_SIZE_X = 54; MIN_SIZE_Y = 22; EB_CLASS_NAME = 'GetMailAddress'; implementation uses ComServ; function TGetMailBand.GetWindow(out wnd: HWnd): HResult; stdcall; begin wnd:=m_hWnd; Result:=S_OK; end; function TGetMailBand.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; begin Result:=E_NOTIMPL; end; function TGetMailBand.ShowDW(fShow: BOOL): HResult; stdcall; begin if m_hWnd<>0 then if fShow then ShowWindow(m_hWnd,SW_SHOW) else ShowWindow(m_hWnd,SW_HIDE); Result:=S_OK; end; function TGetMailBand.CloseDW(dwReserved: DWORD): HResult; stdcall; begin if frmIE<>nil then frmIE.Destroy; Result:= S_OK; end; function TGetMailBand.ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown;fReserved: BOOL): HResult; stdcall; begin Result:=E_NOTIMPL; end; function TGetMailBand.SetSite(const pUnkSite: IUnknown):HResult;stdcall; var pOleWindow:IOleWindow; pOLEcmd:IOleCommandTarget; pSP:IServiceProvider; rc:TRect; begin if Assigned(pUnkSite) then begin m_hwndParent := 0; m_pSite:=pUnkSite as IInputObjectSite; pOleWindow := PunkSIte as IOleWindow; //获得父窗口IE面板窗口的句柄 pOleWindow.GetWindow(m_hwndParent); if(m_hwndParent=0)then begin Result := E_FAIL; exit; end; //获得父窗口区域 GetClientRect(m_hwndParent, rc); if not Assigned(frmIE) then begin //建立TIEForm窗口，父窗口为m_hwndParent frmIE:=TForm1.CreateParented(m_hwndParent); m_Hwnd:=frmIE.Handle; SetWindowLong(frmIE.Handle, GWL_STYLE, GetWindowLong(frmIE.Handle, GWL_STYLE) Or WS_CHILD); //根据父窗口区域设置窗口位置 with frmIE do begin Left :=rc.Left ; Top:=rc.top; Width:=rc.Right - rc.Left; Height:=rc.Bottom - rc.Top; end; frmIE.Visible := True; //获得与浏览器相关联的Webbrowser对象。 pOLEcmd:=pUnkSite as IOleCommandTarget; pSP:=pOLEcmd as IServiceProvider; if Assigned(pSP)then begin pSP.QueryService(IWebbrowserApp, IWebbrowser2,frmIE.IEThis); end; end; end; Result := S_OK; end; function TGetMailBand.GetSite(const riid: TIID; out site: IUnknown):HResult;stdcall; begin if Assigned(m_pSite) then result:=m_pSite.QueryInterface(riid, site) else Result:= E_FAIL; end; function TGetMailBand.GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo): HResult; stdcall; begin Result:=E_INVALIDARG; if not Assigned(frmIE) then frmIE:=TForm1.CreateParented(m_hwndParent); if(@pdbi<>nil)then begin m_dwBandID := dwBandID; m_dwViewMode := dwViewMode; if(pdbi.dwMask and DBIM_MINSIZE)<>0 then begin pdbi.ptMinSize.x := MIN_SIZE_X; pdbi.ptMinSize.y := MIN_SIZE_Y; end; if(pdbi.dwMask and DBIM_MAXSIZE)<>0 then begin pdbi.ptMaxSize.x := -1; pdbi.ptMaxSize.y := -1; end; if(pdbi.dwMask and DBIM_INTEGRAL)<>0 then begin pdbi.ptIntegral.x := 1; pdbi.ptIntegral.y := 1; end; if(pdbi.dwMask and DBIM_ACTUAL)<>0 then begin pdbi.ptActual.x := 0; pdbi.ptActual.y := 0; end; if(pdbi.dwMask and DBIM_MODEFLAGS)<>0 then pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT; if(pdbi.dwMask and DBIM_BKCOLOR)<>0 then pdbi.dwMask := pdbi.dwMask and (not DBIM_BKCOLOR); end; end; function TGetMailBand.GetClassID(out classID: TCLSID): HResult; stdcall; begin classID:= Class_GetMailBand; Result:=S_OK; end; function TGetMailBand.IsDirty: HResult; stdcall; begin Result:=S_FALSE; end; function TGetMailBand.InitNew: HResult; begin Result := E_NOTIMPL; end; function TGetMailBand.Load(const stm: IStream): HResult; stdcall; begin Result:=S_OK; end; function TGetMailBand.Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall; begin Result:=S_OK; end; function TGetMailBand.GetSizeMax(out cbSize: Largeint): HResult; stdcall; begin Result:=E_NOTIMPL; end; //TIEClassFac类实现COM组件的注册 type TIEClassFac=class(TComObjectFactory) // public procedure UpdateRegistry(Register: Boolean); override; end; procedure TIEClassFac.UpdateRegistry(Register: Boolean); var ClassID: string; a:Integer; begin inherited UpdateRegistry(Register); if Register then begin ClassID:=GUIDToString(Class_GetMailBand); with TRegistry.Create do try //添加附加的注册表项 RootKey:=HKEY_LOCAL_MACHINE; OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar',False); a:=0; WriteBinaryData(GUIDToString(Class_GetMailBand),a,0); OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',True); WriteString (GUIDToString(Class_GetMailBand),EB_CLASS_NAME); RootKey:=HKEY_CLASSES_ROOT; OpenKey('\CLSID\'+GUIDToString(Class_GetMailBand),False); WriteString('',EB_CLASS_NAME); finally Free; end; end else begin with TRegistry.Create do try RootKey:=HKEY_LOCAL_MACHINE; OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar',False); DeleteValue(GUIDToString(Class_GetMailBand)); OpenKey('\Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',False); DeleteValue(GUIDToString(Class_GetMailBand)); finally Free; end; end; end; initialization TIEClassFac.Create(ComServer, TGetMailBand, Class_GetMailBand, 'GetMailAddress', '', ciMultiInstance, tmApartment); end. 程序清单1-8 IEForm.pas unit IEForm; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, SHDocVw,MSHTML, StdCtrls; type TForm1 = class(TForm) Button1: TButton; ComboBox1: TComboBox; procedure FormResize(Sender: TObject); procedure Button1Click(Sender: TObject); private public IEThis:IWebbrowser2; end; var Form1: TForm1; implementation procedure TForm1.FormResize(Sender: TObject); begin With Button1 do begin Left := 0; Top := 0; Height:=Self.ClientHeight; end; With ComboBox1 do begin Left := Button1.Width +3; Top := 0; Height:=Self.ClientHeight; Width:=Self.ClientWidth - Left; end; end; procedure TForm1.Button1Click(Sender: TObject); var doc:IHTMLDocument2; all:IHTMLElementCollection; len,i,flag:integer; item:IHTMLElement; vAttri:Variant; begin if Assigned(IEThis)then begin ComboBox1.Clear; //获得Webbrowser对象中的文档对象 doc:=IEThis.Document as IHTMLDocument2; //获得文档中所有的HTML元素集合 all:=doc.Get_all; len:=all.Get_length; //访问HTML元素集合中的每一个元素 for i:=0 to len-1 do begin item:=all.item(i,varempty) as IHTMLElement; //如果该元素是一个链接 if item.Get_tagName = 'A'then begin flag:=0; vAttri:=item.getAttribute('protocol',flag); //获得链接属性 //如果是mailto链接则将链接的目标地址添加到ComboBox1 if vAttri = 'mailto:'then begin vAttri:=item.getAttribute('href',flag); ComboBox1.Items.Add(vAttri); end; end; end; end; end; end. |
2023-10-27
2022-08-15
2022-08-17
2022-09-23
2022-08-13
六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期
今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知
今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道
今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要
我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多
今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不
电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很
我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法
今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win
今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎
请发表评论