兼懂Delphi和VB的高手请进：这段程序怎样翻译成VB？
下面就是一个例子展示如何从打开的Internet Explorer中取得其网页元素的HTML源代码：const
RSPSIMPLESERVICE = 1;
RSPUNREGISTERSERVICE = 0;
type
TObjectFromLResult = function(LRESULT: lResult; const IID: TIID; WPARAM: wParam; out pObject): HRESULT; stdcall;
function GetIEFromHWND(WHandle: HWND; var IE: IWebbrowser2): HRESULT;
var
hInst: HWND;
lRes: Cardinal;
MSG: Integer;
pDoc: IHTMLDocument2;
ObjectFromLresult: TObjectFromLresult;
begin
hInst := LoadLibrary('Oleacc.dll');
@ObjectFromLresult := GetProcAddress(hInst, 'ObjectFromLresult');
if @ObjectFromLresult <> nil then
begin
try
MSG := RegisterWindowMessage('WM_HTML_GETOBJECT');
SendMessageTimeOut(WHandle, MSG, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes);
Result := ObjectFromLresult(lRes, IHTMLDocument2, 0, pDoc);
if Result = S_OK then
(pDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp, IWebbrowser2, IE);
finally
FreeLibrary(hInst);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
All: IHtmlElementCollection;
HtmlElement: IHtmlElement;
I: Integer;
Document: IHtmlDocument2;
IE: IWebBrowser2;
Wnd: HWND;
WndChild: HWND;
begin
Wnd := FindWindow('IEFrame', nil);
if Wnd = 0 then
begin
MessageDlg('No Running instance of Internet Explorer!', mtError, [mbOK], 0);
end;
// walk Shell DocObject View->Internet Explorer_Server
WndChild := FindWindowEX(Wnd, 0, 'Shell DocObject View', nil);
if WndChild <> 0 then
begin
WndChild := FindWindowEX(WndChild, 0, 'Internet Explorer_Server', nil);
if WndChild <> 0 then
begin
GetIEFromHWnd(WndChild, IE); //Get Iwebbrowser2 from Handle
Document := IE.Document as IHtmlDocument2;
if Assigned(Document) then
begin
All := Document.All;
for I := 0 to All.Length - 1 do
begin
HtmlElement := All.item(i, 0) as IhtmlElement;
SourceView.Lines.Add(IntToStr(i) + ' ' + HTmlElement.innerHTML);
end;
end;
end;
end;
end; --------------------编程问答-------------------- 找僵哥吧 --------------------编程问答--------------------
你有他的联系方法吗？ --------------------编程问答-------------------- http://www.evget.com/zh-CN/Info/ReadInfo.aspx?id=8728
这个有用吗？ --------------------编程问答-------------------- 看看这个是否有用：
Private Sub Command1_Click()
Dim oShellApp As Object
Dim oShellWindows As Object
Dim oWindow As Object
Dim oDocument As Object
Set oShellApp = CreateObject("Shell.Application")
Set oShellWindows = oShellApp.Windows
For Each oWindow In oShellWindows
Set oDocument = oWindow.Document
If LCase$(TypeName(oDocument)) = "htmldocument" Then
Text1.Text = oDocument.documentElement.outerHTML
End If
Next
End Sub
--------------------编程问答--------------------
[email=unsigned@126.com][/email]
这个僵哥的电邮 --------------------编程问答--------------------
不能用ShellWindows对象读取的，因为这个对象在普通用户权限下没法创建 --------------------编程问答-------------------- 再试试这个：
引用 Microsoft Internet Controls
Private Sub Command1_Click()
Dim oShellWindows As ShellWindows
Dim oWindow As Object
Dim oDocument As Object
Set oShellWindows = New ShellWindows
For Each oWindow In oShellWindows
Set oDocument = oWindow.Document
If LCase$(TypeName(oDocument)) = "htmldocument" Then
Text1.Text = oDocument.documentElement.outerHTML
End If
Next
End Sub --------------------编程问答-------------------- ding --------------------编程问答-------------------- Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" ( _
ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" ( _
ByVal hWndParent As Long, _
ByVal lpEnumFunc As Long, _
lParam As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" _
Alias "RegisterWindowMessageA" ( _
ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" _
Alias "SendMessageTimeoutA" ( _
ByVal hwnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
lParam As Any, _
ByVal fuFlags As Long, _
ByVal uTimeout As Long, _
lpdwResult As Long) As Long
Private Const SMTO_ABORTIFHUNG = &H2
Private Declare Function ObjectFromLresult Lib "oleacc" ( _
ByVal lResult As Long, _
riid As UUID, _
ByVal wParam As Long, _
ppvObject As Any) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Function IEDOMFromhWnd(ByVal hwnd As Long) As IHTMLDocument
Dim IID_IHTMLDocument As UUID
Dim hWndChild As Long
Dim lRes As Long
Dim lMsg As Long
Dim hr As Long
If hwnd <> 0 Then
If Not IsIEServerWindow(hwnd) Then
' Find a child IE server window
EnumChildWindows hwnd, AddressOf EnumChildProc, hwnd
End If
If hwnd <> 0 Then
' Register the message
lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
' Get the object pointer
Call SendMessageTimeout(hwnd, lMsg, 0, 0, _
SMTO_ABORTIFHUNG, 1000, lRes)
If lRes Then
' Initialize the interface ID
With IID_IHTMLDocument
.Data1 = &H626FC520
.Data2 = &HA41E
.Data3 = &H11CF
.Data4(0) = &HA7
.Data4(1) = &H31
.Data4(2) = &H0
.Data4(3) = &HA0
.Data4(4) = &HC9
.Data4(5) = &H8
.Data4(6) = &H26
.Data4(7) = &H37
End With
' Get the object from lRes
hr = ObjectFromLresult(lRes, IID_IHTMLDocument, _
0, IEDOMFromhWnd)
End If
End If
End If
End Function
Private Function IsIEServerWindow(ByVal hwnd As Long) As Boolean
Dim lRes As Long
Dim sClassName As String
' Initialize the buffer
sClassName = String$(100, 0)
' Get the window class name
lRes = GetClassName(hwnd, sClassName, Len(sClassName))
sClassName = Left$(sClassName, lRes)
IsIEServerWindow = StrComp(sClassName, _
"Internet Explorer_Server", _
vbTextCompare) = 0
End Function
'
' Copy this function to a .bas module
'
Function EnumChildProc(ByVal hwnd As Long, lParam As Long) As Long
If IsIEServerWindow(hwnd) Then
lParam = hwnd
Else
EnumChildProc = 1
End If
End Function
--------------------编程问答-------------------- 学习中,顶 --------------------编程问答-------------------- http://www.omgili.com/newsgroups/microsoft/public/vb/winapi/ORcaabDJHA3668TK2MSFTNGP05phxgbl.html&q=+Roll+your+own+VB6+server... --------------------编程问答--------------------
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Long) As Long--------------------编程问答-------------------- 注意把mshtml.tlb添加进工程当中（project->References...） --------------------编程问答-------------------- 僵哥果然不同凡响，哈哈~俺来蹭分的 --------------------编程问答-------------------- 我挖
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Const SMTO_ABORTIFHUNG = &H2
Private Declare Function RegisterWindowMessage Lib "user32" Alias _
"RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias _
"SendMessageTimeoutA" (ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam _
As Long, lParam As Any, ByVal fuFlags As Long, ByVal uTimeout As Long, _
lpdwResult As Long) As Long
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As _
Long, riid As UUID, ByVal wParam As Long, ppvObject As Any) As Long
Private Sub Command1_Click()
Dim Wnd As Long
Dim WndChild As Long
Dim IE As Object
Dim MSG As Long
Dim OLEResult As Long
Dim IID_IHTMLDocument2 As UUID
Dim HTMLDoc As IHTMLDocument2
Dim Element As IHTMLElement
Dim HtmlText() As String
Dim I As Long
With IID_IHTMLDocument2
.Data1 = &H332C4425
.Data2 = &H26CB
.Data3 = &H11D0
.Data4(0) = &HB4
.Data4(1) = &H83
.Data4(2) = &H0
.Data4(3) = &HC0
.Data4(4) = &H4F
.Data4(5) = &HD9
.Data4(6) = &H1
.Data4(7) = &H19
End With
Wnd = FindWindow(ByVal "IEFrame", ByVal 0&)
If Wnd = 0 Then
MsgBox "No Running instance of Internet Explorer!", vbOKOnly + vbCritical
Exit Sub
End If
'IE7
WndChild = FindWindowEx(ByVal Wnd, ByVal 0&, ByVal "TabWindowClass", ByVal 0&)
If WndChild <> 0 Then Wnd = WndChild
WndChild = FindWindowEx(ByVal Wnd, ByVal 0&, ByVal "Shell DocObject View", ByVal 0&)
If WndChild = 0 Then Exit Sub
WndChild = FindWindowEx(ByVal WndChild, ByVal 0&, ByVal "Internet Explorer_Server", ByVal 0&)
If WndChild = 0 Then Exit Sub
MSG = RegisterWindowMessage(ByVal "WM_HTML_GETOBJECT")
Call SendMessageTimeout(ByVal WndChild, ByVal MSG, ByVal 0&, ByVal 0&, ByVal SMTO_ABORTIFHUNG, ByVal 1000, lRes)
OLEResult = ObjectFromLresult(ByVal lRes, IID_IHTMLDocument2, ByVal 0&, HTMLDoc)
If OLEResult <> 0 Then Exit Sub
ReDim HtmlText(HTMLDoc.All.length - 1)
For I = 0 To HTMLDoc.All.length - 1
HtmlText(I) = HTMLDoc.All(I, 0).innerHTML
Next
Text1.Text = Join(HtmlText, vbCrLf)
End Sub
补充：VB , 网络编程
