想做一个3721类似的功能组件。大家给点思路啊。(100分)

  • 主题发起人 主题发起人 coolfun
  • 开始时间 开始时间
C

coolfun

Unregistered / Unconfirmed
GUEST, unregistred user!
具体要求就是在IE地址栏里输入中文，然后转到我自己的网站上，对这些中文进行解析，最后再转到相应的网站上。

大家给点思路哦。
 
http://www.delphibbs.com/delphibbs/dispq.asp?lid=2398434
 
to andy263
这个你搞定了吗,能说一下的吗
 
利用DELPHI编写IE扩展



116、利用DELPHI编写IE扩展
　　 在自己的程序中使用过WebBrowser控件的朋友都知道，WebBrowser控件定义了诸如BeforeNavigate、DownloadComplete 等事件，我们可以通过编写事件处理代码实现对WebBrowser控件的操作。那么如何实现对IE的事件响应和处理呢？同建立IE面板一样。我们需要建立一个实现IObjectWithSite接口的COM组件，不同的是，我们还需要实现IDispatch接口，在IObjectWithSite接口的SetSite方法中获得IE的WebBrowser接口并建立自身与WebBrowser的连接，然后如果在IE的Webbrowser对象中发生什么事件的话，那么IE就会回调连接的IDispatch接口的Invoke方法。我们通过在Invoke方法中编写代码就可以获得IE事件了。这个利用的是COM编程的回调接口原理。
下面我们首先来实现代码。点击Delphi菜单 File | New 。在 ActiveX 页面中选择Active Library ，然后点击 OK 按钮。然后用同样的方法建立一个COM Object。在COM Object Wizard 窗口中，将复选框 Included type library 去掉。然后在Class Name中输入IEHelper，在Implemented Interface 中输入：IDispatch；IObjectwithSite 。然后点击 OK 按钮建立一个COM组件。
保存工程，将工程保存为IEHelper.dpr，将Unit1保存为IEHelperUnit.pas。下面是IEHelperUnit.pas的具体代码：

unit iehelperunit


interface

uses
WIndows, Comobj, ActiveX, SHDOCVW, MSHTML,Dialogs



type

TIEHelperFactory = class(TComObjectFactory)
private
procedure AddKeys

procedure RemoveKeys

public
procedure UpdateRegistry(Register: Boolean)
override

end



TIEHelper = class(TComObject, IDispatch, IObjectWithSite)
public
function GetTypeInfoCount(out Count: Integer): HResult
stdcall

function GetTypeInfo(Index, LocaleID: Integer
out TypeInfo): HResult
stdcall

function GetIDsOfNames(c onst IID: TGUID
Names: Pointer

NameCount, LocaleID: Integer
DispIDs: Pointer): HResult
stdcall

function Invoke(DispID: Integer
c onst IID: TGUID
LocaleID: Integer

Flags: Word
var Params
VarResult, ExcepInfo, ArgErr: Pointer): HResult
stdcall

function SetSite(c onst pUnkSite: IUnknown): HResult
stdcall

function GetSite(c onst riid: TIID
out site: IUnknown): HResult
stdcall

private
IE: IWebbrowser2

Cookie: Integer

end


c onst
Class_IEHelper: TGUID = '{3D898C55-74CC-4B7C-B5F1-45913F368388}'



implementation

uses ComServ, Registry, SysUtils



procedure DoStatusTextChange(c onst Text: WideString)

begin

end


procedure DoProgressChange(Progress: Integer
ProgressMax: Integer)

begin

end


procedure DoCommandStateChange(Command: Integer
Enable: WordBool)

begin

end


procedure DoDownloadBegin

begin

end


procedure DoDownloadComplete

begin

end


procedure DoTitleChange(c onst Text: WideString)

begin

end


procedure DoPropertyChange(c onst szProperty: WideString)

begin

end


procedure DoBeforeNavigate2(c onst pDisp: IDispatch
var URL: OleVariant
var Flags: OleVariant
var TargetFrameName: OleVariant
var PostData: OleVariant
var Headers: OleVariant
var Cancel: WordBool)

begin
if URL<>'http://www.applevb.com/&amp;#39;then begin
Showmessage('你不可以浏览其它站点')

Cancel:=True

URL:='http://www.applevb.com&amp;#39;

(pDisp as IWebbrowser2).Navigate2(URL,Flags,TargetFrameName,PostData,Headers)

end

end


procedure DoNewWindow2(var ppDisp: IDispatch
var Cancel: WordBool)

begin

end


procedure DoNavigateComplete2(c onst pDisp: IDispatch
var URL: OleVariant)

begin

end


procedure DoDocumentComplete(c onst pDisp: IDispatch
var URL: OleVariant)

begin

end


procedure DoOnQuit

begin

end


procedure DoOnVisible(Visible: WordBool)

