如何监视在浏览器组件(如TwebBrowser)中的选中动作? (200分)

  • 主题发起人 主题发起人 千中元
  • 开始时间 开始时间

千中元

Unregistered / Unconfirmed
GUEST, unregistred user!
例如IE,如在一个网页上选中,则IE菜单的 "编辑---> 复制" 可以使用,反之则不能使用.

另外在IE显示的网页内某url上点击右键,如何取得该链接?(另200分赠送)
 
>取得该链接
可以参考一下http://www.delphibbs.com/delphibbs/dispq.asp?lid=0940110
但你至少要点击一下右键菜单。

 
2: 这个应该用到外壳扩展吧,你看一下 ContexMenu 相关的资料。
你看看 JetCar 是怎么干的。以下独立保存为一个文件,然后应该在注册表里面
关联它(用 外壳扩展)。不过我不会:)

<script language="VBScript">
'Great thanks to Vladimir Romanov(Author of ReGet Pro)
'Download selected link

Sub AddLink(Url,Info)
On Error Resume Next
set JetCarCatch=CreateObject("JetCar.Netscape")
if err<>0 then
MsgBox("FlashGet not properly installed!"+ vbCrLf+"Please install FlashGet again")
else
call JetCarCatch.AddUrl(Url, Info, external.menuArguments.document.Url)
end if
end sub

Sub OnContextMenu()
set srcEvent = external.menuArguments.event
set EventElement = external.menuArguments.document.elementFromPoint ( srcEvent.clientX, srcEvent.clientY )
if srcEvent.type = "MenuExtAnchor" then
set srcAnchor = EventElement
do until TypeName(srcAnchor)="HTMLAnchorElement"
set srcAnchor=srcAnchor.parentElement
Loop
Call AddLink(srcAnchor.href,srcAnchor.innerText)
elseif srcEvent.type="MenuExtImage" then
if TypeName(EventElement)="HTMLAreaElement" then
Call AddLink(EventElement.href,EventElement.Alt)
else
set srcImage = EventElement
set srcAnchor = srcImage.parentElement
do until TypeName(srcAnchor)="HTMLAnchorElement"
set srcAnchor=srcAnchor.parentElement
if TypeName(srcAnchor)="Nothing" then
call AddLink(srcImage.href,srcImage.Alt)
exit sub
end if
Loop
Call AddLink(srcAnchor.href,srcImage.Alt)
end if
elseif srcEvent.type="MenuExtUnknown" then
set srcAnchor = EventElement
do until TypeName(srcAnchor)="HTMLAnchorElement"
set srcAnchor=srcAnchor.parentElement
if TypeName(srcAnchor)="Nothing" then
Call AddLink(EventElement.href,EventElement.innerText)
exit sub
end if
Loop
Call AddLink(srcAnchor.href,srcAnchor.innerText)
elseif 1=1 then
MsgBox("Unknown Event Source """ + srcEvent.type + """" + vbCrLf + "Please send description of error to jetcar@163.net")
end if
end sub


call OnContextMenu()

</script>
 
2下午已经完成. 以前做过类似的一个,时间太久居然给忘了...[:(]

beta,
刚才还想到qq上给你发消息让你看看问题 1 ,我打开大富翁复制这个问题的快捷方式的时候
发现你回答了.呵呵,再一看,回答的是2
 
可以做到的:
procedure TForm1.Timer1Timer(Sender: TObject);
var
doc:IHTMLdocument2;
R:IHTMLTxtRange;
begin

try
doc :=IHTMLdocument2(webbrowser1.Document) ;
if doc = nil then exit;
R :=IHTMLTxtRange(doc.selection.createRange);
if R.Get_text <> '' then Caption := (R.Get_text);
except beep;
end;
end;
 
[red][/red]
 
后退
顶部