如何用TwebBrowser拦弹出广告？(50分)

如何用TwebBrowser拦弹出广告？

//这时有一个TwebBrowser替代器,很好用,你的功能都有
{$DEFINE USE_IOLECOMMANDTARGET}
//***********************************************************
// EmbeddedWb ver 1.16b (Oct. 15 , 2001) *
// *
// For Delphi 4, 5 and 6 *
// Freeware Component *
// by *
// Per Linds?Larsen *
// per.lindsoe@larsen.mail.dk *
// *
// *
// Contributors: *
// *
// Mathias Walter (walter@coint.de) *
// - all messagehandling code *
// *
// Neil Moss (NeilM@BuchananInternational.com) *
// - code for setting downloadoptions *
// *
// Documentation and updated versions: *
// *
// http://www.euromind.com/iedelphi *
//***********************************************************


unit EmbeddedWB;

{$WARN SYMBOL_DEPRECATED OFF}
interface

uses
{$IFDEF VER140}Variants, {$ENDIF}
IEConst, IEUtils, Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
EXTCtrls, OleCtrls, Mshtml_tlb,{system32/Mshtml.dll} SHDocVw_tlb{system32/SHDocVw.dll}, ActiveX, shlObj, Wininet, Urlmon, shellapi;


type
{$IFDEF USE_IOLECOMMANDTARGET}
TScriptErrorEvent = procedure(Sender: TObject; ErrorLine, ErrorCharacter, ErrorCode, ErrorMessage, ErrorUrl: string;
var ContinueScript: Boolean; var Showdialog: Boolean) of object;
TRefreshEvent = procedure(Sender: TObject; CmdID: Integer; var Cancel: Boolean) of object;
TUnloadEvent = procedure(Sender: TObject) of object;
{$ENDIF}

TGetOverrideKeyPathEvent = function(pchKey: POLESTR; dw: DWORD): HRESULT of object;
TShowContextMenuEvent = function(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT of object;
TGetHostInfoEvent = function(var pInfo: TDOCHOSTUIINFO): HRESULT of object;
TShowUIEvent = function(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT of object;
THideUIEvent = function: HRESULT of object;
TUpdateUIEvent = function: HRESULT of object;
TEnableModelessEvent = function(const fEnable: BOOL): HRESULT of object;
TOnDocWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object;
TOnFrameWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object;
TResizeBorderEvent = function(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow;
const fRameWindow: BOOL): HRESULT of object;
TTranslateAcceleratorEvent = function(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
const nCmdID: DWORD): HRESULT of object;
TGetOptionKeyPathEvent = function(var pchKey: POLESTR; const dw: DWORD): HRESULT of object;
TGetDropTargetEvent = function(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT of object;
TGetExternalEvent = function(out ppDispatch: IDispatch): HRESULT of object;
TTranslateUrlEvent = function(const dwTranslate: DWORD; const pchURLIn: POLESTR;
var ppchURLOut: POLESTR): HRESULT of object;
TFilterDataObjectEvent = function(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT of object;
TShowMessageEvent = function(hwnd: THandle;
lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT of object;
TShowHelpEvent = function(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;
dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT of object;
TGetTypeInFoCountEvent = function(out Count: Integer): HResult of object;
TGetTypeInfoEvent = function(Index, LocaleID: Integer; out TypeInfo: ITypeInfo): HResult of object;
TGetIDsOfNamesEvent = function(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult of object;
TInvokeEvent = function(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params: TagDispParams; VarResult, ExcepInfo, ArgErr: Pointer): HResult of object;
TQueryServiceEvent = function(const rsid, iid: TGuid; out Obj: IUnknown): HResult of object;
TShowDialogEvent = procedure(Sender: TObject; h: THandle) of object;


TDownloadControlOption = (DLCTL_DLIMAGES, DLCTL_VIDEOS, DLCTL_BGSOUNDS,
DLCTL_NO_SCRIPTS, DLCTL_NO_JAVA, DLCTL_NO_RUNACTIVEXCTLS, DLCTL_NO_DLACTIVEXCTLS,
DLCTL_DOWNLOADONLY, DLCTL_NO_FRAMEDOWNLOAD, DLCTL_RESYNCHRONIZE, DLCTL_PRAGMA_NO_CACHE,
DLCTL_NO_BEHAVIORS, DLCTL_NO_METACHARSET, DLCTL_URL_ENCODING_DISABLE_UTF8,
DLCTL_URL_ENCODING_ENABLE_UTF8, DLCTL_FORCEOFFLINE, DLCTL_NO_CLIENTPULL,
DLCTL_SILENT, DLCTL_OFFLINE);

TDownloadControlOptions = set of TDownloadControlOption;

TUserInterfaceOption = (DIALOG, DISABLE_HELP_MENU, NO3DBORDER,
SCROLL_NO, DISABLE_SCRIPT_INACTIVE, OPENNEWWIN, DISABLE_OFFSCREEN,
FLAT_SCROLLBAR, DIV_BLOCKDEFAULT, ACTIVATE_CLIENTHIT_ONLY, OVERRIDEBEHAVIORFACTORY,
CODEPAGELINKEDFONTS, URL_ENCODING_DISABLE_UTF8, URL_ENCODING_ENABLE_UTF8,
ENABLE_FORMS_AUTOCOMPLETE, ENABLE_INPLACE_NAVIGATION, IME_ENABLE_RECONVERSION);

TUserInterfaceOptions = set of TUserInterfaceOption;

type

TMeasure = (mMetric, mUS);

TPrintOrientationOption = (poPortrait, poLandscape);

TMargins = class(TPersistent)
private
FLeft: Real;
FRight: Real;
FTop: Real;
FBottom: real;
published
property Left: Real read FLeft write FLeft;
property Right: Real read FRight write FRight;
property Top: Real read FTop write FTop;
property Bottom: Real read FBottom write FBottom;
end;

TPrintOptions = class(TPersistent)
private
FHTMLHeader: TStrings;
FHeader: string;
FFooter: string;
FMargins: TMargins;
FOrientation: TPrintOrientationOption;
FMeasure: TMeasure;
procedure SetHTMLHeader(const Value: Tstrings);
property Measure: TMeasure read FMeasure;
published
property Margins: TMargins read FMargins write FMargins;
property Header: string read FHeader write FHeader;
property HTMLHeader: TStrings read FHTMLHeader write SetHTMLHeader;
property Footer: string read FFooter write FFooter;
property Orientation: TPrintOrientationOption read FOrientation write FOrientation;
end;

TEmbeddedWB = class(TWebbrowser, IDocHostShowUI, IDocHostUIHandler,
IDocHostUIHandler2, IDispatch, IServiceProvider,
{$IFDEF USE_IOLECOMMANDTARGET}
IOleCommandTarget
{$ENDIF}
)
private
{$IFDEF VER120}
SaveMessage: TMessageEvent;
{$ENDIF}
//FUserAgent: string;
FReplaceCaption: Boolean;
FPrintOptions: TPrintOPtions;
FDownloadControlOptions: TDownloadControlOptions;
FUserInterfaceOptions: TUserInterfaceOptions;
{$IFDEF USE_IOLECOMMANDTARGET}
FOnUnload: TUnloadEvent;
FOnRefresh: TRefreshEvent;
FOnScriptError: TScriptErrorEvent;
{$ENDIF}
FOnGetOverrideKeyPath: TGetOverrideKeypathEvent;
FOnShowContextMenu: TShowcontextmenuEvent;
FOnGetHostInfo: TGetHostInfoEvent;
FOnShowUI: TShowUIEvent;
FOnHideUI: THideUIEvent;
FOnUpdateUI: TUpdateUIEvent;
FOnEnableModeless: TEnableModelessEvent;
FOnOnDocWindowActivate: TOnDocWindowActivateEvent;
FOnOnFrameWindowActivate: TOnFrameWindowActivateEvent;
FOnResizeBorder: TResizeBorderEvent;
FOnTranslateAccelerator: TTranslateAcceleratorEvent;
FOnGetOptionKeyPath: TGetOptionKeyPathEvent;
FOnGetDropTarget: TGetDropTargetEvent;
FOnGetExternal: TGetExternalEvent;
FOnTranslateUrL: TTranslateUrlEvent;
FOnFilterDataObject: TFilterDataObjectEvent;
FHelpFile: string;
FOnShowMessage: TShowMessageEvent;
FOnShowHelp: TShowHelpEvent;
FOnGetTypeInfoCount: TGetTypeInfoCountEvent;
FOnGetTypeInfo: TGetTypeInfoEvent;
FOnGetIDsOfNames: TGetIDsOfNamesEvent;
FOnInvoke: TInvokeEvent;
FOnQueryService: TQueryServiceEvent;
FOldWindowProc: TWndMethod;
FParentForm: TForm;
FDownloadOptionValue: Longint;
FUserInterfaceValue: Cardinal;
FOnCloseQuery: TCloseQueryEvent;
FOnShowDialog: TShowDialogEvent;
OldWBWndProc: TWndMethod;
RuntimeMeasure: TMeasure;
DDEHWnd: THandle;
FEnableDDE: Boolean;
FfpExceptions: Boolean;
//procedure SetUserAgent;
//procedure RemoveUserAgent;
procedure GetPrintValues;
procedure Hook;
procedure UnHook;
procedure FormWndProc(var AMsg: TMessage);
procedure DDEWndProc(var AMsg: TMessage);
procedure WBWndProc(var Message: TMessage);
procedure SetDownloadOptions(const Value: TDownloadControlOptions);
procedure SetUserInterfaceOptions(const Value: TUserInterfaceOptions);
procedure SetfpExceptions(const Value: Boolean);

procedure UpdateDownloadControlValue;
procedure UpdateUserInterfaceValue;
protected
function DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL;
function DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
function DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
function GetOverrideKeyPath(pchKey: POLESTR; dw: DWORD): HRESULT; stdcall;

{$IFDEF USE_IOLECOMMANDTARGET}
function QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
prgCmds: POleCmd; CmdText: POleCmdText): HResult; stdcall;
function Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
const vaIn: OleVariant; var vaOut: OleVariant): HResult; stdcall;
{$ENDIF}
function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; stdcall;
function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
function HideUI: HRESULT; stdcall;
function UpdateUI: HRESULT; stdcall;
function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow;
const FrameWindow: BOOL): HRESULT; stdcall;
function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
const nCmdID: DWORD): HRESULT; stdcall;
function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall;
function GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT; stdcall;
function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
var ppchURLOut: POLESTR): HRESULT; stdcall;
function FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT; stdcall;
function ShowMessage(hwnd: THandle;
lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall;
function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;
dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
{$IFDEF VER120}
procedure IEMessageHandler(var Msg: TMsg; var Handled: Boolean);
{$ENDIF}
function QueryService(const rsid, iid: TGuid; out Obj): HResult; stdcall;
//function OpenClient(Client: string): Boolean;
function PrintMarginStr(M: Real): PChar;
public
SecurityManager: IInternetSecurityManager;
ZoneManager: IInternetZoneManager;
//function ShowMailClient: Boolean;
//function ShowNewsClient: Boolean;
//function ShowAddressBook: Boolean;
//function ShowCalendar: Boolean;
//function ShowInternetCall: Boolean;
procedure AssignDocument;
procedure SetFocusToDoc;
procedure InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant);
procedure Go(Url: string);
procedure Print;
procedure OpenDialog;
procedure SaveDialog;
procedure PrintSetup;
procedure PageSetup(UsePrintOptions: Boolean);
procedure ViewSource;
procedure Properties;
procedure Options;
procedure Find;
{$IFDEF VER120}
procedure EnableMessagehandler;
procedure DisableMessagehandler;
{$ENDIF}
procedure Copy;
procedure SelectAll;
procedure Zoom(ZoomValue: Integer);
function ZoomRangeHigh: Integer;
function ZoomRangeLow: Integer;
function ZoomValue: Integer;
procedure NavigatePidl(pidl: PItemIdlist);
procedure NavigateFolder(CSIDL: Integer);
procedure SetGlobalOffline(Value: Boolean);
function IsGlobalOffline: boolean;
function LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult;
function LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT;
function SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT;
function SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT;
function SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT;
function LoadFromStream(const AStream: TStream): HRESULT;
function LoadFromStrings(const AStrings: TStrings): HRESULT;
function SaveToStrings(AStrings: TStrings): HRESULT;
function SaveToStream(AStream: TStream): HRESULT;
function SaveToFile(const Fname: string): HRESULT;
constructor Create(Owner: TComponent); override;
procedure Loaded; override;
destructor Destroy; override;
procedure PrintPreView;
procedure PrintWithOptions;
function GetFrame(FrameNo: Integer): IWebbrowser2;
function FrameCount: LongInt;
procedure GetThumbnail(var Image: TImage);
procedure ClearHistory;
procedure ClearCache;
published
property DownloadOptions: TDownloadControlOptions read FDownloadControlOptions write SetDownloadOptions;
property UserInterfaceOptions: TUserInterfaceOptions read FUserInterfaceOptions write SetUserInterfaceOptions;
{$IFDEF USE_IOLECOMMANDTARGET}
property OnRefresh: TRefreshEvent read FOnRefresh write FOnRefresh;
property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError;
property OnUnload: TUnloadEvent read FOnUnload write FOnUnload;
{$ENDIF}
property OnGetOverrideKeyPath: TGetOVerrideKeypathEvent read FOnGetOverrideKeyPath write FOnGetOverrideKeyPath;
property OnShowContextMenu: TShowContextMenuEvent read FOnShowContextmenu write FOnShowContextmenu;
property OnGetHostInfo: TGetHostInfoEvent read FOnGethostinfo write fongethostinfo;
property OnShowUI: TShowUIEvent read FOnShowUI write FOnShowUI;
property OnHideUI: THideUIEvent read FOnHideUI write FOnHideUI;
property OnUpdateUI: TUpdateUIEvent read FOnUpdateUI write FOnUpdateUI;
property OnEnableModeless: TEnableModelessEvent read FOnEnableModeless write FOnEnableModeless;
property OnOnDocWindowActivate: TOnDocWindowActivateEvent read FOnOnDocWindowActivate write FOnOnDocWindowActivate;
property OnOnFrameWindowActivate: TOnFrameWindowActivateEvent read FOnOnFrameWindowActivate write FOnOnFrameWindowActivate;
property OnResizeBorder: TResizeBorderEvent read FOnResizeBorder write FOnResizeBorder;
property OnTranslateAccelerator: TTranslateAcceleratorEvent read FOnTranslateAccelerator write FOnTranslateAccelerator;
property OnGetOptionKeyPath: TGetOptionKeyPathEvent read FOnGetOptionKeyPath write FOnGetOptionKeyPath;
property OnGetDropTarget: TGetDropTargetEvent read FOnGetDropTarget write FOnGetDropTarget;
property OnGetExternal: TGetExternalEvent read FOnGetExternal write FOnGetExternal;
property OnTranslateUrl: TTranslateUrlEvent read FOnTranslateUrL write FOnTranslateUrL;
property OnFilterDataObject: TFilterDataObjectEvent read FOnFilterDataObject write FOnFilterDataObject;
property HelpFile: string read FHelpFile write FHelpFile;
property OnShowMessage: TShowMessageEvent read FOnShowMessage write FOnShowMessage;
property OnShowHelp: TShowHelpEvent read FOnShowHelp write FOnShowHelp;
property OnGetTypeInfoCount: TGetTypeInfoCountEvent read FonGetTypeInfoCount write FOnGetTypeInfoCount;
property OnGetTypeInfo: TGetTypeInfoEvent read FonGetTypeInfo write FOnGetTypeInfo;
property OnGetIDsOfNames: TGetIDsOfNamesEvent read FOnGetIDsOfNames write FOnGetIdsOfNames;
property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke;
property OnQueryService: TQueryServiceEvent read FOnQueryService write FOnQueryService;
property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;
property OnShowDialog: TShowDialogEvent read FOnShowDialog write FOnShowDialog;
property PrintOptions: TPrintOptions read FPrintOptions write FPrintOptions;
//property UserAgent: string read FUserAgent write FUserAgent;
property ReplaceCaption: Boolean read FReplaceCaption write FReplaceCaption;
property EnableDDE: Boolean read FEnableDDE write FEnableDDE;
property fpExceptions: Boolean read FfpExceptions write SetfpExceptions;
end;

function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
function RegisterNameSpace(clsid: TGUID): HRESULT;
function UnregisterNameSpace: HRESULT;



procedure Register;

implementation

uses comobj;


var
Saved8087CW: Word;
PrintingWithOptions: Boolean;
InvokingPagesetup: Boolean;
MimeFactory, NSFactory: IClassFactory;
MimeInternetSession, NSInternetSession: IInternetSession;
DontRespond: Boolean;
OpenFolder, ExploreFolder: string;
FoldersApp, FoldersTopic: string;
FindFolder: string;
HtmlFileApp, HtmlFileTopic: string;
fHtmlCommand: Boolean;
{$IFDEF VER120}
bMsgHandler: Boolean;
{$ENDIF}



procedure TEmbeddedWB.GetThumbnail(var Image: TImage);
var
DrawRect: TRect;
begin
if Image = nil then exit;
DrawRect := Rect(0, 0, Image.Height, Image.width);
Image.Picture.Bitmap.Height := image.height;
Image.Picture.Bitmap.Width := image.Width;
({$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IviewObject).Draw(DVASPECT_DOCPRINT, 0, nil, nil, 0,
image.Canvas.Handle, @DrawRect, nil, nil, 0);
Image.Refresh;
end;



procedure TEmbeddedWB.SetfpExceptions(const Value: Boolean);
begin
if not Value then begin
Set8087CW($133F);
FfpExceptions := False;
end
else
begin
Set8087CW(Saved8087CW);
FfpExceptions := True;
end;
end;


function TEmbeddedwb.GetFrame(FrameNo: Integer): IWebbrowser2;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: IUnknown;
Fetched: PLongint;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
begin
Fetched := nil;
OleContainer := Document as IOleContainer;
OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
Enum.Skip(FrameNo);
Enum.Next(1, Unk, Fetched);
Result := Unk as IWebbrowser2;
end else Result := nil;
end;


{
Ver. 1.16:
Thanks to Brian Lowe for Fixing OLE-problem in function FrameCount:
http://groups.yahoo.com/group/delphi-webbrowser/message/4194
}

function TEmbeddedWB.FrameCount: LongInt;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;"
EnumResult: HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
begin
OleContainer := Document as IOleContainer;
EnumResult := OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
if EnumResult = S_OK then // Added per OLE help
Enum.Next(100, Unk, @Result)
else // Added per OLE help
Enum := nil;
end else
Result := 0;
end;


{procedure TEmbeddedWB.SetUserAgent;
var
reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('/Software/Microsoft/Windows/CurrentVersion/Internet Settings/User Agent/Post Platform', True)
then Reg.WriteString(FUserAgent, '');
finally
Reg.CloseKey;
Reg.Free;
end;
end;

procedure TEmbeddedWB.RemoveUserAgent;
var
reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('/Software/Microsoft/Windows/CurrentVersion/Internet Settings/User Agent/Post Platform', FALSE)
then reg.DeleteValue(FUseragent);
finally
Reg.CloseKey;
Reg.Free;
end;
end;}


function GetDDEVariables: Boolean;
var
s: string;
Reg: TRegistry;
begin
Reg := Tregistry.Create;
with Reg do try
RootKey := HKEY_CLASSES_ROOT;
OpenKey('htmlfile/shell/open/ddeexec/application', False);
HtmlFileApp := Readstring('');
CloseKey;
OpenKey('htmlfile/shell/open/ddeexec/topic', FALSE);
HtmlFileTopic := ReadString('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec/application', False);
FoldersApp := Readstring('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec/topic', FALSE);
FoldersTopic := ReadString('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
OpenFolder := Copy(s, 1, Pos('(', S) - 1);
OpenKey('Folder/shell/explore/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
ExploreFolder := Copy(s, 1, Pos('(', S) - 1);
OpenKey('Directory/shell/find/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
FindFolder := Copy(s, 1, Pos('(', S) - 1);
Result := True;
except
Result := False;
end;
Reg.Free;
end;


function GetCommandTypeFromDDEString(szCommand: string): UINT;
begin
szCommand := Copy(szCommand, Pos('[', szCommand) + 1, length(szCommand));
szCommand := Copy(szCommand, 1, Pos('(', szCommand) - 1);
if szCommand = Openfolder then Result := VIEW_COMMAND else
if szCommand = Explorefolder then Result := EXPLORE_COMMAND else
if szCommand = Findfolder then Result := FIND_COMMAND else
Result := NO_COMMAND;
end;

function GetPathFromDDEString(szCommand: string; var szFolder: string): Boolean;
begin
szCommand := Copy(szCommand, Pos('"', szCommand) + 1, length(szCommand));
szFolder := Copy(szCommand, 1, Pos('"', szCommand) - 1);
Result := (szFolder <> '');
end;




function GetPidlFromDDEString(szCommand: string): PItemIDList;
var
pidlShared, pidlGlobal: PItemIDList;
dwProcessID: Integer;
hShared: THandle;
s: string;
ProcessID: string;
i: Integer;
begin
s := Copy(szCommand, Pos(',', szCommand) + 1, length(szCommand));
i := 1;
while not (s in IsDigit) and (i <= Length(s)) do Inc(i);
processID := Copy(s, i, Length(S));
s := copy(S, i, length(s) - 1);
i := 1;
while (s in IsDigit) and (i <= Length(s)) do Inc(i);
s := copy(S, 1, i - 1);

while not ((ProcessID = ':') or (ProcessID = ',')) and (i <= Length(processID)) do Inc(i);
if ProcessID = ':' then
begin
ProcessID := Copy(ProcessID, i, Length(ProcessID));
i := 1;
while not (ProcessID in IsDigit) and (i <= Length(ProcessID)) do Inc(i);
ProcessID := Copy(ProcessID, i, Length(ProcessID));
i := 1;
while (ProcessID in IsDigit) and (i <= Length(ProcessID)) do Inc(i);
if not (ProcessID in IsDigit) then ProcessID := Copy(ProcessID, 1, i - 1);
end else ProcessID := '0';
dwProcessID := StrToInt(ProcessID);
if dwProcessID <> 0 then begin
hShared := StrToInt(s);
pidlShared := ShLockShared(hShared, dwProcessId);
if PidlShared <> nil then
begin
Result := CopyPidl(PidlShared);
ShUnlockShared(pidlShared);
end else Result := nil;
ShFreeShared(hShared, dwProcessID);
end else
begin
pidlGlobal := PItemIDList(StrToInt(s));
Result := CopyPidl(pidlGlobal);
_Free(pidlGlobal);
end;
end;

function GetShowCmdFromDDEString(szCommand: string): Integer;
var
i: Integer;
begin
i := 1;
while szCommand <> ',' do Inc(i);
Inc(i);
while szCommand <> ',' do Inc(i);
szCommand := Copy(szCommand, i, Length(szCommand));
i := 0;
repeat
inc(i)
until (i > Length(szCommand)) or (szCommand in IsDigit);
if i <= length(szCommand) then result := StrtoInt(szCommand) else
result := 1;
end;


function ParseDDECommand(szCommand: string; var szFolder: string; var pidl: PItemIDList; var show: Integer): UINT;
begin
Result := GetCommandTypeFromDDEString(szCommand);
if Result <> NO_COMMAND then begin
GetPathFromDDEString(szCommand, szFolder);
pidl := GetPidlFromDDEString(szCommand);
Show := GetShowCmdFromDDEString(szCommand);
end;
end;


function TEmbeddedwb.DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL;
begin
Result := PostMessage(THandle(iwParam), WM_DDE_TERMINATE, handle, 0);
end;



function TEmbeddedWB.DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
var
dwThreadID: DWORD;
dwProcessID: DWORD;
hwndClient: Integer;
aInApp,
aInTopic,
aOutApp,
aOutTopic: ATOM;
szInAppName,
szInAppTopic: array[0..255] of Char;
begin

FillChar(szInAppName, SizeOf(szInAppName), 0);
FillChar(szInAppTopic, SizeOf(szInAppTopic), 0);

if DontRespond then
begin
result := 0;
exit;
end;

hwndClient := THandle(iwParam);
dwThreadID := GetWindowThreadProcessId(hwndClient, @dwProcessID);
if (GetCurrentProcessId() <> dwProcessID) or (GetCurrentThreadID() <> dwThreadID) then
begin
result := 0;
exit;
end;
aInApp := LOWORD(ilParam);
aInTopic := HIWORD(ilParam);
GlobalGetAtomName(aInApp, szInAppName, SizeOf(szInAppName));
GlobalGetAtomName(aInTopic, szInAppTopic, SizeOf(szInAppTopic));
if szInAppName = HtmlFileApp then
begin
fHtmlCommand := True;
aOutApp := GlobalAddAtom(PChar(HtmlFileApp));
aOutTopic := GlobalAddAtom(PChar(HtmlFileTopic));
if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then
SendMessage(hwndClient, WM_DDE_ACK, WPARAM(handle), MAKELPARAM(aOutApp, aOutTopic));
if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp);
if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic);
end
else
begin
fHtmlCommand := False;
aOutApp := GlobalAddAtom(PChar(FoldersApp));
aOutTopic := GlobalAddAtom(PChar(FoldersTopic));
if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then
SendMessage(HWNDClient, WM_DDE_ACK, WPARAM(Handle), MAKELPARAM(aOutApp, aOutTopic));
if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp);
if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic);
end;
result := 0;
end;

function TEmbeddedwb.DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
var
szFolder: string;
szCommand: LPTSTR;
uLo: PUINT;
hgMem: HGLOBAL;
ack: DDEACK;
lpTemp: PUINT;
uCommand: Cardinal;
show: Integer;
pidl: PITEMIDLIST;
sei: TShellExecuteInfo;
szTmp: string;
begin
ulo := nil;
if UnpackDDElParam(WM_DDE_EXECUTE, ilParam, uLo, @hgMem)
then begin
szCommand := GlobalLock(hgmem);
ZeroMemory(@Ack, sizeof(ddeAck));
if (szCommand <> nil) then
begin
if fHtmlCommand then
begin
szTmp := szCommand;
if Pos('"', szTmp) = 1 then
begin
Delete(szTmp, 1, 1);
szTmp := System.Copy(szTmp, 1, Pos('"', szTmp) - 1);
end;
Go(szTmp);
Ack.flags := 1;
end
else
begin
uCommand := ParseDDECommand(szCommand, szFolder, pidl, Show);
case uCommand of
VIEW_COMMAND:
begin

if (szFolder <> '') then Go(szFolder)
else
if (pidl <> nil) then NavigatePidl(pidl);
DisposePidl(pidl);
Ack.flags := 1;
end;
EXPLORE_COMMAND:
begin
DontRespond := TRUE;
ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO));
sei.cbSize := sizeof(SHELLEXECUTEINFO);
if szFolder <> '' then begin
sei.fMask := SEE_MASK_CLASSNAME;
sei.lpFile := Pchar(szFolder);
end else
begin
sei.fMask := SEE_MASK_IDLIST or SEE_MASK_CLASSNAME;
sei.lpIDList := pidl;
end;
sei.lpClass := 'folder';
sei.Wnd := 0;
sei.nShow := Show;
sei.lpVerb := 'explore';
ShellExecuteEx(@sei);
DontRespond := FALSE;
DisposePidl(pidl);
Ack.flags := 1;
end;
FIND_COMMAND:
begin
DontRespond := TRUE;
ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO));
sei.cbSize := sizeof(SHELLEXECUTEINFO);
if (szFolder <> '')
then begin
sei.fMask := 0;
sei.lpFile := PChar(szFolder);
end
else
begin
sei.fMask := SEE_MASK_IDLIST;
sei.lpIDList := pidl;
end;
sei.wnd := 0;
sei.nShow := Show;
sei.lpVerb := 'find';
ShellExecuteEx(@sei);
DontRespond := FALSE;
DisposePidl(pidl);
Ack.flags := 1;
end;
end;
end;
GlobalUnlock(hgMem);
lpTemp := @Ack;
PostMessage(Thandle(iwParam),
WM_DDE_ACK,
WPARAM(handle),
ReuseDDElParam(ilParam, WM_DDE_EXECUTE, WM_DDE_ACK, lpTemp^, hgMem));
end;
end;
Result := 0;
end;