begin

end


procedure DoOnToolBar(ToolBar: WordBool)

begin

end


procedure DoOnMenuBar(MenuBar: WordBool)

begin

end


procedure DoOnStatusBar(StatusBar: WordBool)

begin

end


procedure DoOnFullScreen(FullScreen: WordBool)

begin

end


procedure DoOnTheaterMode(TheaterMode: WordBool)

begin

end



procedure BuildPositionalDispIds(pDispIds: PDispIdList
c onst dps: TDispParams)

var
i: integer

begin
Assert(pDispIds <> nil)

for i := 0 to dps.cArgs - 1 do
pDispIds^ := dps.cArgs - 1 - i

if (dps.cNamedArgs <= 0) then Exit

for i := 0 to dps.cNamedArgs - 1 do
pDispIds^[dps.rgdispidNamedArgs^[I := i

end


function TIEHelper.Invoke(DispID: Integer
c onst IID: TGUID
LocaleID: Integer

Flags: Word
var Params
VarResult, ExcepInfo, ArgErr: Pointer): HResult

type
POleVariant = ^OleVariant

var
dps: TDispParams absolute Params

bHasParams: boolean

pDispIds: PDispIdList

iDispIdsSize: integer

begin
Result := DISP_E_MEMBERNOTFOUND

pDispIds := nil

iDispIdsSize := 0

bHasParams := (dps.cArgs > 0)

if (bHasParams) then
begin
iDispIdsSize := dps.cArgs * SizeOf(TDispId)

GetMem(pDispIds, iDispIdsSize)

end

try
if (bHasParams) then BuildPositionalDispIds(pDispIds, dps)

case DispId of
102:
begin
DoStatusTextChange(dps.rgvarg^[pDispIds^[0].bstrval)

Result := S_OK

end

108:
begin
DoProgressChange(dps.rgvarg^[pDispIds^[0].lval, dps.rgvarg^[pDispIds^[1].lval)

Result := S_OK

end

105:
begin
DoCommandStateChange(dps.rgvarg^[pDispIds^[0].lval, dps.rgvarg^[pDispIds^[1].vbool)

Result := S_OK

end

106:
begin
DoDownloadBegin()

Result := S_OK

end

104:
begin
DoDownloadComplete()

Result := S_OK

end

113:
begin
DoTitleChange(dps.rgvarg^[pDispIds^[0].bstrval)

Result := S_OK

end

112:
begin
DoPropertyChange(dps.rgvarg^[pDispIds^[0].bstrval)

Result := S_OK

end

250:
begin
DoBeforeNavigate2(IDispatch(dps.rgvarg^[pDispIds^[0].dispval), POleVariant(dps.rgvarg^[pDispIds^[1].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[2].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[3].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[4].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[5].pvarval)^, dps.rgvarg^[pDispIds^[6].pbool^)

Result := S_OK

end

251:
begin
DoNewWindow2(IDispatch(dps.rgvarg^[pDispIds^[0].pdispval^), dps.rgvarg^[pDispIds^[1].pbool^)

Result := S_OK

end

252:
begin
DoNavigateComplete2(IDispatch(dps.rgvarg^[pDispIds^[0].dispval), POleVariant(dps.rgvarg^[pDispIds^[1].pvarval)^)

Result := S_OK

end

259:
begin
DoDocumentComplete(IDispatch(dps.rgvarg^[pDispIds^[0].dispval), POleVariant(dps.rgvarg^[pDispIds^[1].pvarval)^)

Result := S_OK

end

253:
begin
DoOnQuit()

Result := S_OK

end

254:
begin
DoOnVisible(dps.rgvarg^[pDispIds^[0].vbool)

Result := S_OK

end

255:
begin
DoOnToolBar(dps.rgvarg^[pDispIds^[0].vbool)

Result := S_OK

end

256:
begin
DoOnMenuBar(dps.rgvarg^[pDispIds^[0].vbool)

Result := S_OK

end

257:
begin
DoOnStatusBar(dps.rgvarg^[pDispIds^[0].vbool)

Result := S_OK

end

258:
begin
DoOnFullScreen(dps.rgvarg^[pDispIds^[0].vbool)

Result := S_OK

end

260:
begin
DoOnTheaterMode(dps.rgvarg^[pDispIds^[0].vbool)

Result := S_OK

end

end

finally
if (bHasParams) then FreeMem(pDispIds, iDispIdsSize)

end

end



function TIEHelper.GetIDsOfNames(c onst IID: TGUID
Names: Pointer

NameCount, LocaleID: Integer
DispIDs: Pointer): HResult

begin
Result := E_NOTIMPL

end


function TIEHelper.GetTypeInfo(Index, LocaleID: Integer

out TypeInfo): HResult

begin
Result := E_NOTIMPL

pointer(TypeInfo) := nil

end


function TIEHelper.GetTypeInfoCount(out Count: Integer): HResult

begin
Result := E_NOTIMPL

Count := 0

end



function TIEHelper.GetSite(c onst riid: TIID
out site: IUnknown): HResult

begin
// Result := S_OK

if Assigned(IE) then result:=IE.QueryInterface(riid, site)
else
Result:= E_FAIL

end


function TIEHelper.SetSite(c onst pUnkSite: IUnknown): HResult

var
cmdTarget: IOleCommandTarget

Sp: IServiceProvider

CPC: Ic onnectionPointc ontainer

CP: Ic onnectionPoint

begin
if Assigned(pUnkSite) then begin
cmdTarget := pUnkSite as IOleCommandTarget

Sp := CmdTarget as IServiceProvider


if Assigned(Sp)then
Sp.QueryService(IWebbrowserApp, IWebbrowser2, IE)

if Assigned(IE) then begin
IE.QueryInterface(Ic onnectionPointc ontainer, CPC)

CPC.Findc onnectionPoint(DWEBbrowserEvents2, CP)

CP.Advise(Self, Cookie)
end

end

Result := S_OK

end



procedure TIEHelperFactory.AddKeys

var S: string

begin
S := GUIDToString(CLASS_IEHelper)

with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE

if OpenKey('Software/Microsoft/Windows/CurrentVersion/explorer/Browser Helper Objects/' + S, TRUE)
then CloseKey

finally
free

end

end


procedure TIEHelperFactory.RemoveKeys

var S: string

begin
S := GUIDToString(CLASS_IEHelper)

with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE

DeleteKey('Software/Microsoft/Windows/CurrentVersion/explorer/Browser Helper Objects/' + S)

finally
free

end

end


procedure TIEHelperFactory.UpdateRegistry(Register: Boolean)

begin
inherited UpdateRegistry(Register)

if Register then AddKeys else RemoveKeys

end


initialization
TIEHelperFactory.Create(ComServer, TIEHelper, Class_IEHelper,
'IEHelper', '', ciMultiInstance, tmApartment)

end.

代码很长，但是关键的是TIEHelper.SetSite方法以及TIEHelper.Invoke方法。在TIEHelper.SetSite方法中注意以下语句：
if Assigned(Sp)then
Sp.QueryService(IWebbrowserApp, IWebbrowser2, IE)

if Assigned(IE) then begin
IE.QueryInterface(Ic onnectionPointc ontainer, CPC)

CPC.Findc onnectionPoint(DWEBbrowserEvents2, CP)

CP.Advise(Self, Cookie)

上面的语句作用是，首先获得IE的Webbrowser接口，然后寻找到连接点。并通过Advise方法建立COM自身与连接点的连接。
当连接建立成功后，IE在有事件引发后，会调用连接到自身的IDispatch接口对象的Invoke方法。不同的事件对应不同的DispID编码，我们可以在程序中判断DispID并做相应的处理。在上面的程序中，我们只处理了BeforeNavigate2 事件，处理函数是DoBeforeNavigate2，在该函数中，如果浏览的站点不是'http://www.applevb.com/&amp;#39;的话，程序会提示：'你不可以浏览其它站点'并强行转到http://www.applevb.com。
很多的软件，象“护花使者”以及“3721”一类的中文网址”都是利用上面的原理来实现对IE浏览器事件响应的，例如3721，当用户输入一个中文词并浏览时，COM组件可以在BeforeNavigate2 事件中编写代码访问服务器并转到正确的站点上去。

 
这个程序有很多错误~ 除了 c onst 外 还有个 某变量不是 数字却与数字操作的错误。

不知道是否有人真的正确执行了程序。盼有原代码，最好是zip的。
 
程序没问题，我调试通过了。不过跟我的要求还有点距离的。
 
默认搜索页改成自己的主页不就行了
 
不太懂你的意思，能不能具体一点。

还有，当你的电脑里安装了3721之后，用windows.net的方法已经截不能用户输入的URL地址。3721好像做了手脚。
 
3721 太恶心了
 
BHO是可以做到的！
 
向各位学习！
 
您必须登录或注册才可回复。

Similar threads

Ray
[转]终于可以发布Delphi下收点OSGI精髓皮毛而设计的插件框架WisdomPluginFramework
回复
4
查看
5K
chlkuei
C
小
能被vbscript在客户端的网页中调用的组件，怎么编写呀？？？就像3721的上网助手一样。。 (100分)
回复
4
查看
228
小海
小
S
我终于远离了网络实名（3721）的烦恼。(300分)
2
回复
31
查看
439
wsn
W
1
给点思路就有分啊~(200分)
回复
16
查看
375
119110
1
G
想做一个EMAIL收集器，请大家给点思路！(100分)
回复
7
查看
106
gmc001
G
后退
顶部