First create an ActiveX Library. Save it as MailieBand.dpr; then create a COM Object, save it as BandUnit.PAS; then create an Form, this window will be displayed as a sub-window in the IE toolbar, change the Border attribute of the window to BSnone, add A TBUTTON component and a TcomboBox component, change the TButton's CAPTION property to get all, then save the window file as iness.pas. In BandUnit, a TcomObject object that implements the interface mentioned above. As follows: TgetMailband = Class (Tcomobject, IdeskBand, IPERSISTREAMINIT)
In addition, since it is necessary to add some registry information when the COM server is registered, it is also necessary to establish an object that inherits from the TcomobjectFactory class, and writes the code to add additional registry information in the object's UpdateREGISTRY event. The following procedures list 1-6 to 1-8 are all program code for implementing the COM server:
Program List 1-6 Mailieband.dprlibrary mailieband;
Uses comServ, Bandunit in 'Bandunit.Pas', IEForm in 'ieform.pas' {form1}, mailieband_tlb in 'mailieband_tlb.pas';
Exports DllgetClassObject, DllcanunloadNow, DllRegisterServer, DllunregisterServer;
{$ R * .tlb}
{$ R * .res}
Begund.
Program List 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 {Declare IDeskBand methods here} 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; {Declare IObjectWithSite methods Here} Function Setsite (Const Punksite: IUNKNOWN): HRESULT; stdcall; function getsite (Const riid: TiID; OUT SITE: IUNKNOWN): HRESULT; stdcall;
{Declare IPersistStream methods here} 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;
Const class_getmailband: tguid = '{954F618B-0DEC-4D1A-9317-E0FC96F87865}'; // The following is IID IIUNKNOWN: Tguid = (D1: $ 00000000; D2: $ 0000; D3: $ 0000; D4: ($ C0, $ 00, 00, $ 00, $ 00, $ 00, $ 00, $ 46)); IID_IOLOBJECT: Tguid = (D1: $ 00000112; D2: $ 00; D3: $ 0000; D4: ($ C0, $ 00, $ 00, $ 00, $ 00, $ 00, $ 00 $ 46)); IID_IOLEWINDOW: Tguid = (D1: $ 00000114; D2: $ 00; D3: $ 0000; D4: ($ C0, $ 00, $ 00, $ 00, $ 00, $ 00, $ 46));
IID_IINPUTOBJECTSITE: Tguid = (D1: $ F1DB8392; D2: $ 7331; D3: $ 11D0; D4: ($ 8C, $ 2D, $ BF, $ E8)); SSID_SINTERNETEXPLORER: Tguid = '{0002DF05-0000-0000-C000-000000000046}'; siid_iwebbrowserapp: tguid = '{0002DF05-0000-0000-C000-000000000046}'; // The minimum width and height allowed by the panel. 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_NNOTIMPL;
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 damie.destroy; result: = s_ok; end;
Function TgetMailband.resizeborderdw (Var Prcborder: TRECT; PUNKTOOLBARSITE: IUNKNOWN; FRESERVED: BOOL): HRESULT; stdcall; begin result: = E_NOTIMPL;
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; // Get the handle of the parent window IE panel window PoleWindow.GetWindow (m_hwndparent);
IF (m_hwndparent = 0)........................
// Get the parent window area getClientRect (M_HWNDParent, RC);
If not assigned (fmie) THEN BEGIN / / Established TIEFORM window, the parent window is m_hwndparent frmie: = tform1.createparented (m_hwndparent); m_hwnd: = fmie.handle;
Setwindowlong (frmie.handle, gwl_style, getwindowl "or ws_child); // According to the Father Window Area Settings Window Location with FRMIE DO BEGIN LEFT: = rc.LEFT; Top: = rc.top; width: = Rc.right - rc.left; height: = rc.bottom - rc.top; end; fmie.visible: = true;
// Get the WebBrowser object associated with the browser. PolecMD: = punksite as iolecommandtarget; psp: = polecmd as iServiceProvider;
IF Assigned (PSP) THEN BEGIN PSP.QUERYSERVICE (iWebBrowSerapp, IWebBrowser2, fmie.iethis); 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) The begin m_dwbandid: = dwbandid; m_dwviewmode: = dwviewmode;
IF (PDBI.DWMASK AND DBIM_MINSIZE) <> 0 THEN BEGIN PDBI.PTMIZE.X: = min_size_x; pdbi.ptminsize.y: = min_size_y;
IF (pdbi.dwmask and dbim_maxsize) <> 0 dam pdbi.ptmaxsize.x: = -1; pdbi.ptmaxsize.y: = -1;
IF (pdbi.dwmask and dbim_integral) <> 0 dam pdbi.ptintegral.x: = 1; pdbi.ptintegral.y: = 1;
IF (pdbi.dwmask and dbim_Actual <> 0 dam: = 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;
Function TgetMailband.getClassID (OUT CLASSID: TCLSID): HRESULT; STDCALL; Begin ClassID: = Class_getmailBand; Result: = S_OK; END;
Function Tgetmailband.Indirty: hResult; stdcall; begin result: = s_false;
Function TgetMailband.initnew: hResult; begin Result: = E_NOTIMPL;
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;
// TIECLASSFAC classes Realize the registration of COM components TYPE TIECLASSFAC = Class (TcombjectFactory) // 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 // add additional registration entry 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_Get MailBand)); 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.
Program List 1-8 iForm.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 {Private declarations} public IEThis: IWebbrowser2; {Public declarations} end; var Form1: TFORM1;
IMPLEMENTATION
{$ R * .dfm}
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: = Height: = Self.clientHeight; width: = Self.ClientWidth - Left; 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; // get Document object doc: = Iethis.Document as htmldocument2; // Get all of the HTML elements set all: = doc.get_all;
Len: = all.get_gength;
// Access each element in the HTML element collection for i: = 0 to len-1 do begin item: = all.item (i, varempty) as htmlelement; // If this element is a link if item.get_tagname = ' A'then Begin Flag: = 0; Vattri: = Item.GetaTtRibute ('Protocol', FLAG); // Get Link Properties // If it is a mailto link, add a link to ComboBox1 if Vattri = 'mailto:' THEN Begin Vattri: = Item.GetaTribute ('href', flag); ComboBoBox1.items.Add (Vattri); end; end; end; end;
End.
Compile the project, close all IE windows, then click the Run | Register ActiveX Server item registration server for the Delphi menu. Then open the IE, click on the menu to view | Toolbar items, you can see a getMailAddress item in the submenu, select the change, the toolbar appears in the IE toolbar.