procedure TEmbeddedwb.PrintWithOptions;
begin
PrintingWithOptions := True;
Pagesetup(TRUE);
Print;
end;


procedure TembeddedWB.GetPrintValues;
var
S: string;
regWinRegistry: TRegistry;

function ReadMargin(key: string): Real;
begin
S := RegwinRegistry.ReadString(key);
S := Stringreplace(S, ' ', '', [rfReplaceAll]);
if DecimalSeparator <> '.' then
S := Stringreplace(S, '.', DecimalSeparator, []);
if Printoptions.Measure = mMetric then
result := StrtoFloat(S) * InchToMetric else
result := StrtoFloat(S);
end;

begin
regWinRegistry := TRegistry.Create;
try
with regWinRegistry do begin
RootKey := HKEY_CURRENT_USER;
if OpenKey('Software/Microsoft/Internet Explorer/PageSetup', False) then
begin
PrintOptions.Header := Readstring('header');
PrintOptions.Footer := ReadString('footer');
PrintOptions.Margins.left := ReadMargin('margin_left');
PrintOptions.Margins.right := ReadMargin('margin_right');
PrintOptions.Margins.top := ReadMargin('margin_top');
PrintOptions.Margins.bottom := ReadMargin('margin_bottom');
end;
end;
finally
regWinRegistry.Free;
end;
end;


procedure TEmbeddedWB.Loaded;
begin
inherited Loaded;
CoInternetCreateSecuritymanager(self, SecurityManager, 0);
CoInternetCreateZoneManager(self, ZoneManager, 0);
UpdateDownloadControlValue;
UpdateUserInterfaceValue;
hook;
if not (csDesigning in ComponentState) then
begin
OldWBWndProc := WindowProc;
WindowProc := WBWndProc;
//SetUserAgent;
end else
begin
PrintOptions.FMeasure := RunTimeMeasure;
GetPrintValues;
end;

end;

function TEmbeddedWB.PrintMarginStr(M: Real): PChar;
var
S: string;
begin
if printOptions.Measure <> RuntimeMeasure
then begin
if RuntimeMeasure = mMetric then
s := FloatToStr(M * InchToMetric) else
s := FloatToStr(M / InchToMetric);
Result := PChar(S);
end else Result := PChar(FloatToStr(M));
end;


constructor TEmbeddedWb.Create(Owner: TComponent);
var
Buf: array[1..10] of Char;
begin
FfpExceptions := True;
inherited;
{$IFDEF VER120}
enablemessagehandler;
{$ENDIF}
GetDDEVariables;
DDEHWnd := AllocateHWnd(DDEWndProc);
FPrintOptions := TPrintOptions.Create;
FPrintOptions.Margins := TMargins.Create;
FPrintOptions.FHTMLHeader := TStringlist.Create;
FPrintOptions.FHTMLHeader.Add('<HTML></HTML>');
FillChar(Buf, SizeOf(Buf), 0);
GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, @Buf[1], SizeOf(Buf));
if Buf[1] = '1' then RunTimeMeasure := mUS else
RunTimeMeasure := mMetric;
DownloadOptions := [DLCTL_DLIMAGES, DLCTL_BGSOUNDS, DLCTL_VIDEOS];
UserInterfaceOptions := [];
FEnableDDE := False;
end;


destructor TEmbeddedWb.Destroy;
begin
DeAllocateHWnd(DDEHwnd);
FPrintOptions.HTMLHeader.Free;
FPrintoptions.Margins.Free;
FPrintoptions.Free;
unhook;
//RemoveUserAgent;
{$IFDEF VER120}
disablemessagehandler;
{$ENDIF}
inherited;
end;


function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, MimeFactory);
CoInternetGetSession(0, MimeInternetSession, 0);
Result := MIMEInternetSession.RegisterMimeFilter(MimeFactory, Clsid, MIME);
end;

function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
begin
Result := MIMEInternetSession.UnregisterMimeFilter(MIMEFactory, MIME);
end;


function RegisterNameSpace(clsid: TGUID): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, NSFactory);
CoInternetGetSession(0, NSInternetSession, 0);
Result := NSInternetSession.RegisterNameSpace(NSFactory, Clsid, 'http', 0, nil, 0);
end;

function UnregisterNameSpace: HRESULT;
begin
Result := NSInternetSession.UnregisterNameSpace(NSFactory, 'http');
end;


procedure TEmbeddedWB.Hook;
begin
if (csDesigning in ComponentState) then exit;
FParentform := TForm(Owner);
if (FParentForm <> nil) and (FParentForm.HandleAllocated) then
begin
FOldWindowProc := FParentForm.WindowProc;
FParentForm.WindowProc := FormWndProc;
end;
end;

procedure TEmbeddedWB.UnHook;
begin
if (csDesigning in ComponentState) then exit;
if (FParentForm <> nil) and (FParentForm.HandleAllocated) then
FParentForm.WindowProc := FOldWindowProc;
// FOldWindowProc := nil;
FParentform := nil;
end;


procedure TEmbeddedWB.DDEWndProc(var AMsg: TMessage);
begin
with AMsg do
if (Msg = WM_DDE_INITIATE) and FEnableDDE
then DDEInitiate(wparam, lparam)
else
Result := DefWindowProc(DDEHWND, msg, wParam, lParam);
end;


procedure TEmbeddedWB.FormWndProc(var AMsg: TMessage);
var
i: Integer;
wnd: Integer;
S: string;
Msg: TWmActivate;
begin
if AMsg.Msg = WM_ACTIVATE then begin
Msg := TWmActivate(AMsg);
if Msg.Active = 0 then
begin
wnd := Msg.ActiveWindow;
SetLength(S, 80);
SetLength(S, GetClassName(Wnd, PChar(S), Length(S)));
if (S = '#32770') then
begin
if ReplaceCaption then
begin
SendMessage(wnd, WM_SETICON, ICON_SMALL, Forms.Application.Icon.Handle);
I := GetWindowTextLength(wnd);
SetLength(S, I + 1);
GetWindowText(Wnd, PChar(S), I + 1);
S := StringReplace(S, 'Microsoft ', '', []);
S := StringReplace(S, 'Internet Explorer', Forms.Application.Title, []);
SetWindowText(Wnd, Pchar(S));
end;
if InvokingPageSetup then
begin
InvokingPagesetup := False;
if PrintingWithOptions then
begin
SetWindowPos(Wnd, 0, -600, 0, 0, 0, 0);
PrintingWithOptions := False;
end;
if PrintOptions.Orientation = poPortrait then
SendDlgItemMessage(Wnd, $0420, BM_CLICK, 0, 0) else
SendDlgItemMessage(Wnd, $0421, BM_CLICK, 0, 0);
SetDlgItemText(wnd, $1FD3, PChar(PrintOptions.Header));
SetDlgItemText(wnd, $1FD5, PChar(PrintOptions.Footer));
SetDlgItemText(wnd, $0483, PrintMarginStr(PrintOptions.Margins.Left));
SetDlgItemText(wnd, $0484, PrintMarginStr(PrintOptions.Margins.top));
SetDlgItemText(wnd, $0485, PrintMarginStr(PrintOptions.Margins.Right));
SetDlgItemText(wnd, $0486, PrintMarginStr(PrintOptions.Margins.Bottom));
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4) then
PostMessage(FindWindowEx(wnd, 0, Pchar('Button'), nil), BM_CLICK, 0, 0) //Win2000
else SendDlgItemMessage(Wnd, 1, BM_CLICK, 0, 0);
end;
end;
if not PrintingWithOptions and (wnd <> 0) and Assigned(FOnShowDialog) then FOnShowDialog(self, Wnd);
end;
end;
FOldWindowProc(AMsg);
end;

function TEmbeddedWB.QueryService(const rsid, iid: TGuid; out Obj): HResult;
begin
if Assigned(FOnQueryService) then
Result := FOnQueryService(rsid, iid, IUnknown(obj)) else
Result := E_NOINTERFACE;
end;


{function TEmbeddedWB.ShowMailClient: Boolean;
begin
result := OpenClient('Mail');
end;

function TEmbeddedWB.ShowNewsClient: Boolean;
begin
result := OpenClient('News');
end;

function TEmbeddedWB.ShowAddressBook: Boolean;
begin
result := OpenClient('Contacts');
end;

function TEmbeddedWB.ShowCalendar: Boolean;
begin
result := OpenClient('Calendar');
end;

function TEmbeddedWB.ShowInternetCall: Boolean;
begin
result := OpenClient('Internet Call');
end;


function TEmbeddedWB.OpenClient(Client: string): Boolean;
var
s, params, Exec: string;
begin
Result := FALSE;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software/Clients/' + Client, FALSE);
S := ReadString('');
CloseKey;
OpenKey('Software/Clients/' + Client + '/' + S + '/shell/open/command', FALSE);
S := ReadString('');
CloseKey;
if S <> '' then begin
if Pos('/', S) > 0 then begin
Exec := system.Copy(S, 1, Pos('/', S) - 2);
Params := system.Copy(s, Length(exec) + 1, length(S));
end else begin
Exec := S;
Params := '';
end;
Result := TRUE;
shellExecute(handle, 'open', Pchar(Exec), pChar(Params), '', SW_SHOW);
end;
finally
Free;
end;
end;}


procedure TEmbeddedWB.PrintPreView;
// IE 5.5 only
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;


procedure TEmbeddedWB.SetDownloadOptions(const Value:
TDownloadControlOptions);
begin
FDownloadControlOptions := Value;
UpdateDownloadControlValue;
{$IFDEF VER120}
(Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ELSE}
(Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ENDIF}
end;

procedure TEmbeddedWB.SetUserInterfaceOptions(const Value:
TUserInterfaceOptions);
begin
FUserInterfaceOptions := Value;
UpdateUserInterfaceValue;
{$IFDEF VER120}
(Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ELSE}
(Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ENDIF}
end;

procedure TEmbeddedWB.UpdateDownloadControlValue;
const
acardDownloadControlValues: array[TDownloadControlOption] of Cardinal =
($00000010, $00000020, $00000040, $00000080,
$00000100, $00000200, $00000400, $00000800,
$00001000, $00002000, $00004000, $00008000,
$00010000, $00020000, $00040000, $10000000,
$20000000, $40000000, $80000000);
var
i: TDownloadControlOption;
begin
FDownloadOptionValue := 0;
if (FDownloadControlOptions <> []) then
for i := Low(TDownloadControlOption) to High(TDownloadControlOption)
do
if (i in FDownloadControlOptions) then
Inc(FDownloadOptionValue, acardDownloadControlValues);
end;

procedure TEmbeddedWB.UpdateUserInterfaceValue;
const
acardUserInterfaceValues: array[TUserInterfaceOption] of Cardinal =
($00000001, $00000002, $00000004, $00000008,
$00000010, $00000020, $00000040, $00000080,
$00000100, $00000200, $00000400, $00000800,
$00001000, $00002000, $00004000, $00010000, $00020000);
var
i: TUserInterfaceOption;
begin
FUserInterfaceValue := 0;
if (FUserInterfaceOptions <> []) then
for i := Low(TUserInterfaceOption) to High(TUserInterfaceOption) do
if (i in FUserInterfaceOptions) then
Inc(FUserInterfaceValue, acardUserInterfaceValues);
end;


function TEmbeddedWB.IsGlobalOffline: boolean;
var
dwState: DWORD;
dwSize: DWORD;
begin
dwState := 0;
dwSize := SizeOf(dwState);
result := false;
if (InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @dwState,
dwSize)) then
if ((dwState and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0) then
result := true;
end;

procedure TEmbeddedWB.SetGlobalOffline(Value: Boolean);
const
INTERNET_STATE_DISCONNECTED_BY_USER = $10;
ISO_FORCE_DISCONNECTED = $1;
INTERNET_STATE_CONNECTED = $1;
var
ci: TInternetConnectedInfo;
dwSize: DWORD;
begin
dwSize := SizeOf(ci);
if (Value) then begin
ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER;
ci.dwFlags := ISO_FORCE_DISCONNECTED;
end else begin
ci.dwFlags := 0;
ci.dwConnectedState := INTERNET_STATE_CONNECTED;
end;
InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, dwSize);
end;


function SaveDocToStream(Doc: IDispatch; var AStream: TStream): HResult;
var
IpStream: IPersistStreamInit;
begin
if Doc <> nil then begin
IpStream := Doc as IPersistStreamInit;
Result := IpStream.save(TStreamAdapter.Create(AStream), TRUE);
end else Result := S_FALSE;
end;


function TEmbeddedWB.SaveToStream(AStream: TStream): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(Document) then
Result := SaveDocToStream(Document, AStream)
else Result := S_FALSE;
end;




function SaveDocToStrings(Doc: IDispatch; var AStrings: TStrings): HResult;
var
IpStream: IPersistStreamInit;
AStream: TMemoryStream;
begin
AStream := TMemoryStream.Create;
try
IpStream := doc as IPersistStreamInit;
if not Assigned(IpStream) then Result := S_FALSE else
if Succeeded(IpStream.save(TStreamadapter.Create(AStream), TRUE))
then begin
AStream.Seek(0, 0);
AStrings.LoadFromStream(AStream);
Result := S_OK;
end else Result := S_FALSE;
except
Result := S_FALSE;
end;
AStream.Free;
end;

function TEmbeddedwb.SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT;
var
iw: IWebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then
Result := SaveDocToStream(iw.Document, AStream)
end;



function TEmbeddedwb.SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT;
var
iw: Iwebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then
Result := SaveDocToStrings(iw.Document, AStrings);
end;

function TEmbeddedwb.SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT;
var
Iw: IWebbrowser2;
PFile: IPersistFile;
begin
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then begin
PFile := iw.Document as IPersistFile;
Result := PFile.Save(StringToOleStr(FName), False);
end else Result := S_FALSE;
end;


function SaveDocToFile(Doc: IDispatch; const Fname: string): HResult;
var
PFile: IPersistFile;
begin
PFile := Doc as IPersistFile;
Result := PFile.Save(StringToOleStr(FName), False);
end;


function TEmbeddedWB.SaveToFile(const Fname: string): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(Document) then
begin
Result := SaveDocToFile(Document, FName);
end else Result := S_FALSE;
end;



function TEmbeddedWB.SaveToStrings(AStrings: TStrings): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
Result := SaveDocToStrings(Document, AStrings)
else Result := S_FALSE;
end;

function TEmbeddedWb.LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult;
var
iw: IWebbrowser2;
M: TMemoryStream;
begin
Result := S_FALSE;
iw := GetFrame(Frameno);
if (iw <> nil) and assigned(iw.document) then begin
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
M.seek(0, 0);
Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(M));
except
Result := S_FALSE;
end;
M.free;
end;
end;

function TEmbeddedWb.LoadFromStrings(const AStrings: TStrings): HResult;
var
M: TMemoryStream;
begin
if not Assigned(document) then AssignDocument;
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
Result := LoadFromStream(M);
except
Result := S_FALSE;
end;
M.free;
end;


function TEmbeddedWb.LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT;
var
iw: IWebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) then if Assigned(iw.Document) then
begin
AStream.seek(0, 0);
Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
end;

function TEmbeddedWb.LoadFromStream(const AStream: TStream): HRESULT;
begin
if not Assigned(Document) then AssignDocument;
AStream.seek(0, 0);
Result := (Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;

procedure TEmbeddedWb.AssignDocument;
begin
Go('about:blank');
while readystate <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages;
end;

procedure TEmbeddedWb.SetFocusToDoc;
begin
if Document <> nil then
with {$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IOleobject do
DoVerb(OLEIVERB_UIACTIVATE, nil, Self, 0, Handle, GetClientRect);
end;

{$IFDEF VER120}

procedure TEmbeddedWb.EnableMessagehandler;
begin
if not bMsgHandler then
begin
SaveMessage := Forms.Application.OnMessage;
Forms.Application.OnMessage := IeMessagehandler;
bMsgHandler := True;
end;
end;


procedure TEmbeddedWB.DisableMessageHandler;
begin
if bMsgHandler then
begin
Forms.Application.onMessage := Savemessage;
bMsgHandler := False;
end;
end;
{$ENDIF}


///BEGIN >>>>> Messagehandler by Mathias Walter - walter@coint.de >>>>>///

procedure TEmbeddedWB.WBWndProc(var Message: TMessage);
const
StdKeys = [VK_RETURN, VK_BACK]; { standard keys }
ExtKeys = [VK_LEFT, VK_RIGHT]; { extended keys }
fExtended = $01000000; { extended key flag }
var
bClose: Boolean;
{$IFNDEF VER120}
WinMsg: TMsg;
{$ENDIF}
begin
with Message do
begin
{$IFNDEF VER120}
if (Msg >= (CN_BASE + WM_KEYFIRST)) and (Msg <= (CN_BASE + WM_DEADCHAR)) then
begin
WinMsg.hwnd := Handle;
WinMsg.message := Msg - CN_BASE;
WinMsg.wParam := wParam;
WinMsg.lParam := lParam;
WinMsg.time := GetMessageTime;
WinMsg.pt.x := $115DE1F1;
WinMsg.pt.y := $115DE1F1;
if not ((wParam in StdKeys) or
(wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then
with Application as IOleInPlaceActiveObject do
Result := Integer(TranslateAccelerator(WinMsg) = S_OK);
end
else
{$ENDIF}
case Msg of
WM_CLOSE: begin
bClose := True;
if Assigned(FOnCloseQuery) then
FOnCloseQuery(Self, bClose);
if bClose then
OldWBWndProc(Message);
end;
WM_DDE_EXECUTE: DDEExecute(wparam, lparam);
WM_DDE_TERMINATE: DDETerminate(wparam, lparam);
else
OldWBWndProc(Message);
end;
end;
end;

{$IFDEF VER120}

procedure TEmbeddedWB.IEMessageHandler(var Msg: TMsg; var Handled: Boolean);
{ fixes the malfunction of some keys within webbrowser control }
const
StdKeys = [VK_TAB, VK_RETURN]; { standard keys }
ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys }
fExtended = $01000000; { extended key flag }
begin
Handled := False;
with Msg do
if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and
((wParam in StdKeys) or (GetKeyState(VK_CONTROL) < 0) or
(wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then
try
if IsChild(Handle, hWnd) then
{ handles all browser related messages }
begin
with Application_ as IOleInPlaceActiveObject do
Handled := TranslateAccelerator(Msg) = S_OK;
if not Handled then
begin
Handled := True;
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
except end;
end; // IEMessageHandler
{$ENDIF}

///END <<<<<< Messagehandler by Mathias Walter - walter@coint.de <<<<<///


procedure TEmbeddedWb.NavigateFolder(CSIDL: Integer);
var
sFolder: PITemIdList;
begin
SHGetSpecialFolderLocation(0, CSIDL, SFolder);
NavigatePidl(SFolder);
CoTaskMemFree(SFolder);
end;


procedure TEmbeddedWB.NavigatePidl(pidl: PItemIdList);
var
VaEmpty, vaPidl: Olevariant;
psa: PSafeArray;
cbData: UINT;
begin
cbdata := GetPidlSize(pidl);
psa := SafeArrayCreateVector(VT_UI1, 0, cbData);
if (psa <> nil) then begin
CopyMemory(psa.pvData, pidl, cbData);
VariantInit(vaPidl);
TVariantArg(vaPidl).vt := VT_ARRAY or VT_UI1;
TVariantArg(vaPidl).parray := psa;
Navigate2(vaPidl, vaEmpty, vaEmpty, vaEmpty, vaEmpty);
VariantClear(vaPidl);
end;
end;

procedure TEmbeddedWB.Go(Url: string);
var
_URL, Flags, TargetFrameName, PostData, Headers: Olevariant;
begin
_URL := Url;
Flags := 0; TargetFrameName := 0; Postdata := 0; Headers := 0;
Navigate2(_URL, Flags, TargetFrameName, PostData, Headers);
end;


procedure TEmbeddedWB.InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant);
var
CmdTarget: IOleCommandTarget;
PtrGUID: PGUID;
begin
New(PtrGUID);
if InvokeIE then PtrGUID^ := CLSID_WebBrowser else
PtrGuid := PGUID(nil);
if Document <> nil then
try
Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget <> nil then
try
CmdTarget.Exec(PtrGuid, Value1, Value2, vaIn, vaOut);
finally
CmdTarget._Release;
end;
except end;
Dispose(PtrGUID);
end;


procedure TEmbeddedWB.Print;
var
vaIn, vaOut: Olevariant;
HtmlText: string;
Stream: IStream;
Dummy: Int64;
Psa: PSafeArray;
begin
HtmlText := PrintOptions.HtmlHeader.Text;
CreateStreamOnHGlobal(0, TRUE, Stream);
Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy);
Stream.Seek(0, STREAM_SEEK_SET, Dummy);
SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa);
TVarData(VaIn).VType := varArray or varByRef;
SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray));
InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;

procedure TEmbeddedWB.PrintSetup;
var
vaIn, vaOut: Olevariant;
HtmlText: string;
Stream: IStream;
Dummy: Int64;
Psa: PSafeArray;
begin
HtmlText := PrintOptions.HtmlHeader.Text;
CreateStreamOnHGlobal(0, TRUE, Stream);
Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy);
Stream.Seek(0, STREAM_SEEK_SET, Dummy);
SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa);
TVarData(VaIn).VType := varArray or varByRef;
SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray));
InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut);
end;

procedure TEmbeddedWB.PageSetup(UsePrintOptions: Boolean);
var
vaIn, vaOut: Olevariant;
begin
if UsePrintOptions then InvokingPageSetup := True;
InvokeCmd(FALSE, OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure TEmbeddedWB.OpenDialog;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_OPEN, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure TEmbeddedWB.SaveDialog;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure TEmbeddedWB.ViewSource;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_VIEWSOURCE, 0, vaIn, vaOut);
end;

procedure TEmbeddedWB.Options;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_OPTIONS, 0, vaIn, vaOut);
end;

procedure TEmbeddedWB.Properties;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure TEmbeddedWB.Find;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_FIND, 0, vaIn, vaOut);
end;

procedure TEmbeddedWB.Copy;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;

procedure TEmbeddedWB.SelectAll;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;


procedure TEmbeddedWB.Zoom(ZoomValue: Integer);
var
vaIn, vaOut: Olevariant;
begin
if ZoomValue < ZoomRangeLow then vaIn := ZoomRangeLow else
if ZoomValue > ZoomRangeHigh then vaIn := ZoomRangeHigh else
vaIn := ZoomValue;
InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;

function TEmbeddedWB.ZoomRangeLow: Integer;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := LoWord(Dword(vaOut));
end;

function TEmbeddedWB.ZoomRangeHigh: Integer;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := HiWord(Dword(vaOut));
end;

function TEmbeddedWB.ZoomValue: Integer;
var
vaIn, vaOut: Olevariant;
begin
vaIn := null;
InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := vaOut;
end;

// IDOCHOSTUIHANDLER

function TEmbeddedWB.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT;
begin
if Assigned(FOnShowContextmenu) then RESULT := FOnSHowContextmenu(dwID, ppt,
pcmdtreserved, pdispreserved) else
RESULT := S_FALSE;
end;

function TEmbeddedWB.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
begin
pInfo.cbSize := SizeOf(pInfo);
pInfo.dwFlags := FUserInterfaceValue;
pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT;
if Assigned(FOnGetHostInfo) then
Result := FOnGetHostInfo(pInfo) else
Result := S_OK;
end;

function TEmbeddedWB.ShowUI(const dwID: DWORD;
const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT;
begin
if Assigned(FOnShowUI) then
Result := FOnShowUI(dwID, pActiveObject, pCommandTarget, pFrame, pDoc)
else
Result := S_FALSE;
end;

function TEmbeddedWB.HideUI: HRESULT;
begin
if Assigned(FOnHideUI) then
Result := FOnHideUI else
Result := S_FALSE;
end;

function TEmbeddedWB.UpdateUI: HRESULT;
begin
if Assigned(FOnUpdateUI) then
Result := FOnUpdateUI else
Result := S_FALSE;
end;

function TEmbeddedWB.EnableModeless(const fEnable: BOOL): HRESULT;
begin
if Assigned(FOnEnableModeless) then
Result := FOnEnableModeless(fEnable) else
Result := S_FALSE;
end;

function TEmbeddedWB.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
begin
if Assigned(FOnOnDocWindowActivate) then
Result := FOnOnDocWindowActivate(fActivate) else
Result := S_FALSE;
end;

function TEmbeddedWB.OnFrameWindowActivate(const fActivate: BOOL): HRESULT;
begin
if Assigned(FOnOnFrameWindowActivate) then
Result := FOnOnFrameWindowActivate(fActivate) else
Result := S_FALSE;
end;

function TEmbeddedWB.ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT;
begin
if Assigned(FOnResizeBorder) then
Result := FOnResizeBorder(prcBorder, pUIWindow, fRameWindow) else
Result := S_FALSE;
end;

function TEmbeddedWB.TranslateAccelerator(const lpMsg: PMSG;
const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;
begin
if Assigned(FOnTranslateAccelerator) then
Result := FOnTranslateAccelerator(lpMsg, pguidCmdGroup, nCmdID) else
Result := S_FALSE;
end;

function TEmbeddedWB.GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT;
begin
if Assigned(FOnGetOptionKeyPath) then
Result := FOnGetOptionKeyPath(pchKey, dw) else
Result := S_FALSE;
end;

function TEmbeddedWB.GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT;
begin
if Assigned(FOnGetDropTarget) then
Result := FOnGetDropTarget(pDropTarget, ppDropTarget) else
Result := S_OK;
end;

function TEmbeddedWB.GetExternal(out ppDispatch: IDispatch): HRESULT;
begin
if Assigned(FOnGetExternal) then
Result := FOnGetExternal(ppDispatch) else
Result := S_FALSE;
end;

function TEmbeddedWB.TranslateUrl(const dwTranslate: DWORD;
const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;
begin
if Assigned(FOnTranslateUrl) then
Result := FOnTranslateUrl(dwTranslate, pchUrlIn, ppchUrlOut) else
Result := S_FALSE;
end;

function TEmbeddedWB.FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT;
begin
if Assigned(FOnFilterDataObject) then
Result := FOnFilterDataObject(pDO, ppDORet) else
Result := S_FALSE;
end;



// IDOCHOSTSHOWUI

function TEmbeddedWB.ShowMessage(hwnd: THandle; lpstrText: POLESTR;
lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT;
begin
if Assigned(FOnShowMessage) then
Result := FOnShowMessage(hwnd, lpstrText, lpStrCaption, dwType, lpStrHelpFile, dwHelpContext, plResult) else
Result := S_FALSE;
end;

function TEmbeddedWB.ShowHelp(hwnd: THandle; pszHelpFile: POLESTR;
uCommand: integer; dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT;
begin
Result := S_OK;
if Assigned(FOnShowHelp) then
Result := FOnShowHelp(hwnd, pszHelpFile, uCommand, dwData, ptMouse, pDispatchObjectHit) else
if FHelpFile <> '' then HtmlHelp(hwnd, Pchar(FHelpFile), ucommand, dwData) else
Result := S_FALSE;
end;

// IDISPATCH methods

function TEmbeddedWB.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin

if Assigned(FOnGetIdsofNames) then
Result := FOnGetIdsofNames(IID, Names, NameCount, LocaleID, DispIds) else
result := E_NotImpl;

end;

function TEmbeddedWB.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
if Assigned(FOnGetTypeInfo) then
Result := FOnGetTypeInfo(Index, LocaleID, ITypeInfo(TypeInfo)) else
begin
Result := E_NOTIMPL;
pointer(TypeInfo) := nil;
end;
end;

function TEmbeddedWB.GetTypeInfoCount(out Count: Integer): HResult;
begin
if Assigned(FOnGetTypeInfoCount) then
Result := FOnGetTypeInfoCount(Count) else
begin
Result := E_NOTIMPL;
Count := 0;
end;
end;

function TEmbeddedWB.Invoke(DispID: Integer;
const IID: TGUID;
LocaleID: Integer;
Flags: Word;
var Params;
VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
Result := S_OK;
if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) and
(DispId = DISPID_AMBIENT_DLCONTROL) then
PVariant(VarResult)^ := FDownloadOptionValue
else
if Assigned(FOnInvoke) then
Result := FOnInvoke(DispId, IID, LocaleID, Flags, TagDispParams(Params),
VarResult, ExcepInfo, ArgErr)
else
Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params,
VarResult, ExcepInfo, ArgErr);
end;


procedure Register;
begin
RegisterComponents({$IFDEF VER120} 'ActiveX'{$ELSE} 'Internet'{$ENDIF}, [TEmbeddedWB]);
end;


{ TPrintOptions }

procedure TPrintOptions.SetHTMLHeader(const Value: Tstrings);
begin
FHTMLHeader.Assign(Value);
end;



function DeleteFirstCacheEntry(var H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWord;
begin
Result := S_OK;
H := 0;
D := 0;
FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, nil, @D, nil, nil, nil);
GetMem(T, D);
try
H := FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, T, @D, nil, nil, nil);
if (H = 0) then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;

function DeleteNextCacheEntry(H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWORD;
begin
Result := S_OK;
D := 0;
FindnextUrlCacheEntryEx(H, nil, @D, nil, nil, nil);
GetMem(T, D);
try
if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil)
then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;


procedure TEmbeddedWB.ClearCache;
var
H: THandle;
begin
if DeleteFirstCacheEntry(H) = S_OK then
repeat
until DeleteNextCacheEntry(H) = ERROR_NO_MORE_ITEMS;
FindCloseUrlCache(H)
end;

procedure TEmbeddedWB.ClearHistory;
var
HistoryStg: IUrlHistoryStg2;
begin
HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
HistoryStg.ClearHistory;
end;

function TEmbeddedWB.GetOverrideKeyPath(pchKey: POLESTR;
dw: DWORD): HRESULT;
begin
if Assigned(FOnGetOverrideKeyPath) then RESULT := FOnGetOverrideKeyPath(pchkey, dw) else
Result := S_OK;
end;

{$IFDEF USE_IOLECOMMANDTARGET}
function TEmbeddedWB.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
const vaIn: OleVariant; var vaOut: OleVariant): HResult;
var
FCancel, FContinueScript, FShowDialog: Boolean;
pEventObj: IHTMLEventObj;
function GetProperty(const PropName: WideString): OLEVariant;
var
Dispparams: TDispParams;
Disp, Status: Integer;
ExcepInfo: TExcepInfo;
PPropName: PWideChar;
begin
Dispparams.rgvarg := nil;
Dispparams.rgdispidNamedArgs := nil;
Dispparams.cArgs := 0;
Dispparams.cNamedArgs := 0;
PPropName := PWideChar(PropName);
Status := pEventObj.GetIDsOfNames(GUID_NULL, @PPropname, 1,
LOCALE_SYSTEM_DEFAULT, @Disp);
if Status = 0 then
begin
Status := pEventObj.Invoke(disp, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET,
Dispparams, @Result, @ExcepInfo, nil);
if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
end else
if Status = DISP_E_UNKNOWNNAME then
raise EOleError.CreateFmt('''%s'' not supported.', [PropName])
else
OleCheck(Status);
end;
begin
if (CmdGroup = nil) then
begin
Result := OLECMDERR_E_UNKNOWNGROUP;
Exit;
end;

Result := OLECMDERR_E_NOTSUPPORTED;
if (ncmdID = OLECMDID_ONUNLOAD) and IsEqualGuid(cmdGroup^, CGID_EXPLORER) and
Assigned(FOnUnload) then FOnUnload(Self);

if IsEqualGuid(cmdGroup^, CGID_DocHostCommandHandler) then
begin
if Assigned(FOnRefresh) and ((nCmdID = 6041 {F5}) or (nCmdID = 6042 {ContextMenu}) or (nCmdID = 2300)) then
begin
FCancel := False;
FOnRefresh(self, nCmdID, FCancel);
if FCancel then Result := S_OK;
end else
case nCmdID of
OLECMDID_SHOWSCRIPTERROR:
if Assigned(FOnScriptError)
then begin
pEventObj := (Document as IHTMLDocument2).parentWindow.event;
if pEventObj <> nil then
begin
FContinueScript := True;
FShowDialog := True;
FOnScriptError(self,
GetProperty('errorline'),
GetProperty('errorCharacter'),
GetProperty('errorCode'),
GetProperty('errorMessage'),
GetProperty('errorUrl'),
FContinueScript, FShowDialog);
TVariantArg(vaOut).vt := VT_BOOL;
TVariantArg(vaOut).vbool := FContinueScript;
if not FShowDialog then Result := S_OK;
end;
end;
end;
end;
end;

function TEmbeddedWB.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
prgCmds: POleCmd; CmdText: POleCmdText): HResult;
begin
result := S_OK;
end;
{$ENDIF}

initialization
Saved8087CW := Default8087CW;
{$IFDEF VER120}
bMsgHandler := False;
{$ENDIF}
OleInitialize(nil);
finalization
Set8087CW(Saved8087CW);
try
OleUninitialize;
except end;
end.

(*******************************
* IECONST 1.4 (Oct 16, 2001) *
*******************************)

unit IeConst;

interface

uses Sysutils, ShlObj, Activex, Windows, Urlmon;


const



STATURL_QUERYFLAG_ISCACHED = $00010000;
STATURL_QUERYFLAG_NOURL = $00020000;
STATURL_QUERYFLAG_NOTITLE = $00040000;
STATURL_QUERYFLAG_TOPLEVEL = $00080000;

STATURLFLAG_ISCACHED = $00000001;
STATURLFLAG_ISTOPLEVEL = $00000002;



IID_IDownloadManager: TGUID =
(D1: $988934A4; D2: $064B; D3: $11D3; D4: ($BB, $80, $0, $10, $4B, $35, $E7, $F9));

SID_SDownloadManager = '{988934A4-064B-11D3-BB80-00104B35E7F9}';


IID_IEnumStatUrl: TGUID = (D1: $3C374A42; D2: $BAE4; D3: $11CF; D4: ($BF, $7D, $00, $AA, $00, $69, $46, $EE));
IID_IUrlHistoryStg: TGUID = (D1: $3C374A41; D2: $BAE4; D3: $11CF; D4: ($BF, $7D, $00, $AA, $00, $69, $46, $EE));
IID_IUrlHistoryStg2: TGUID = (D1: $AFA0DC11; D2: $C313; D3: $831A; D4: ($83, $1A, $00, $C0, $4F, $D5, $AE, $38));
IID_IUrlHistoryNotify: TGUID = (D1: $BC40BEC1; D2: $C493; D3: $11D0; D4: ($83, $1B, $00, $C0, $4F, $D5, $AE, $38));

SID_IEnumStatUrl = '{3C374A42-BAE4-11CF-BF7D-00AA006946EE}';
SID_IUrlHistoryStg = '{3C374A41-BAE4-11CF-BF7D-00AA006946EE}';
SID_IUrlHistoryStg2 = '{AFA0DC11-C313-11d0-831A-00C04FD5AE38}';
SID_IURLHistoryNotify = '{BC40BEC1-C493-11d0-831B-00C04FD5AE38}';
CLSID_CUrlHistory: TGUID = '{3C374A40-BAE4-11CF-BF7D-00AA006946EE}';


IID_IDocHostUIHandler: TGUID = '{bd3f23c0-d43e-11cf-893b-00aa00bdce1a}';
IID_IDocHostUIHandler2: TGUID = '{3050f6d0-98b5-11cf-bb82-00aa00bdce0b}';
IID_IDocHostShowUI: TGUID = '{c4d244b0-d43e-11cf-893b-00aa00bdce1a}';
GUID_TriEditCommandGroup: TGUID = '{2582F1C0-084E-11d1-9A0E-006097C9B344}';
CMDSETID_Forms3: TGUID = '{DE4BA900-59CA-11CF-9592-444553540000}';

IID_IQueryInfo: TGUID = (D1: $00021500; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
CGID_DocHostCommandHandler: TGUID = (D1: $F38BC242; D2: $B950; D3: $11D1; D4: ($89, $18, $00, $C0, $4F, $C2, $C8, $36));



MSOCMDF_SUPPORTED = OLECMDF_SUPPORTED;
MSOCMDF_ENABLED = OLECMDF_ENABLED;

MSOCMDEXECOPT_PROMPTUSER = OLECMDEXECOPT_PROMPTUSER;
MSOCMDEXECOPT_DONTPROMPTUSER = OLECMDEXECOPT_DONTPROMPTUSER;

InchToMetric = 25.4;

NO_COMMAND = 0;
VIEW_COMMAND = 1;
EXPLORE_COMMAND = 2;
FIND_COMMAND = 3;

ISDigit = ['0'..'9', '-', '+'];

CONTEXT_MENU_DEFAULT = 0;
CONTEXT_MENU_IMAGE = 1;
CONTEXT_MENU_CONTROL = 2;
CONTEXT_MENU_TABLE = 3;
// in browse mode
CONTEXT_MENU_TEXTSELECT = 4;
CONTEXT_MENU_ANCHOR = 5;
CONTEXT_MENU_UNKNOWN = 6;
// These 2 are mapped to IMAGE for the public")
CONTEXT_MENU_IMGDYNSRC = 7;
CONTEXT_MENU_IMGART = 8;
CONTEXT_MENU_DEBUG = 9;
CONTEXT_MENU_VSCROLL = 10;
CONTEXT_MENU_HSCROLL = 11;

DISPID_AMBIENT_DLCONTROL = (-5512);
DISPID_AMBIENT_USERAGENT = (-5513);

HTMLID_FIND = 1;
HTMLID_VIEWSOURCE = 2;
HTMLID_OPTIONS = 3;

DOCHOSTUITYPE_BROWSE = 0;
DOCHOSTUITYPE_AUTHOR = 1;

DOCHOSTUIDBLCLK_DEFAULT = 0;
DOCHOSTUIDBLCLK_SHOWPROPERTIES = 1;
DOCHOSTUIDBLCLK_SHOWCODE = 2;

DOCHOSTUIFLAG_DIALOG = $0001;
DOCHOSTUIFLAG_DISABLE_HELP_MENU = $0002;
DOCHOSTUIFLAG_NO3DBORDER = $0004;
DOCHOSTUIFLAG_SCROLL_NO = $0008;
DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = $0010;
DOCHOSTUIFLAG_OPENNEWWIN = $0020;
DOCHOSTUIFLAG_DISABLE_OFFSCREEN = $0040;
DOCHOSTUIFLAG_FLAT_SCROLLBAR = $0080;
DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = $0100;
DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = $0200;
DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY = $0400;
DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = $0800;
DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = $1000;
DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = $2000;
DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = $4000;
DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION = $10000;
DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION = $20000;

IDM_UNKNOWN = 0;
IDM_ALIGNBOTTOM = 1;
IDM_ALIGNHORIZONTALCENTERS = 2;
IDM_ALIGNLEFT = 3;
IDM_ALIGNRIGHT = 4;
IDM_ALIGNTOGRID = 5;
IDM_ALIGNTOP = 6;
IDM_ALIGNVERTICALCENTERS = 7;
IDM_ARRANGEBOTTOM = 8;
IDM_ARRANGERIGHT = 9;
IDM_BRINGFORWARD = 10;
IDM_BRINGTOFRONT = 11;
IDM_CENTERHORIZONTALLY = 12;
IDM_CENTERVERTICALLY = 13;
IDM_CODE = 14;
IDM_DELETE = 17;
IDM_FONTNAME = 18;
IDM_FONTSIZE = 19;
IDM_GROUP = 20;
IDM_HORIZSPACECONCATENATE = 21;
IDM_HORIZSPACEDECREASE = 22;
IDM_HORIZSPACEINCREASE = 23;
IDM_HORIZSPACEMAKEEQUAL = 24;
IDM_INSERTOBJECT = 25;
IDM_MULTILEVELREDO = 30;
IDM_SENDBACKWARD = 32;
IDM_SENDTOBACK = 33;
IDM_SHOWTABLE = 34;
IDM_SIZETOCONTROL = 35;
IDM_SIZETOCONTROLHEIGHT = 36;
IDM_SIZETOCONTROLWIDTH = 37;
IDM_SIZETOFIT = 38;
IDM_SIZETOGRID = 39;
IDM_SNAPTOGRID = 40;
IDM_TABORDER = 41;
IDM_TOOLBOX = 42;
IDM_MULTILEVELUNDO = 44;
IDM_UNGROUP = 45;
IDM_VERTSPACECONCATENATE = 46;
IDM_VERTSPACEDECREASE = 47;
IDM_VERTSPACEINCREASE = 48;
IDM_VERTSPACEMAKEEQUAL = 49;
IDM_JUSTIFYFULL = 50;
IDM_BACKCOLOR = 51;
IDM_BOLD = 52;
IDM_BORDERCOLOR = 53;
IDM_FLAT = 54;
IDM_FORECOLOR = 55;
IDM_ITALIC = 56;
IDM_JUSTIFYCENTER = 57;
IDM_JUSTIFYGENERAL = 58;
IDM_JUSTIFYLEFT = 59;
IDM_JUSTIFYRIGHT = 60;
IDM_RAISED = 61;
IDM_SUNKEN = 62;
IDM_UNDERLINE = 63;
IDM_CHISELED = 64;
IDM_ETCHED = 65;
IDM_SHADOWED = 66;
IDM_FIND = 67;
IDM_SHOWGRID = 69;
IDM_OBJECTVERBLIST0 = 72;
IDM_OBJECTVERBLIST1 = 73;
IDM_OBJECTVERBLIST2 = 74;
IDM_OBJECTVERBLIST3 = 75;
IDM_OBJECTVERBLIST4 = 76;
IDM_OBJECTVERBLIST5 = 77;
IDM_OBJECTVERBLIST6 = 78;
IDM_OBJECTVERBLIST7 = 79;
IDM_OBJECTVERBLIST8 = 80;
IDM_OBJECTVERBLIST9 = 81;
IDM_CONVERTOBJECT = 82;
IDM_CUSTOMCONTROL = 83;
IDM_CUSTOMIZEITEM = 84;
IDM_RENAME = 85;
IDM_IMPORT = 86;
IDM_NEWPAGE = 87;
IDM_MOVE = 88;
IDM_CANCEL = 89;
IDM_FONT = 90;
IDM_STRIKETHROUGH = 91;
IDM_DELETEWORD = 92;

IDM_FOLLOW_ANCHOR = 2008;

IDM_INSINPUTIMAGE = 2114;
IDM_INSINPUTBUTTON = 2115;
IDM_INSINPUTRESET = 2116;
IDM_INSINPUTSUBMIT = 2117;
IDM_INSINPUTUPLOAD = 2118;
IDM_INSFIELDSET = 2119;

IDM_PASTEINSERT = 2120;
IDM_REPLACE = 2121;
IDM_EDITSOURCE = 2122;
IDM_BOOKMARK = 2123;
IDM_HYPERLINK = 2124;
IDM_UNLINK = 2125;
IDM_BROWSEMODE = 2126;
IDM_EDITMODE = 2127;
IDM_UNBOOKMARK = 2128;

IDM_TOOLBARS = 2130;
IDM_STATUSBAR = 2131;
IDM_FORMATMARK = 2132;
IDM_TEXTONLY = 2133;
IDM_OPTIONS = 2135;
IDM_FOLLOWLINKC = 2136;
IDM_FOLLOWLINKN = 2137;
IDM_VIEWSOURCE = 2139;
IDM_ZOOMPOPUP = 2140;

// IDM_BASELINEFONT1, IDM_BASELINEFONT2, IDM_BASELINEFONT3, IDM_BASELINEFONT4,
// and IDM_BASELINEFONT5 should be consecutive integers;
//
IDM_BASELINEFONT1 = 2141;
IDM_BASELINEFONT2 = 2142;
IDM_BASELINEFONT3 = 2143;
IDM_BASELINEFONT4 = 2144;
IDM_BASELINEFONT5 = 2145;

IDM_HORIZONTALLINE = 2150;
IDM_LINEBREAKNORMAL = 2151;
IDM_LINEBREAKLEFT = 2152;
IDM_LINEBREAKRIGHT = 2153;
IDM_LINEBREAKBOTH = 2154;
IDM_NONBREAK = 2155;
IDM_SPECIALCHAR = 2156;
IDM_HTMLSOURCE = 2157;
IDM_IFRAME = 2158;
IDM_HTMLCONTAIN = 2159;
IDM_TEXTBOX = 2161;
IDM_TEXTAREA = 2162;
IDM_CHECKBOX = 2163;
IDM_RADIOBUTTON = 2164;
IDM_DROPDOWNBOX = 2165;
IDM_LISTBOX = 2166;
IDM_BUTTON = 2167;
IDM_IMAGE = 2168;
IDM_OBJECT = 2169;
IDM_1D = 2170;
IDM_IMAGEMAP = 2171;
IDM_FILE = 2172;
IDM_COMMENT = 2173;
IDM_SCRIPT = 2174;
IDM_JAVAAPPLET = 2175;
IDM_PLUGIN = 2176;
IDM_PAGEBREAK = 2177;

IDM_PARAGRAPH = 2180;
IDM_FORM = 2181;
IDM_MARQUEE = 2182;
IDM_LIST = 2183;
IDM_ORDERLIST = 2184;
IDM_UNORDERLIST = 2185;
IDM_INDENT = 2186;
IDM_OUTDENT = 2187;
IDM_PREFORMATTED = 2188;
IDM_ADDRESS = 2189;
IDM_BLINK = 2190;
IDM_DIV = 2191;

IDM_TABLEINSERT = 2200;
IDM_RCINSERT = 2201;
IDM_CELLINSERT = 2202;
IDM_CAPTIONINSERT = 2203;
IDM_CELLMERGE = 2204;
IDM_CELLSPLIT = 2205;
IDM_CELLSELECT = 2206;
IDM_ROWSELECT = 2207;
IDM_COLUMNSELECT = 2208;
IDM_TABLESELECT = 2209;
IDM_TABLEPROPERTIES = 2210;
IDM_CELLPROPERTIES = 2211;
IDM_ROWINSERT = 2212;
IDM_COLUMNINSERT = 2213;

IDM_HELP_CONTENT = 2220;
IDM_HELP_ABOUT = 2221;
IDM_HELP_README = 2222;

IDM_REMOVEFORMAT = 2230;
IDM_PAGEINFO = 2231;
IDM_TELETYPE = 2232;
IDM_GETBLOCKFMTS = 2233;
IDM_BLOCKFMT = 2234;
IDM_SHOWHIDE_CODE = 2235;
IDM_TABLE = 2236;

IDM_COPYFORMAT = 2237;
IDM_PASTEFORMAT = 2238;
IDM_GOTO = 2239;

IDM_CHANGEFONT = 2240;
IDM_CHANGEFONTSIZE = 2241;
IDM_INCFONTSIZE = 2242;
IDM_DECFONTSIZE = 2243;
IDM_INCFONTSIZE1PT = 2244;
IDM_DECFONTSIZE1PT = 2245;
IDM_CHANGECASE = 2246;
IDM_SUBSCRIPT = 2247;
IDM_SUPERSCRIPT = 2248;
IDM_SHOWSPECIALCHAR = 2249;

IDM_CENTERALIGNPARA = 2250;
IDM_LEFTALIGNPARA = 2251;
IDM_RIGHTALIGNPARA = 2252;
IDM_REMOVEPARAFORMAT = 2253;
IDM_APPLYNORMAL = 2254;
IDM_APPLYHEADING1 = 2255;
IDM_APPLYHEADING2 = 2256;
IDM_APPLYHEADING3 = 2257;

IDM_DOCPROPERTIES = 2260;
IDM_ADDFAVORITES = 2261;
IDM_COPYSHORTCUT = 2262;
IDM_SAVEBACKGROUND = 2263;
IDM_SETWALLPAPER = 2264;
IDM_COPYBACKGROUND = 2265;
IDM_CREATESHORTCUT = 2266;
IDM_PAGE = 2267;
IDM_SAVETARGET = 2268;
IDM_SHOWPICTURE = 2269;
IDM_SAVEPICTURE = 2270;
IDM_DYNSRCPLAY = 2271;
IDM_DYNSRCSTOP = 2272;
IDM_PRINTTARGET = 2273;
IDM_IMGARTPLAY = 2274;
IDM_IMGARTSTOP = 2275;
IDM_IMGARTREWIND = 2276;
IDM_PRINTQUERYJOBSPENDING = 2277;

IDM_CONTEXTMENU = 2280;
IDM_GOBACKWARD = 2282;
IDM_GOFORWARD = 2283;
IDM_PRESTOP = 2284;

IDM_CREATELINK = 2290;
IDM_COPYCONTENT = 2291;

IDM_LANGUAGE = 2292;

IDM_REFRESH = 2300;
IDM_STOPDOWNLOAD = 2301;

IDM_ENABLE_INTERACTION = 2302;

IDM_LAUNCHDEBUGGER = 2310;
IDM_BREAKATNEXT = 2311;

IDM_INSINPUTHIDDEN = 2312;
IDM_INSINPUTPASSWORD = 2313;

IDM_OVERWRITE = 2314;

IDM_PARSECOMPLETE = 2315;

IDM_HTMLEDITMODE = 2316;

IDM_REGISTRYREFRESH = 2317;
IDM_COMPOSESETTINGS = 2318;

IDM_SHOWALLTAGS = 2320;
IDM_SHOWALIGNEDSITETAGS = 2321;
IDM_SHOWSCRIPTTAGS = 2322;
IDM_SHOWSTYLETAGS = 2323;
IDM_SHOWCOMMENTTAGS = 2324;
IDM_SHOWAREATAGS = 2325;
IDM_SHOWUNKNOWNTAGS = 2326;
IDM_SHOWMISCTAGS = 2327;
IDM_SHOWZEROBORDERATDESIGNTIME = 2328;

IDM_AUTODETECT = 2329;

IDM_SCRIPTDEBUGGER = 2330;

IDM_GETBYTESDOWNLOADED = 2331;

IDM_NOACTIVATENORMALOLECONTROLS = 2332;
IDM_NOACTIVATEDESIGNTIMECONTROLS = 2333;
IDM_NOACTIVATEJAVAAPPLETS = 2334;

IDM_SHOWWBRTAGS = 2340;

IDM_PERSISTSTREAMSYNC = 2341;
IDM_SETDIRTY = 2342;


IDM_MIMECSET__FIRST__ = 3609;
IDM_MIMECSET__LAST__ = 3640;

IDM_MENUEXT_FIRST__ = 3700;
IDM_MENUEXT_LAST__ = 3732;
IDM_MENUEXT_COUNT = 3733;

ID_EDITMODE = 32801;

IDM_OPEN = 2000;
IDM_NEW = 2001;
IDM_SAVE = 70;
IDM_SAVEAS = 71;
IDM_SAVECOPYAS = 2002;
IDM_PRINTPREVIEW = 2003;
IDM_PRINT = 27;
IDM_PAGESETUP = 2004;
IDM_SPELL = 2005;
IDM_PASTESPECIAL = 2006;
IDM_CLEARSELECTION = 2007;
IDM_PROPERTIES = 28;
IDM_REDO = 29;
IDM_UNDO = 43;
IDM_SELECTALL = 31;
IDM_ZOOMPERCENT = 50;
IDM_GETZOOM = 68;
IDM_STOP = 2138;
IDM_COPY = 15;
IDM_CUT = 16;
IDM_PASTE = 26;

IDM_TRIED_IS_1D_ELEMENT = 0; //[out,VT_BOOL]
IDM_TRIED_IS_2D_ELEMENT = 1; //[out,VT_BOOL]
IDM_TRIED_NUDGE_ELEMENT = 2; //[in,VT_BYREF VARIANT.byref=LPPOINT]
IDM_TRIED_SET_ALIGNMENT = 3; //[in,VT_BYREF VARIANT.byref=LPPOINT]
IDM_TRIED_MAKE_ABSOLUTE = 4;
IDM_TRIED_LOCK_ELEMENT = 5;
IDM_TRIED_SEND_TO_BACK = 6;
IDM_TRIED_SEND_TO_FRONT = 7;
IDM_TRIED_SEND_BACKWARD = 8;
IDM_TRIED_SEND_FORWARD = 9;
IDM_TRIED_SEND_BEHIND_1D = 10;
IDM_TRIED_SEND_FRONT_1D = 11;
IDM_TRIED_CONSTRAIN = 12; //[in,VT_BOOL]
IDM_TRIED_SET_2D_DROP_MODE = 13; //[in,VT_BOOL]
IDM_TRIED_INSERTROW = 14;
IDM_TRIED_INSERTCOL = 15;
IDM_TRIED_DELETEROWS = 16;
IDM_TRIED_DELETECOLS = 17;
IDM_TRIED_MERGECELLS = 18;
IDM_TRIED_SPLITCELL = 19;
IDM_TRIED_INSERTCELL = 20;
IDM_TRIED_DELETECELLS = 21;
IDM_TRIED_INSERTTABLE = 22; //[in, VT_ARRAY]

//WARNING WARNING WARNING!!! Don't forget to modify IDM_TRIED_LAST_CID
//when you add new Command IDs

IDM_TRIED_LAST_CID = IDM_TRIED_INSERTTABLE;




CLSID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';

type

STATURL = record
cbSize: DWORD;
pwcsUrl: DWORD;
pwcsTitle: DWORD;
ftLastVisited: FILETIME;
ftLastUpdated: FILETIME;
ftExpires: FILETIME;
dwFlags: DWORD;
end;


IDownloadManager = interface(IUnknown)
['{988934A4-064B-11D3-BB80-00104B35E7F9}']
function Download(
pmk: IMoniker; // Identifies the object to be downloaded
pbc: IBindCtx; // Stores information used by the moniker to bind
dwBindVerb: DWORD; // The action to be performed during the bind
grfBINDF: DWORD; // Determines the use of URL encoding during the bind
pBindInfo: PBindInfo; // Used to implement IBindStatusCallback::GetBindInfo
pszHeaders: PWidechar; // Additional headers to use with IHttpNegotiate
pszRedir: PWidechar; // The URL that the moniker is redirected to
uiCP: UINT // The code page of the object's display name
): HRESULT; stdcall;
end;



IEnumSTATURL = interface(IUnknown)
['{3C374A42-BAE4-11CF-BF7D-00AA006946EE}']
function Next(celt: Integer; out elt; pceltFetched: PLongint): HRESULT; stdcall;
function Skip(celt: Longint): HRESULT; stdcall;
function Reset: HResult; stdcall;
function Clone(out ppenum: IEnumSTATURL): HResult; stdcall;
function SetFilter(poszFilter: PWideChar; dwFlags: DWORD): HResult; stdcall;
end;

IUrlHistoryStg = interface(IUnknown)
['{3C374A41-BAE4-11CF-BF7D-00AA006946EE}']
function AddUrl(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer): HResult; stdcall;
function DeleteUrl(pocsUrl: PWideChar; dwFlags: Integer): HResult; stdcall;
function QueryUrl(pocsUrl: PWideChar; dwFlags: Integer; var lpSTATURL: STATURL): HResult; stdcall;
function BindToObject(pocsUrl: PWideChar; var riid: TIID; out ppvOut: Pointer): HResult; stdcall;
function EnumUrls(out ppenum: IEnumSTATURL): HResult; stdcall;
end;

IUrlHistoryStg2 = interface(IUrlHistoryStg)
['{AFA0DC11-C313-11D0-831A-00C04FD5AE38}']
function AddUrlAndNotify(pocsUrl: PWideChar; pocsTitle: PWideChar; dwFlags: Integer;
fWriteHistory: Integer; var poctNotify: Pointer;
const punkISFolder: IUnknown): HResult; stdcall;
function ClearHistory: HResult; stdcall;
end;

IUrlHistoryNotify = interface(IOleCommandTarget)
['{BC40BEC1-C493-11d0-831B-00C04FD5AE38}']
end;

PDOCHOSTUIINFO = ^TDOCHOSTUIINFO;
TDOCHOSTUIINFO = record
cbSize: ULONG;
dwFlags: DWORD;
dwDoubleClick: DWORD;
chHostCss: POLESTR;
chHostNS: POLESTR;
end;


IDocHostShowUI = interface(IUnknown)
['{c4d244b0-d43e-11cf-893b-00aa00bdce1a}']
function ShowMessage(hwnd: THandle; lpstrText: POLESTR; lpstrCaption: POLESTR;
dwType: longint; lpstrHelpFile: POLESTR; dwHelpContext: longint;
var plResult: LRESULT): HRESULT; stdcall;
function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;
dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT; stdcall;
end; // IDocHostShowUI


IDocHostUIHandler = interface(IUnknown)
['{bd3f23c0-d43e-11cf-893b-00aa00bdce1a}']
function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; stdcall;
function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
function HideUI: HRESULT; stdcall;
function UpdateUI: HRESULT; stdcall;
function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow;
const fRameWindow: BOOL): HRESULT; stdcall;
function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
const nCmdID: DWORD): HRESULT; stdcall;
function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall;
function GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT; stdcall;
function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
var ppchURLOut: POLESTR): HRESULT; stdcall;
function FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT; stdcall;
end; // IDocHostUIHandler


IDocHostUIHandler2 = interface(IDocHostUIHandler)
['{3050f6d0-98b5-11cf-bb82-00aa00bdce0b}']
function GetOverrideKeyPath(pchKey: POLESTR; dw: DWORD): HRESULT; stdcall;
end;

const
IID_IUniformResourceLocatorA: TGUID = (
D1: $FBF23B80; D2: $E3F0; D3: $101B; D4: ($84, $88, $00, $AA, $00, $3E, $56, $F8));

IID_IUniformResourceLocatorW: TGUID = (
D1: $CABB0DA0; D2: $DA57; D3: $11CF; D4: ($99, $74, $00, $20, $AF, $D7, $97, $62));


{$IFDEF UNICODE}
IID_IUniformResourceLocator: TGUID = (
D1: $CABB0DA0; D2: $DA57; D3: $11CF; D4: ($99, $74, $00, $20, $AF, $D7, $97, $62));
{$ELSE}
IID_IUniformResourceLocator: TGUID = (
D1: $FBF23B80; D2: $E3F0; D3: $101B; D4: ($84, $88, $00, $AA, $00, $3E, $56, $F8));
{$ENDIF}


const
CLSID_InternetShortCut: TGUID = (
d1: $FBF23B40; D2: $E3F0; D3: $101B; D4: ($84, $88, $00, $AA, $00, $3E, $56, $F8));

SID_IUniformResourceLocatorA = '{FBF23B80-E3F0-101B-8488-00AA003E56F8}';
SID_IUniformResourceLocatorW = '{CABB0DA0-DA57-11CF-9974-0020AFD79762}';
{$IFDEF UNICODE}
SID_IUniformResourceLocator = SID_IUniformResourceLocatorW;
{$ELSE}
SID_IUniformResourceLocator = SID_IUniformResourceLocatorA;
{$ENDIF}



IURL_SETURL_FL_GUESS_PROTOCOL = $0001; // Guess protocol if missing
IURL_SETURL_FL_USE_DEFAULT_PROTOCOL = $0002; // Use default protocol if missing

IURL_INVOKECOMMAND_FL_ALLOW_UI = $0001;
IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB = $0002; // Ignore pcszVerb
IURL_INVOKECOMMAND_FL_DDEWAIT = $0004; // pass DDEWAIT to ShellExec

TRANSLATEURL_FL_GUESS_PROTOCOL = $0001; // Guess protocol if missing
TRANSLATEURL_FL_USE_DEFAULT_PROTOCOL = $0002; // Use default protocol if missing

URLASSOCDLG_FL_USE_DEFAULT_NAME = $0001;
URLASSOCDLG_FL_REGISTER_ASSOC = $0002;

MIMEASSOCDLG_FL_REGISTER_ASSOC = $0001;

type

PUrlInvokeCommandInfoA = ^TUrlInvokeCommandInfoA;

TUrlInvokeCommandInfoA = record
dwcbSize: DWORD; // Size of structure
dwFlags: DWORD; // Bit field of IURL_INVOKECOMMAND_FLAGS
hwndParent: HWND; // Parent window. Valid only if IURL_INVOKECOMMAND_FL_ALLOW_UI is set.
pcszVerb: LPCSTR; // Verb to invoke. Ignored if IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB is set.
end;



PUrlInvokeCommandInfoW = ^TUrlInvokeCommandInfoW;
TUrlInvokeCommandInfoW = record
dwcbSize: DWORD; // Size of structure
dwFlags: DWORD; // Bit field of IURL_INVOKECOMMAND_FLAGS
hwndParent: HWND; // Parent window. Valid only if IURL_INVOKECOMMAND_FL_ALLOW_UI is set.
pcszVerb: LPCWSTR; // Verb to invoke. Ignored if IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB is set.
end;

{$IFDEF UNICODE}
PURLInvokeCommandInfo = ^TUrlInvokeCommandInfoW;
TUrlInvokeCommandInfo = TUrlInvokeCOmmandInfoW;
{$ELSE}
PURLInvokeCommandInfo = ^TUrlInvokeCommandInfoA;
TUrlInvokeCommandInfo = TUrlInvokeCOmmandInfoA;
{$ENDIF}




IUniformResourceLocatorA = interface(IUnknown)
[SID_IUniformResourceLocatorA]
function SetURL(pcszURL: LpcStr; dwInFlags: DWORD): HRESULT; stdcall;
function GetURL(ppszURL: LpStr): HRESULT; stdcall;
function InvokeCommand(purlici: PURLINVOKECOMMANDINFOA): HRESULT; stdcall;

end;



IUniformResourceLocatorW = interface(IUnknown)
[SID_IUniformResourceLocatorW]
function SetURL(pcszURL: LpcWStr; dwInFlags: DWORD): HRESULT; stdcall;
function GetURL(ppszURL: LpWStr): HRESULT; stdcall;
function InvokeCommand(purlici: PURLINVOKECOMMANDINFOW): HRESULT; stdcall;
end;


{$IFDEF UNICODE}
IUniformResourceLocator = IUniformResourceLocatorW;
{$ELSE}
IUniformResourceLocator = IUniformResourceLocatorA;
{$ENDIF}

function TranslateURLA(pcszURL: LPCSTR;
dwInFlags: DWORD;
ppszTranslatedURL: LPSTR): HRESULT; stdcall;


function TranslateURLW(pcszURL: LPCWSTR;
dwInFlags: DWORD;
ppszTranslatedURL: LPWSTR): HRESULT; stdcall;

{$IFDEF UNICODE}
function TranslateURL(pcszURL: LPCWSTR;
dwInFlags: DWORD;
ppszTranslatedURL: LPWSTR): HRESULT; stdcall;
{$ELSE}
function TranslateURL(pcszURL: LPCSTR;
dwInFlags: DWORD;
ppszTranslatedURL: LPSTR): HRESULT; stdcall;
{$ENDIF}


function URLAssociationDialogA(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCSTR;
pcszURL: LPCSTR;
pszAppBuf: LPSTR;
ucAppBufLen: UINT): HRESULT; stdcall;

function URLAssociationDialogW(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCWSTR;
pcszURL: LPCWSTR;
pszAppBuf: LPWSTR;
ucAppBufLen: UINT): HRESULT; stdcall;

{$IFDEF UNICODE}
function URLAssociationDialog(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCWSTR;
pcszURL: LPCWSTR;
pszAppBuf: LPWSTR;
ucAppBufLen: UINT): HRESULT; stdcall;
{$ELSE}
function URLAssociationDialog(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCSTR;
pcszURL: LPCSTR;
pszAppBuf: LPSTR;
ucAppBufLen: UINT): HRESULT; stdcall;
{$ENDIF}



function MIMEAssociationDialogA(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCSTR;
pcszMIMEContentType: LPCSTR;
pszAppBuf: LPSTR;
ucAppBufLen: UINT): HRESULT; stdcall;


function MIMEAssociationDialogW(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCWSTR;
pcszMIMEContentType: LPCWSTR;
pszAppBuf: LPWSTR;
ucAppBufLen: UINT): HRESULT; stdcall;

{$IFDEF UNICODE}
function MIMEAssociationDialog(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCWSTR;
pcszMIMEContentType: LPCWSTR;
pszAppBuf: LPWSTR;
ucAppBufLen: UINT): HRESULT; stdcall;
{$ELSE}
function MIMEAssociationDialog(hwndParent: HWND;
dwInFlags: DWORD;
pcszFile: LPCSTR;
pcszMIMEContentType: LPCSTR;
pszAppBuf: LPSTR;
ucAppBufLen: UINT): HRESULT; stdcall;
{$ENDIF}

function InetIsOffline(dwFlags: DWORD): BOOL; stdcall;


{$IFDEF VER120}

const
IID_IInternetSession: TGUID = '{79eac9e7-baf9-11ce-8c82-00aa004ba90b}';
IID_IInternetSecurityMgrSite: TGUID = '{79eac9ed-baf9-11ce-8c82-00aa004ba90b}';
IID_IInternetSecurityManager: TGUID = '{79eac9ee-baf9-11ce-8c82-00aa004ba90b}';
IID_IInternetHostSecurityManager: TGUID = '{3af280b6-cb3f-11d0-891e-00c04fb6bfc4}';
SID_IInternetSecurityManager: TGUID = '{79eac9ee-baf9-11ce-8c82-00aa004ba90b}';
SID_IInternetHostSecurityManager: TGUID = '{3af280b6-cb3f-11d0-891e-00c04fb6bfc4}';
IID_IInternetZoneManager: TGUID = '{79eac9ef-baf9-11ce-8c82-00aa004ba90b}';


type
TUrlZoneReg = ULONG;

PBindInfo = ^TBindInfo;
_tagBINDINFO = packed record
cbSize: ULONG;
szExtraInfo: LPWSTR;
stgmedData: TStgMedium;
grfBindInfoF: DWORD;
dwBindVerb: DWORD;
szCustomVerb: LPWSTR;
cbstgmedData: DWORD;
dwOptions: DWORD;
dwOptionsFlags: DWORD;
dwCodePage: DWORD;
securityAttributes: TSecurityAttributes;
iid: TGUID;
pUnk: IUnknown;
dwReserved: DWORD;
end;
TBindInfo = _tagBINDINFO;
BINDINFO = _tagBINDINFO;


{$NODEFINE POLEStrArray}
POLEStrArray = ^TOLESTRArray;
{$NODEFINE TOLEStrArray}
TOLEStrArray = array[0..MaxLongint div SizeOf(POLEStr) - 1] of POLEStr;

{$EXTERNALSYM IInternetBindInfo}
IInternetBindInfo = interface
['{79eac9e1-baf9-11ce-8c82-00aa004ba90b}']
function GetBindInfo(out grfBINDF: DWORD; var bindinfo: TBindInfo): HResult; stdcall;
function GetBindString(ulStringType: ULONG; wzStr: POLEStrArray; cEl: ULONG;
var cElFetched: ULONG): HResult; stdcall;
end;

PProtocolData = ^TProtocolData;
{$EXTERNALSYM _tagPROTOCOLDATA}
_tagPROTOCOLDATA = packed record
grfFlags: DWORD;
dwState: DWORD;
pData: Pointer;
cbData: ULONG;
end;
TProtocolData = _tagPROTOCOLDATA;
{$EXTERNALSYM _tagPROTOCOLDATA}
PROTOCOLDATA = _tagPROTOCOLDATA;

{$EXTERNALSYM IInternetProtocolSink}
IInternetProtocolSink = interface; // forward

{$EXTERNALSYM IInternetProtocolRoot}
IInternetProtocolRoot = interface
['{79eac9e3-baf9-11ce-8c82-00aa004ba90b}']
function Start(szUrl: LPCWSTR; OIProtSink: IInternetProtocolSink;
OIBindInfo: IInternetBindInfo; grfPI, dwReserved: DWORD): HResult; stdcall;
function Continue(const ProtocolData: TProtocolData): HResult; stdcall;
function Abort(hrReason: HResult; dwOptions: DWORD): HResult; stdcall;
function Terminate(dwOptions: DWORD): HResult; stdcall;
function Suspend: HResult; stdcall;
function Resume: HResult; stdcall;
end;

{$EXTERNALSYM IInternetProtocol}
IInternetProtocol = interface(IInternetProtocolRoot)
['{79eac9e4-baf9-11ce-8c82-00aa004ba90b}']
function Read(pv: Pointer; cb: ULONG; out cbRead: ULONG): HResult; stdcall;
function Seek(dlibMove: LARGE_INTEGER; dwOrigin: DWORD; out libNewPosition: ULARGE_INTEGER): HResult; stdcall;
function LockRequest(dwOptions: DWORD): HResult; stdcall;
function UnlockRequest: HResult; stdcall;
end;

{$EXTERNALSYM IInternetProtocolSink}
IInternetProtocolSink = interface
['{79eac9e5-baf9-11ce-8c82-00aa004ba90b}']
function Switch(const ProtocolData: TProtocolData): HResult; stdcall;
function ReportProgress(ulStatusCode: ULONG; szStatusText: LPCWSTR): HResult; stdcall;
function ReportData(grfBSCF: DWORD; ulProgress, ulProgressMax: ULONG): HResult; stdcall;
function ReportResult(hrResult: HResult; dwError: DWORD; szResult: LPCWSTR): HResult; stdcall;
end;

{$NODEFINE TLPCWSTRArray}
TLPCWSTRArray = array[0..MaxLongInt div SizeOf(LPCWSTR) - 1] of LPCWSTR;
{$NODEFINE PLPCWSTRArray}
PLPCWSTRArray = ^TLPCWSTRArray;

{$EXTERNALSYM IInternetSession}
IInternetSession = interface
['{79eac9e7-baf9-11ce-8c82-00aa004ba90b}']
function RegisterNameSpace(CF: IClassFactory; const clsid: TCLSID; pwzProtocol: LPCWSTR;
cPatterns: ULONG; const pwzPatterns: PLPCWSTRArray; dwReserved: DWORD): HResult; stdcall;
function UnregisterNameSpace(CF: IClassFactory; pszProtocol: LPCWSTR): HResult; stdcall;
function RegisterMimeFilter(CF: IClassFactory; const rclsid: TCLSID;
pwzType: LPCWSTR): HResult; stdcall;
function UnregisterMimeFilter(CF: IClassFactory; pwzType: LPCWSTR): HResult; stdcall;
function CreateBinding(BC: IBindCtx; szUrl: LPCWSTR; UnkOuter: IUnknown; out Unk: IUnknown;
out OINetProt: IInternetProtocol; dwOption: DWORD): HResult; stdcall;
function SetSessionOption(dwOption: DWORD; pBuffer: Pointer; dwBufferLength: DWORD;
dwReserved: DWORD): HResult; stdcall;
function GetSessionOption(dwOption: DWORD; pBuffer: Pointer; var dwBufferLength: DWORD;
dwReserved: DWORD): HResult; stdcall;
end; // IInternetSession

{$EXTERNALSYM CoInternetGetSession}
function CoInternetGetSession(dwSessionMode: DWORD; var pIInternetSession: IInternetSession;
dwReserved: DWORD): HResult; stdcall;



type
{$EXTERNALSYM IInternetSecurityMgrSite}
IInternetSecurityMgrSite = interface
['{79eac9ed-baf9-11ce-8c82-00aa004ba90b}']
function GetWindow(out hwnd: HWnd): HResult; stdcall;
function EnableModeless(fEnable: BOOL): HResult; stdcall;
end;

const
{$EXTERNALSYM MAX_SIZE_SECURITY_ID}
MAX_SIZE_SECURITY_ID = 512; // bytes;

// MapUrlToZone returns the zone index given a URL
{$EXTERNALSYM PUAF_DEFAULT}
PUAF_DEFAULT = $00000000;
{$EXTERNALSYM PUAF_NOUI}
PUAF_NOUI = $00000001;
{$EXTERNALSYM PUAF_ISFILE}
PUAF_ISFILE = $00000002;
{$EXTERNALSYM PUAF_WARN_IF_DENIED}
PUAF_WARN_IF_DENIED = $00000004;
{$EXTERNALSYM PUAF_FORCEUI_FOREGROUND}
PUAF_FORCEUI_FOREGROUND = $00000008;
{$EXTERNALSYM PUAF_CHECK_TIFS}
PUAF_CHECK_TIFS = $00000010;

// This is the wrapper function that most clients will use.
// It figures out the current Policy for the passed in Action,
// and puts up UI if the current Policy indicates that the user
// should be queried. It returns back the Policy which the caller
// will use to determine if the action should be allowed
// This is the wrapper function to conveniently read a custom policy.

// SetZoneMapping
// lpszPattern: string denoting a URL pattern
// Examples of valid patterns:
// *://*.msn.com
// http://*.sony.co.jp
// *://et.msn.com
// ftp://157.54.23.41/
// https://localsvr
// file:/localsvr/share
// *://157.54.100-200.*
// Examples of invalid patterns:
// http://*.lcs.mit.edu
// ftp://*
// dwFlags: SZM_FLAGS values

{$EXTERNALSYM SZM_CREATE}
SZM_CREATE = $00000000;
{$EXTERNALSYM SZM_DELETE}
SZM_DELETE = $00000001;

type
{$EXTERNALSYM IInternetSecurityManager}
IInternetSecurityManager = interface
['{79eac9ee-baf9-11ce-8c82-00aa004ba90b}']
function SetSecuritySite(Site: IInternetSecurityMgrSite): HResult; stdcall;
function GetSecuritySite(out Site: IInternetSecurityMgrSite): HResult; stdcall;
function MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD;
dwFlags: DWORD): HResult; stdcall;
function GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer;
var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;
function ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD;
pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
dwFlags, dwReserved: DWORD): HResult; stdcall;
function QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID;
out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
dwReserved: DWORD): HResult; stdcall;
function SetZoneMapping(dwZone: DWORD; lpszPattern: LPCWSTR;
dwFlags: DWORD): HResult; stdcall;
function GetZoneMappings(dwZone: DWORD; out enumString: IEnumString;
dwFlags: DWORD): HResult; stdcall;
end;

{$EXTERNALSYM IInternetHostSecurityManager}
IInternetHostSecurityManager = interface
['{3af280b6-cb3f-11d0-891e-00c04fb6bfc4}']
function GetSecurityId(pbSecurityId: Pointer; var cbSecurityId: DWORD;
dwReserved: DWORD): HResult; stdcall;
function ProcessUrlAction(dwAction: DWORD; pPolicy: Pointer; cbPolicy: DWORD;
pContext: Pointer; cbContext, dwFlags, dwReserved: DWORD): HResult; stdcall;
function QueryCustomPolicy(const guidKey: TGUID; out pPolicy: Pointer; out cbPolicy: DWORD;
pContext: Pointer; cbContext, dwReserved: DWORD): HResult; stdcall;
end;

const
{$EXTERNALSYM URLACTION_MIN}
URLACTION_MIN = $00001000;

{$EXTERNALSYM URLACTION_DOWNLOAD_MIN}
URLACTION_DOWNLOAD_MIN = $00001000;
{$EXTERNALSYM URLACTION_DOWNLOAD_SIGNED_ACTIVEX}
URLACTION_DOWNLOAD_SIGNED_ACTIVEX = $00001001;
{$EXTERNALSYM URLACTION_DOWNLOAD_UNSIGNED_ACTIVEX}
URLACTION_DOWNLOAD_UNSIGNED_ACTIVEX = $00001004;
{$EXTERNALSYM URLACTION_DOWNLOAD_CURR_MAX}
URLACTION_DOWNLOAD_CURR_MAX = $00001004;
{$EXTERNALSYM URLACTION_DOWNLOAD_MAX}
URLACTION_DOWNLOAD_MAX = $000011FF;

{$EXTERNALSYM URLACTION_ACTIVEX_MIN}
URLACTION_ACTIVEX_MIN = $00001200;
{$EXTERNALSYM URLACTION_ACTIVEX_RUN}
URLACTION_ACTIVEX_RUN = $00001200;
{$EXTERNALSYM URLACTION_ACTIVEX_OVERRIDE_OBJECT_SAFETY}
URLACTION_ACTIVEX_OVERRIDE_OBJECT_SAFETY = $00001201; // aggregate next four
{$EXTERNALSYM URLACTION_ACTIVEX_OVERRIDE_DATA_SAFETY}
URLACTION_ACTIVEX_OVERRIDE_DATA_SAFETY = $00001202; //
{$EXTERNALSYM URLACTION_ACTIVEX_OVERRIDE_SCRIPT_SAFETY}
URLACTION_ACTIVEX_OVERRIDE_SCRIPT_SAFETY = $00001203; //
{$EXTERNALSYM URLACTION_SCRIPT_OVERRIDE_SAFETY}
URLACTION_SCRIPT_OVERRIDE_SAFETY = $00001401; //
{$EXTERNALSYM URLACTION_ACTIVEX_CONFIRM_NOOBJECTSAFETY}
URLACTION_ACTIVEX_CONFIRM_NOOBJECTSAFETY = $00001204; //
{$EXTERNALSYM URLACTION_ACTIVEX_TREATASUNTRUSTED}
URLACTION_ACTIVEX_TREATASUNTRUSTED = $00001205;
{$EXTERNALSYM URLACTION_ACTIVEX_CURR_MAX}
URLACTION_ACTIVEX_CURR_MAX = $00001205;
{$EXTERNALSYM URLACTION_ACTIVEX_MAX}
URLACTION_ACTIVEX_MAX = $000013FF;

{$EXTERNALSYM URLACTION_SCRIPT_MIN}
URLACTION_SCRIPT_MIN = $00001400;
{$EXTERNALSYM URLACTION_SCRIPT_RUN}
URLACTION_SCRIPT_RUN = $00001400;
{$EXTERNALSYM URLACTION_SCRIPT_JAVA_USE}
URLACTION_SCRIPT_JAVA_USE = $00001402;
{$EXTERNALSYM URLACTION_SCRIPT_SAFE_ACTIVEX}
URLACTION_SCRIPT_SAFE_ACTIVEX = $00001405;
{$EXTERNALSYM URLACTION_SCRIPT_CURR_MAX}
URLACTION_SCRIPT_CURR_MAX = $00001405;
{$EXTERNALSYM URLACTION_SCRIPT_MAX}
URLACTION_SCRIPT_MAX = $000015FF;

{$EXTERNALSYM URLACTION_HTML_MIN}
URLACTION_HTML_MIN = $00001600;
{$EXTERNALSYM URLACTION_HTML_SUBMIT_FORMS}
URLACTION_HTML_SUBMIT_FORMS = $00001601; // aggregate next two
{$EXTERNALSYM URLACTION_HTML_SUBMIT_FORMS_FROM}
URLACTION_HTML_SUBMIT_FORMS_FROM = $00001602; //
{$EXTERNALSYM URLACTION_HTML_SUBMIT_FORMS_TO}
URLACTION_HTML_SUBMIT_FORMS_TO = $00001603; //
{$EXTERNALSYM URLACTION_HTML_FONT_DOWNLOAD}
URLACTION_HTML_FONT_DOWNLOAD = $00001604;
{$EXTERNALSYM URLACTION_HTML_JAVA_RUN}
URLACTION_HTML_JAVA_RUN = $00001605; // derive from Java custom policy;
{$EXTERNALSYM URLACTION_HTML_CURR_MAX}
URLACTION_HTML_CURR_MAX = $00001605;
{$EXTERNALSYM URLACTION_HTML_MAX}
URLACTION_HTML_MAX = $000017FF;

{$EXTERNALSYM URLACTION_SHELL_MIN}
URLACTION_SHELL_MIN = $00001800;
{$EXTERNALSYM URLACTION_SHELL_INSTALL_DTITEMS}
URLACTION_SHELL_INSTALL_DTITEMS = $00001800;
{$EXTERNALSYM URLACTION_SHELL_MOVE_OR_COPY}
URLACTION_SHELL_MOVE_OR_COPY = $00001802;
{$EXTERNALSYM URLACTION_SHELL_FILE_DOWNLOAD}
URLACTION_SHELL_FILE_DOWNLOAD = $00001803;
{$EXTERNALSYM URLACTION_SHELL_VERB}
URLACTION_SHELL_VERB = $00001804;
{$EXTERNALSYM URLACTION_SHELL_WEBVIEW_VERB}
URLACTION_SHELL_WEBVIEW_VERB = $00001805;
{$EXTERNALSYM URLACTION_SHELL_CURR_MAX}
URLACTION_SHELL_CURR_MAX = $00001805;
{$EXTERNALSYM URLACTION_SHELL_MAX}
URLACTION_SHELL_MAX = $000019FF;

{$EXTERNALSYM URLACTION_NETWORK_MIN}
URLACTION_NETWORK_MIN = $00001A00;

{$EXTERNALSYM URLACTION_CREDENTIALS_USE}
URLACTION_CREDENTIALS_USE = $00001A00;
{$EXTERNALSYM URLPOLICY_CREDENTIALS_SILENT_LOGON_OK}
URLPOLICY_CREDENTIALS_SILENT_LOGON_OK = $00000000;
{$EXTERNALSYM URLPOLICY_CREDENTIALS_MUST_PROMPT_USER}
URLPOLICY_CREDENTIALS_MUST_PROMPT_USER = $00010000;
{$EXTERNALSYM URLPOLICY_CREDENTIALS_CONDITIONAL_PROMPT}
URLPOLICY_CREDENTIALS_CONDITIONAL_PROMPT = $00020000;
{$EXTERNALSYM URLPOLICY_CREDENTIALS_ANONYMOUS_ONLY}
URLPOLICY_CREDENTIALS_ANONYMOUS_ONLY = $00030000;

{$EXTERNALSYM URLACTION_AUTHENTICATE_CLIENT}
URLACTION_AUTHENTICATE_CLIENT = $00001A01;
{$EXTERNALSYM URLPOLICY_AUTHENTICATE_CLEARTEXT_OK}
URLPOLICY_AUTHENTICATE_CLEARTEXT_OK = $00000000;
{$EXTERNALSYM URLPOLICY_AUTHENTICATE_CHALLENGE_RESPONSE}
URLPOLICY_AUTHENTICATE_CHALLENGE_RESPONSE = $00010000;
{$EXTERNALSYM URLPOLICY_AUTHENTICATE_MUTUAL_ONLY}
URLPOLICY_AUTHENTICATE_MUTUAL_ONLY = $00030000;

{$EXTERNALSYM URLACTION_NETWORK_CURR_MAX}
URLACTION_NETWORK_CURR_MAX = $00001A01;
{$EXTERNALSYM URLACTION_NETWORK_MAX}
URLACTION_NETWORK_MAX = $00001BFF;

{$EXTERNALSYM URLACTION_JAVA_MIN}
URLACTION_JAVA_MIN = $00001C00;
{$EXTERNALSYM URLACTION_JAVA_PERMISSIONS}
URLACTION_JAVA_PERMISSIONS = $00001C00;
{$EXTERNALSYM URLPOLICY_JAVA_PROHIBIT}
URLPOLICY_JAVA_PROHIBIT = $00000000;
{$EXTERNALSYM URLPOLICY_JAVA_HIGH}
URLPOLICY_JAVA_HIGH = $00010000;
{$EXTERNALSYM URLPOLICY_JAVA_MEDIUM}
URLPOLICY_JAVA_MEDIUM = $00020000;
{$EXTERNALSYM URLPOLICY_JAVA_LOW}
URLPOLICY_JAVA_LOW = $00030000;
{$EXTERNALSYM URLPOLICY_JAVA_CUSTOM}
URLPOLICY_JAVA_CUSTOM = $00800000;
{$EXTERNALSYM URLACTION_JAVA_CURR_MAX}
URLACTION_JAVA_CURR_MAX = $00001C00;
{$EXTERNALSYM URLACTION_JAVA_MAX}
URLACTION_JAVA_MAX = $00001CFF;

// The following Infodelivery actions should have no default policies
// in the registry. They assume that no default policy means fall
// back to the global restriction. If an admin sets a policy per
// zone, then it overrides the global restriction.

{$EXTERNALSYM URLACTION_INFODELIVERY_MIN}
URLACTION_INFODELIVERY_MIN = $00001D00;
{$EXTERNALSYM URLACTION_INFODELIVERY_NO_ADDING_CHANNELS}
URLACTION_INFODELIVERY_NO_ADDING_CHANNELS = $00001D00;
{$EXTERNALSYM URLACTION_INFODELIVERY_NO_EDITING_CHANNELS}
URLACTION_INFODELIVERY_NO_EDITING_CHANNELS = $00001D01;
{$EXTERNALSYM URLACTION_INFODELIVERY_NO_REMOVING_CHANNELS}
URLACTION_INFODELIVERY_NO_REMOVING_CHANNELS = $00001D02;
{$EXTERNALSYM URLACTION_INFODELIVERY_NO_ADDING_SUBSCRIPTIONS}
URLACTION_INFODELIVERY_NO_ADDING_SUBSCRIPTIONS = $00001D03;
{$EXTERNALSYM URLACTION_INFODELIVERY_NO_EDITING_SUBSCRIPTIONS}
URLACTION_INFODELIVERY_NO_EDITING_SUBSCRIPTIONS = $00001D04;
{$EXTERNALSYM URLACTION_INFODELIVERY_NO_REMOVING_SUBSCRIPTIONS}
URLACTION_INFODELIVERY_NO_REMOVING_SUBSCRIPTIONS = $00001D05;
{$EXTERNALSYM URLACTION_INFODELIVERY_NO_CHANNEL_LOGGING}
URLACTION_INFODELIVERY_NO_CHANNEL_LOGGING = $00001D06;
{$EXTERNALSYM URLACTION_INFODELIVERY_CURR_MAX}
URLACTION_INFODELIVERY_CURR_MAX = $00001D06;
{$EXTERNALSYM URLACTION_INFODELIVERY_MAX}
URLACTION_INFODELIVERY_MAX = $00001DFF;
{$EXTERNALSYM URLACTION_CHANNEL_SOFTDIST_MIN}
URLACTION_CHANNEL_SOFTDIST_MIN = $00001E00;
{$EXTERNALSYM URLACTION_CHANNEL_SOFTDIST_PERMISSIONS}
URLACTION_CHANNEL_SOFTDIST_PERMISSIONS = $00001E05;
{$EXTERNALSYM URLPOLICY_CHANNEL_SOFTDIST_PROHIBIT}
URLPOLICY_CHANNEL_SOFTDIST_PROHIBIT = $00010000;
{$EXTERNALSYM URLPOLICY_CHANNEL_SOFTDIST_PRECACHE}
URLPOLICY_CHANNEL_SOFTDIST_PRECACHE = $00020000;
{$EXTERNALSYM URLPOLICY_CHANNEL_SOFTDIST_AUTOINSTALL}
URLPOLICY_CHANNEL_SOFTDIST_AUTOINSTALL = $00030000;
{$EXTERNALSYM URLACTION_CHANNEL_SOFTDIST_MAX}
URLACTION_CHANNEL_SOFTDIST_MAX = $00001EFF;

// For each action specified above the system maintains
// a set of policies for the action.
// The only policies supported currently are permissions (i.e. is something allowed)
// and logging status.
// IMPORTANT: If you are defining your own policies don't overload the meaning of the
// loword of the policy. You can use the hiword to store any policy bits which are only
// meaningful to your action.
// For an example of how to do this look at the URLPOLICY_JAVA above

// Permissions
{$EXTERNALSYM URLPOLICY_ALLOW}
URLPOLICY_ALLOW = $00;
{$EXTERNALSYM URLPOLICY_QUERY}
URLPOLICY_QUERY = $01;
{$EXTERNALSYM URLPOLICY_DISALLOW}
URLPOLICY_DISALLOW = $03;

// Notifications are not done when user already queried.
{$EXTERNALSYM URLPOLICY_NOTIFY_ON_ALLOW}
URLPOLICY_NOTIFY_ON_ALLOW = $10;
{$EXTERNALSYM URLPOLICY_NOTIFY_ON_DISALLOW}
URLPOLICY_NOTIFY_ON_DISALLOW = $20;

// Logging is done regardless of whether user was queried.
{$EXTERNALSYM URLPOLICY_LOG_ON_ALLOW}
URLPOLICY_LOG_ON_ALLOW = $40;
{$EXTERNALSYM URLPOLICY_LOG_ON_DISALLOW}
URLPOLICY_LOG_ON_DISALLOW = $80;

{$EXTERNALSYM URLPOLICY_MASK_PERMISSIONS}
URLPOLICY_MASK_PERMISSIONS = $0F;


// The ordinal #'s that define the predefined zones internet explorer knows about.
// When we support user-defined zones their zone numbers should be between
// URLZONE_USER_MIN and URLZONE_USER_MAX

const
{$EXTERNALSYM URLZONE_PREDEFINED_MIN}
URLZONE_PREDEFINED_MIN = 0;
{$EXTERNALSYM URLZONE_LOCAL_MACHINE}
URLZONE_LOCAL_MACHINE = 0;
{$EXTERNALSYM URLZONE_INTRANET}
URLZONE_INTRANET = URLZONE_LOCAL_MACHINE + 1;
{$EXTERNALSYM URLZONE_TRUSTED}
URLZONE_TRUSTED = URLZONE_INTRANET + 1;
{$EXTERNALSYM URLZONE_INTERNET}
URLZONE_INTERNET = URLZONE_TRUSTED + 1;
{$EXTERNALSYM URLZONE_UNTRUSTED}
URLZONE_UNTRUSTED = URLZONE_INTERNET + 1;
{$EXTERNALSYM URLZONE_PREDEFINED_MAX}
URLZONE_PREDEFINED_MAX = 999;
{$EXTERNALSYM URLZONE_USER_MIN}
URLZONE_USER_MIN = 1000;
{$EXTERNALSYM URLZONE_USER_MAX}
URLZONE_USER_MAX = 10000;

{$EXTERNALSYM URLTEMPLATE_CUSTOM}
URLTEMPLATE_CUSTOM = $00000000;
{$EXTERNALSYM URLTEMPLATE_PREDEFINED_MIN}
URLTEMPLATE_PREDEFINED_MIN = $00010000;
{$EXTERNALSYM URLTEMPLATE_LOW}
URLTEMPLATE_LOW = $00010000;
{$EXTERNALSYM URLTEMPLATE_MEDIUM}
URLTEMPLATE_MEDIUM = $00011000;
{$EXTERNALSYM URLTEMPLATE_HIGH}
URLTEMPLATE_HIGH = $00012000;
{$EXTERNALSYM URLTEMPLATE_PREDEFINED_MAX}
URLTEMPLATE_PREDEFINED_MAX = $00020000;

{$EXTERNALSYM MAX_ZONE_PATH}
MAX_ZONE_PATH = 260;
{$EXTERNALSYM MAX_ZONE_DESCRIPTION}
MAX_ZONE_DESCRIPTION = 200;

{$EXTERNALSYM ZAFLAGS_CUSTOM_EDIT}
ZAFLAGS_CUSTOM_EDIT = $00000001;
{$EXTERNALSYM ZAFLAGS_ADD_SITES}
ZAFLAGS_ADD_SITES = $00000002;
{$EXTERNALSYM ZAFLAGS_REQUIRE_VERIFICATION}
ZAFLAGS_REQUIRE_VERIFICATION = $00000004;
{$EXTERNALSYM ZAFLAGS_INCLUDE_PROXY_OVERRIDE}
ZAFLAGS_INCLUDE_PROXY_OVERRIDE = $00000008;
{$EXTERNALSYM ZAFLAGS_INCLUDE_INTRANET_SITES}
ZAFLAGS_INCLUDE_INTRANET_SITES = $00000010;
{$EXTERNALSYM ZAFLAGS_NO_UI}
ZAFLAGS_NO_UI = $00000020;
{$EXTERNALSYM ZAFLAGS_SUPPORTS_VERIFICATION}
ZAFLAGS_SUPPORTS_VERIFICATION = $00000040;
{$EXTERNALSYM ZAFLAGS_UNC_AS_INTRANET}
ZAFLAGS_UNC_AS_INTRANET = $00000080;

type
PZoneAttributes = ^TZoneAttributes;
{$EXTERNALSYM _ZONEATTRIBUTES}
_ZONEATTRIBUTES = packed record
cbSize: ULONG;
szDisplayName: array[0..260 - 1] of WideChar;
szDescription: array[0..200 - 1] of WideChar;
szIconPath: array[0..260 - 1] of WideChar;
dwTemplateMinLevel: DWORD;
dwTemplateRecommended: DWORD;
dwTemplateCurrentLevel: DWORD;
dwFlags: DWORD;
end;
TZoneAttributes = _ZONEATTRIBUTES;
{$EXTERNALSYM ZONEATTRIBUTES}
ZONEATTRIBUTES = _ZONEATTRIBUTES;

// Gets the zone attributes (information in registry other than actual security
// policies associated with the zone). Zone attributes are fixed as:
// Sets the zone attributes (information in registry other than actual security
// policies associated with the zone). Zone attributes as above.
// Returns S_OK or ??? if failed to write the zone attributes.
{ Registry Flags

When reading, default behavior is:
If HKLM allows override and HKCU value exists
Then use HKCU value
Else use HKLM value
When writing, default behavior is same as HKCU
If HKLM allows override
Then Write to HKCU
Else Fail
}

const
{$EXTERNALSYM URLZONEREG_DEFAULT}
URLZONEREG_DEFAULT = 0;
{$EXTERNALSYM URLZONEREG_HKLM}
URLZONEREG_HKLM = URLZONEREG_DEFAULT + 1;
{$EXTERNALSYM URLZONEREG_HKCU}
URLZONEREG_HKCU = URLZONEREG_HKLM + 1;

// Gets a named custom policy associated with a zone;
// e.g. the Java VM settings can be defined with a unique key such as 'Java'.
// Custom policy support is intended to allow extensibility from the predefined
// set of policies that IE4 has built in.
//
// pwszKey is the string name designating the custom policy. Components are
// responsible for having unique names.
// ppPolicy is the callee allocated buffer for the policy byte blob; caller is
// responsible for freeing this buffer eventually.
// pcbPolicy is the size of the byte blob returned.
// dwRegFlags determines how registry is accessed (see above).
// Returns S_OK if key is found and buffer allocated; ??? if key is not found (no buffer alloced).
// Sets a named custom policy associated with a zone;
// e.g. the Java VM settings can be defined with a unique key such as 'Java'.
// Custom policy support is intended to allow extensibility from the predefined
// set of policies that IE4 has built in.
//
// pwszKey is the string name designating the custom policy. Components are
// responsible for having unique names.
// ppPolicy is the caller allocated buffer for the policy byte blob.
// pcbPolicy is the size of the byte blob to be set.
// dwRegFlags determines if HTCU or HKLM is set.
// Returns S_OK or ??? if failed to write the zone custom policy.
// Gets action policy associated with a zone, the builtin, fixed-length policies info.

// dwAction is the action code for the action as defined above.
// pPolicy is the caller allocated buffer for the policy data.
// cbPolicy is the size of the caller allocated buffer.
// dwRegFlags determines how registry is accessed (see above).
// Returns S_OK if action is valid; ??? if action is not valid.

type
{$EXTERNALSYM IInternetZoneManager}
IInternetZoneManager = interface
['{79eac9ef-baf9-11ce-8c82-00aa004ba90b}']

// Gets the zone attributes (information in registry other than actual security
// policies associated with the zone). Zone attributes are fixed as:
function GetZoneAttributes(dwZone: DWORD;
var ZoneAttributes: TZoneAttributes): HResult; stdcall;

// Sets the zone attributes (information in registry other than actual security
// policies associated with the zone). Zone attributes as above.
// Returns S_OK or ??? if failed to write the zone attributes.
function SetZoneAttributes(dwZone: DWORD;
const ZoneAttributes: TZoneAttributes): HResult; stdcall;
function GetZoneCustomPolicy(dwZone: DWORD; const guidKey: TGUID; out pPolicy: Pointer;
out cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;
function SetZoneCustomPolicy(dwZone: DWORD; const guidKey: TGUID; pPolicy: Pointer;
cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;
function GetZoneActionPolicy(dwZone, dwAction: DWORD; pPolicy: Pointer;
cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;
function SetZoneActionPolicy(dwZone, dwAction: DWORD; pPolicy: Pointer;
cbPolicy: DWORD; urlZoneReg: TUrlZoneReg): HResult; stdcall;
function PromptAction(dwAction: DWORD; hwndParent: HWnd; pwszUrl, pwszText: LPCWSTR;
dwPromptFlags: DWORD): HResult; stdcall;
function LogAction(dwAction: DWORD; pwszUrl, pwszText: LPCWSTR;
dwLogFlags: DWORD): HResult; stdcall;
function CreateZoneEnumerator(out dwEnum, dwCount: DWORD;
dwFlags: DWORD): HResult; stdcall;
function GetZoneAt(dwEnum, dwIndex: DWORD; out dwZone: DWORD): HResult; stdcall;
function DestroyZoneEnumerator(dwEnum: DWORD): HResult; stdcall;
function CopyTemplatePoliciesToZone(dwTemplate, dwZone, dwReserved: DWORD): HResult; stdcall;
end;

// Creates the security manager object. The first argument is the Service provider
// to allow for delegation
{$EXTERNALSYM CoInternetCreateSecurityManager}
function CoInternetCreateSecurityManager(SP: IServiceProvider; var SM: IInternetSecurityManager;
dwReserved: DWORD): HResult; stdcall;
{$EXTERNALSYM CoInternetCreateZoneManager}
function CoInternetCreateZoneManager(SP: IServiceProvider; var ZM: IInternetZoneManager;
dwReserved: DWORD): HResult; stdcall;



{$ENDIF}

var
ShellModule: THandle;
ComCtlModule : THandle;
HHCtrlModule : THandle;


function SHLockShared(Handle: THandle; DW: DWORD): Pointer; stdcall;
function SHUnlockShared(Pnt: Pointer): BOOL; stdcall;
function SHFreeShared(Handle: THandle; DW: DWORD): Pointer; stdcall;
function _Free(Pidl: PItemIDList): BOOL; stdcall;
function HtmlHelp(hwndCaller: HWND; pszFile: PChar; uCommand: Integer;
dwData: DWORD): HWND; stdcall;


implementation

const
urldll = 'url.dll';

function InetIsOffline; external urldll name 'InetIsOffline';

function MIMEAssociationDialogW; external urldll name 'MIMEAssociationDialogW';
function MIMEAssociationDialogA; external urldll name 'MIMEAssociationDialogA';
{$IFDEF UNICODE}
function MIMEAssociationDialog; external urldll name 'MIMEAssociationDialogW';
{$ELSE}
function MIMEAssociationDialog; external urldll name 'MIMEAssociationDialogA';
{$ENDIF}

function URLAssociationDialogW; external urldll name 'URLAssociationDialogW';
function URLAssociationDialogA; external urldll name 'URLAssociationDialogA';
{$IFDEF UNICODE}
function URLAssociationDialog; external urldll name 'URLAssociationDialogW';
{$ELSE}
function URLAssociationDialog; external urldll name 'URLAssociationDialogA';
{$ENDIF}

function TranslateURLA; external urldll name 'TranslateURLA';
function TranslateURLW; external urldll name 'TranslateURLW';
{$IFDEF UNICODE}
function TranslateURL; external urldll name 'TranslateURLW';
{$ELSE}
function TranslateURL; external urldll name 'TranslateURLA';
{$ENDIF}



{$IFDEF VER120}
const
UrlMonLib = 'URLMON.DLL';
function CoInternetGetSession; external UrlMonLib name 'CoInternetGetSession';
function CoInternetCreateSecurityManager; external UrlMonLib name 'CoInternetCreateSecurityManager';
function CoInternetCreateZoneManager; external UrlMonLib name 'CoInternetCreateZoneManager';
{$ENDIF}





const
Shell32 = 'shell32.dll';
comctl32 = 'comctl32.dll';
hhctrl = 'hhctrl.ocx';


SHLockShared_Index = 521;
SHUnlockShared_Index = 522;
SHFreeShared_Index = 523;
Free_Index = 73;


function GetShellModule: THandle;
begin
if ShellModule = 0 then
begin
ShellModule := {$IFDEF VER120} LoadLibrary(Shell32){$ELSE}SafeLoadLibrary(Shell32){$ENDIF};
if ShellModule <= HINSTANCE_ERROR then
ShellModule := 0;
end;
Result := ShellModule;
end;

function GetHHctrlModule: THandle;
begin
if HHCtrlModule = 0 then
begin
HHCtrlModule :={$IFDEF VER120} LoadLibrary(HHCtrl){$ELSE} SafeLoadLibrary(HHCtrl){$ENDIF};
if HHCtrlModule <= HINSTANCE_ERROR then
HHCtrlModule := 0;
end;
Result := HHCtrlModule;
end;


function GetComctlModule: THandle;
begin
if ComctlModule = 0 then
begin
ComctlModule := {$IFDEF VER120}LoadLibrary(comctl32) {$ELSE} SafeLoadLibrary(comctl32){$ENDIF};
if ComctlModule <= HINSTANCE_ERROR then
ComctlModule := 0;
end;
Result := ComctlModule;
end;


function HtmlHelp(hwndCaller: HWND; pszFile: PChar; uCommand: Integer;
dwData: DWORD): HWND; stdcall;
type
TheFunctionType = function(hwndCaller: HWND; pszFile: PChar; uCommand: Integer;
dwData: DWORD): HWND; stdcall;
var
TheFunction: TheFunctionType;
begin
Result := 0;
if HHCtrlModule = 0 then HHCtrlModule := GetHHCtrlModule;
if HHCtrlModule <> 0 then begin
TheFunction := GetProcAddress(HHCtrlModule, PChar('HtlmHelpA'));
if (Assigned(TheFunction)) then Result := TheFunction(hwndCaller, pszFile, uCommand, dwdata);
end;
end;







function _Free(Pidl: PItemIDList): BOOL; stdcall;
type
TheFunctionType = function(Pidl: PItemIDList): BOOL; stdcall;
var
TheFunction: TheFunctionType;
begin
Result := False;
if ComctlModule = 0 then ComctlModule := GetComctlModule;
if ComctlModule <> 0 then begin
TheFunction := GetProcAddress(ComctlModule, PChar(Free_Index));
if (Assigned(TheFunction)) then Result := TheFunction(Pidl);
end;
end;



function SHLockShared(Handle: THandle; DW: DWORD): Pointer; stdcall;
type
TheFunctionType = function(Handle: THandle; DW: DWORD): Pointer; stdcall;
var
TheFunction: TheFunctionType;
begin
Result := nil;
if ShellModule = 0 then ShellModule := GetShellModule;
if ShellModule <> 0 then begin
TheFunction := GetProcAddress(ShellModule, PChar(SHLockShared_Index));
if (Assigned(TheFunction)) then Result := TheFunction(Handle, DW);
end;
end;

function SHUnLockShared(pnt: Pointer): BOOL; stdcall;
type
TheFunctionType = function(pnt: Pointer): BOOL; stdcall;
var
TheFunction: TheFunctionType;
begin
Result := FALSE;
if ShellModule = 0 then ShellModule := GetShellModule;
if ShellModule <> 0 then begin
TheFunction := GetProcAddress(ShellModule, PChar(SHUnLockShared_Index));
if (Assigned(TheFunction)) then Result := TheFunction(pnt);
end;
end;

function SHFreeShared(Handle: THandle; DW: DWORD): Pointer; stdcall;
type
TheFunctionType = function(Handle: THandle; DW: DWORD): Pointer; stdcall;
var
TheFunction: TheFunctionType;
begin
Result := nil;
if ShellModule = 0 then ShellModule := GetShellModule;
if ShellModule <> 0 then begin
TheFunction := GetProcAddress(ShellModule, PChar(SHFreeShared_Index));
if (Assigned(TheFunction)) then Result := TheFunction(Handle, DW);
end;
end;


initialization

finalization
if ShellModule <> 0 then FreeLibrary(ShellModule);
if ComctlModule <> 0 then FreeLibrary(ComctlModule);
if HHCtrlModule <> 0 then FreeLibrary(HHCtrlModule);

end.

(*******************************
* IEUTILS 1.4 (Oct. 16 2001) *
*******************************)

unit IEUtils;

interface

uses

{$IFDEF VER140}Variants,{$ENDIF}
IEConst, dialogs,Inifiles, Registry, Sysutils, ShellApi, Windows, Activex, Shlobj;


function IE5_Installed: Boolean;
function GetIEVersion: string;
function StringToVarArray(const S: string): Variant;
function VarArrayToString(const V: Variant): string;
function Encode(const S: string): string;
function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function IsFolderEx(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function IsChannel(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
function GetImageIndex(pidl: PItemIDList): integer;
function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
function ResolveLink(const path: string): string;
function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
function ResolveUrlIni(Filename: string): string;
function ResolveUrlIntShCut(Filename: string): string;
procedure DisposePIDL(ID: PItemIDList);
function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
function NextPIDL(IDList: PItemIDList): PItemIDList;
function GetPIDLSize(IDList: PItemIDList): Integer;
procedure StripLastID(IDList: PItemIDList);
function CreatePIDL(Size: Integer): PItemIDList;
function CopyPIDL(IDList: PItemIDList): PItemIDList;
function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;



implementation

uses comobj;


function StringToVarArray(const S: string): Variant;
begin
Result := Unassigned;
if S <> '' then
begin
Result := VarArrayCreate([0, Length(S) - 1], varByte);
Move(Pointer(S)^, VarArrayLock(Result)^, Length(S));
VarArrayUnlock(Result);
end;
end;


function VarArrayToString(const V: Variant): string;
var
i, j: Integer;
begin
if VarIsArray(V) then
for I := 0 to VarArrayHighBound(V, 1) do
begin
j := V;
result := result + chr(j);
end;
end;

function Encode(const S: string): string;
var
I: Integer;
Hex: string;
begin
for I := 1 to Length(S) do

case S of
' ': result := Result + '+';
'A'..'Z', 'a'..'z', '*', '@', '.', '_', '-',
'0'..'9', '$', '!', '''', '(', ')':
result := Result + s;
else
begin
Hex := IntToHex(ord(S), 2);
if Length(Hex) = 2 then Result := Result + '%' + Hex else
Result := Result + '%0' + hex;
end;
end;
end;

function IE5_Installed: Boolean;
var
Reg: TRegistry;
S: string;
begin
Reg := TRegistry.Create;
with Reg do begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software/Microsoft/Internet Explorer', False);
if ValueExists('Version') then S := ReadString('Version')
else S := '0';
CloseKey;
Free;
end;
Result := (StrToInt(S[1]) > 4);
end;


function GetIEVersion: string;
var
SysDir: PChar;
Info: Pointer;
InfoData: Pointer;
InfoSize: LongInt;
Len: DWORD;
FName: Pchar;
SystemDir, Infotype: string;
LangPtr: Pointer;
begin
Len := MAX_PATH + 1;
GetMem(SysDir, Len);
try
if Windows.GetSystemDirectory(SysDir, Len) <> 0 then
SystemDir := SysDir;
finally
FreeMem(SysDir);
end;
result := '';
InfoType := 'FileVersion';
FName := Pchar(SystemDir + '/shdocvw.dll');
InfoSize := GetFileVersionInfoSize(Fname, Len);
if (InfoSize > 0) then
begin
GetMem(Info, InfoSize);
try
if GetFileVersionInfo(FName, Len, InfoSize, Info) then
begin
Len := 255;
if VerQueryValue(Info, '/VarFileInfo/Translation', LangPtr, Len) then
InfoType := Format('/StringFileInfo/%0.4x%0.4x/%s'#0, [LoWord(LongInt(LangPtr^)),
HiWord(LongInt(LangPtr^)), InfoType]);
if VerQueryValue(Info, Pchar(InfoType), InfoData, len) then
Result := strPas(InfoData);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;


function ResolveUrlIni(Filename: string): string;
var
ini: TiniFile;
begin
result := '';
ini := TIniFile.create(fileName);
try
result := ini.ReadString('InternetShortcut', 'URL', '');
finally
ini.free;
end;
end;

function ResolveUrlIntShCut(Filename: string): string;
var
IURL: IUniformResourceLocator;
PersistFile: IPersistfile;
FName: array[0..MAX_PATH] of WideChar;
p: Pchar;
begin
if Succeeded(CoCreateInstance(CLSID_InternetShortcut, nil, CLSCTX_INPROC_SERVER,
IID_IUniformResourceLocator, IURL))
then begin
Persistfile := IUrl as IPersistFile;
StringToWideChar(FileName, FName, MAX_PATH);
PersistFile.Load(Fname, STGM_READ);
IUrl.geturl(@P);
Result := P;
end;
end;

function ResolveChannel(pFolder: IShellFolder; pidl: PItemIDList; var lpszURL: string): HRESULT;
var
pidlChannel: PItemIDList;
psfDesktop: IShellFolder;
pShellLink: IShellLink;
begin
Result := S_FALSE;
if Succeeded(pFolder.GetUIObjectOf(0, 1, pidl, IShellLink, nil, Pointer(pShellLink)))
then
if Succeeded(pShellLink.GetIDList(pidlChannel)) then
if Succeeded(SHGetDesktopFolder(psfDesktop))
then
begin
lpszURL := getDisplayName(psfDesktop, PidlChannel);
Result := S_OK;
end;
DisposePidl(PidlChannel);
end;

function ResolveLink(const path: string): string;
var
link: IShellLink;
storage: IPersistFile;
filedata: TWin32FindData;
buf: array[0..MAX_PATH] of Char;
widepath: WideString;
begin
OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, link));
OleCheck(link.QueryInterface(IPersistFile, storage));
widepath := path;
Result := '';
if Succeeded(storage.Load(@widepath[1], STGM_READ)) then
if Succeeded(link.Resolve(GetActiveWindow, SLR_NOUPDATE)) then
if Succeeded(link.GetPath(buf, sizeof(buf), filedata, SLGP_UNCPRIORITY)) then
Result := buf;
storage := nil;
link := nil;
end;

function ExtractUrl(ShellFolder: IShellFolder; pidl: PItemIDList): string;
var
Handle: THandle;
Info: IQueryInfo;
W: PWideChar;
begin
Handle := 0;
Info := nil;
ShellFolder.GetUIObjectOf(Handle, 1, pidl, IID_IQUERYINFO, nil, Pointer(Info));
if assigned(Info) then
begin
Info.GetInfoTip(0, w);
Result := W;
end else result := '';
Result := Trim(Copy(Result, Pos(#10, Result) + 1, length(Result)));
end;

function IsFolder(ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
Flags: UINT;
begin
Flags := SFGAO_FOLDER;
ShellFolder.GetAttributesOf(1, ID, Flags);
Result := SFGAO_FOLDER and Flags <> 0;
end;

function IsChannel(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
FileInfo: TShFileInfo;
begin
SHGetFileInfo(Pchar(ID), 0, FileInfo, SizeOf(TSHFileInfo), SHGFI_PIDL or SHGFI_TYPENAME);
Result:=BOOL(fileinfo.szTypeName = ChannelShortcut);
end;


function IsFolderEx(ChannelShortcut: String; ShellFolder: IShellFolder; ID: PItemIDList): Boolean;
var
Flags: UINT;
begin
Flags := SFGAO_FOLDER;
ShellFolder.GetAttributesOf(1, ID, Flags);
If SFGAO_FOLDER and Flags <> 0 then
result:=not isChannel(ChannelShortcut, Shellfolder, id)
else Result:=False;
end;

function GetImageIndex(pidl: PItemIDList): integer;
var
Flags: UINT;
FileInfo: TSHFileInfo;
begin
Flags := SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_ICON or SHGFI_SMALLICON;
if SHGetFileInfo(PChar(pidl), 0, FileInfo, SizeOf(TSHFileInfo), Flags) = 0 then
Result := -1
else
Result := FileInfo.iIcon;
end;

function GetDisplayName(Folder: IShellFolder; pidl: PItemIDList): string;
var
StrRet: TStrRet;
begin
Folder.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET:
Result := Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end;

function GetFileName(Folder: IShellFolder; pidl: PItemIDList): string;
var
StrRet: TStrRet;
begin
Folder.GetDisplayNameOf(pidl, SHGDN_FORPARSING, StrRet);
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET:
Result:= Pchar(@pidl.mkid.abID[StrRet.uOffset - SizeOf(pidl.mkid.cb)]);
STRRET_WSTR:
Result := StrRet.pOleStr;
end;
end;

procedure DisposePIDL(ID: PItemIDList);
var
Malloc: IMalloc;
begin
if ID = nil then Exit;
OLECheck(SHGetMalloc(Malloc));
Malloc.Free(ID);
end;

function CopyITEMID(Malloc: IMalloc; ID: PItemIDList): PItemIDList;
begin
Result := Malloc.Alloc(ID^.mkid.cb + SizeOf(ID^.mkid.cb));
CopyMemory(Result, ID, ID^.mkid.cb + SizeOf(ID^.mkid.cb));
end;

function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
Result := IDList;
Inc(PChar(Result), IDList^.mkid.cb);
end;

function GetPIDLSize(IDList: PItemIDList): Integer;
begin
Result := 0;
if Assigned(IDList) then
begin
Result := SizeOf(IDList^.mkid.cb);
while IDList^.mkid.cb <> 0 do
begin
Result := Result + IDList^.mkid.cb;
IDList := NextPIDL(IDList);
end;
end;
end;

procedure StripLastID(IDList: PItemIDList);
var
MarkerID: PItemIDList;
begin
MarkerID := IDList;
if Assigned(IDList) then
begin
while IDList.mkid.cb <> 0 do
begin
MarkerID := IDList;
IDList := NextPIDL(IDList);
end;
MarkerID.mkid.cb := 0;
end;
end;

function CreatePIDL(Size: Integer): PItemIDList;
var
Malloc: IMalloc;
HR: HResult;
begin
Result := nil;
HR := SHGetMalloc(Malloc);
if Failed(HR) then
Exit;
try
Result := Malloc.Alloc(Size);
if Assigned(Result) then
FillChar(Result^, Size, 0);
finally
end;
end;

function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
Size: Integer;
begin
Size := GetPIDLSize(IDList);
Result := CreatePIDL(Size);
if Assigned(Result) then
CopyMemory(Result, IDList, Size);
end;

function ConcatPIDLs(IDList1, IDList2: PItemIDList): PItemIDList;
var
cb1, cb2: Integer;
begin
if Assigned(IDList1) then
cb1 := GetPIDLSize(IDList1) - SizeOf(IDList1^.mkid.cb)
else
cb1 := 0;
cb2 := GetPIDLSize(IDList2);
Result := CreatePIDL(cb1 + cb2);
if Assigned(Result) then
begin
if Assigned(IDList1) then
CopyMemory(Result, IDList1, cb1);
CopyMemory(PChar(Result) + cb1, IDList2, cb2);
end;
end;

end.

http://www.euromind.com/iedelphi/

chenshaizi：
好难看啊，有没简单一点啊？看到我头都大！

我以前在论坛里找到过，但是是把全部的弹出窗口都给屏蔽了。

試一下用WebBrowser1.GetTextBuf, 取得html之後,再過濾廣告,不知行不行....
以前見過別人的方法是用sendmessage 去close彈出的廣告...

TWebBrowser在新建窗口的时候有一个事件(Delphi7)
另外上边那位不要这样贴代码，太讨厌了 你打个包加在你的笔记里边，连接一下就可以了

是有一个newwindow2的事件，可是这个用来显示“在新窗口中打开“用的，弹出广告也是从这里调用，就是不知如何拦截，
procedure TNewIEPage.WebBrowserNewWindow2(Sender: TObject;
var ppDisp: IDispatch; var Cancel: WordBool);
var
h:THandle;
begin
// showmessage();
FCount:=FCount+1;
if FCount=0 then
begin
FPageControl.Update;
APage:=TNewIEPage.Create(FPageControl,nil);
APage.AddBrowsePage(FUrl);
ppDisp:=APage.GetDefaultDispatch;
APage.OnProgress:=FOnProgress;//Form1.OnProgress;
end
else
begin
h:=(sender as TWebBrowser).HWND;
//h:=findwindow(nil,pchar(FCaption)) ;
PostMessage(h,wm_close,0,0);
end;
end;
可是没有作用

Cancel:=true就拦截了，不过是所有，有用的也拦截了

我的想法是把网页用流式打开，而不是直接放入TwebBrowser里，然后再在里面查找所有的链接，如果的前缀不是以当前的主页为前缀的就换为＃＃＃，然后再放到TwebBrowser里，这样就是有了那些其它链接就全部过滤掉了。如果太严了，那就查找像“AD”，“POP”等信息，如果那一个链接中有就删除掉，这样总可以了吧。
至于取链接可以用葵花宝典或者超级猛料里的东东！

想法很好，不过好像实现不了吧

还没解决？

记得hubdog的《Delphi 深度探索》有点介绍

还没解决啊~~！！

弹出广告和正常弹出本质本身就没有区别，区别就在 URL
procedure TNewIEPage.WebBrowserNewWindow2(Sender: TObject;
var ppDisp: IDispatch; var Cancel: WordBool);
你查一下ppDisp的资料，应该可以从这里找到URL

关于boy2002cn的做法，不用这么麻烦。通过IE本身就可以得到(IHTMLDOCUMENT?)url
关键比如JavaScript弹出，这个url是不存在的，或者是临时动态产生的，所以还是前边的方法有效