by jjo (5 Submissions)
Category: Internet/HTML
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 21st July 2004
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
How to use ShellWindows to get access to the HTML document in every instance of Internet Explorer (or Explorer or Mozilla). Uses a listbox to
API Declarations
' number of things:
'
' 1)
' Add the CWinInet_URL class to your project. You can
' find it here:
' http://www.vbip.com/wininet/wininet_url_class_01.asp
' It is used to combine a relative path and a base href.
' If you cant find it there is many variations found out
' there. Look for "CombineUrl", "CrackUrl" or the like
' on the internet.
'
' 2)
' Make a reference to shdovw.dll (MS internet controls)
' and mshtml.tlb (MS HMTL Object Library)
'
' 3)
' Drop three command buttons and listbox onto a form.
' Remember to set the listbox sorted!!!
' Declarations
Option Explicit
Option Compare Text
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const LB_ERR = -1
Private Const LB_ADDSTRING = &H180
Private Const LB_FINDSTRINGEXACT = &H1A2
Private stop_ As Boolean
Private line_ As String
Private pathToBrowser As String
Private Const APP_TITLE = "LINKCATALOGUE"
Private Const LB_NOT_FOUND = LB_ERR
VBcoders
Public Sub getBrowsers()
Debug.Print line_
Debug.Print "| getBrowsers"
Dim sw As New shdocvw.ShellWindows
Dim w As New InternetExplorer
Dim hd As HTMLDocument
Dim hd2 As IHTMLDocument2
Dim pathToBrowser As String, s As String
Dim i As Integer, n As Long, newCount As Long
Dim b As Boolean, hwnds() As Long
b = False
n = List1.ListCount
On Error Resume Next
For i = 0 To sw.Count - 1 Step 1
On Error Resume Next
Debug.Print "| sw.item("; i; "): "; TypeName(sw.Item(i))
If TypeOf sw.Item(i) Is IWebBrowser2 Then
Set w = sw.Item(i)
Debug.Print "| found a browser: "; w.FullName
If (TypeName(w.document) <> "Nothing") Then
'--------------------------------------------------
' ms explorer
'--------------------------------------------------
'If TypeOf w.document Is IShellFolderViewDual2 Then
'End If
'--------------------------------------------------
' ms internet explorer
'--------------------------------------------------
If TypeName(w.document) = "HTMLDocument" Or _
TypeName(w.document) = "IHTMLDocument2" Then
getAll w.document
End If
Else
Debug.Print "| no document "
Debug.Print line_
End If
Set w = Nothing
Else
Debug.Print TypeName(sw.Item(i))
End If
Next
Set sw = Nothing
newCount = List1.ListCount
Debug.Print line_; vbNewLine; line_
Debug.Print "| "; newCount - n; " new items found "
Debug.Print line_;
End Sub
Public Sub getAll(ByVal hd As HTMLDocument)
On Error Resume Next
Debug.Print line_
Debug.Print "| getAll from ", hd.URL
Debug.Print "| url uenc : ", hd.URLUnencoded
Debug.Print "| readyState: ", hd.readyState
Debug.Print "| title : ", hd.Title
Debug.Print "| referrer : ", hd.referrer
Debug.Print "| mimeType : ", hd.mimeType
Debug.Print "| hd.location {"
Debug.Print "| protocol: ", hd.location.protocol
Debug.Print "| hostname: ", hd.location.HostName
Debug.Print "| port : ", hd.location.Port
Debug.Print "| pathname: ", hd.location.pathname
Debug.Print "| }"
Debug.Print "| hd.collections {"
Debug.Print "| all : ", hd.All.length
Debug.Print "| anchors : ", hd.anchors.length
Debug.Print "| applets : ", hd.applets.length
Debug.Print "| images : ", hd.images.length
Debug.Print "| embeds : ", hd.embeds.length
Debug.Print "| frames : ", hd.frames.length
Debug.Print "| links : ", hd.links.length
Debug.Print "| scripts : ", hd.scripts.length
Debug.Print "| styles : ", hd.styleSheets.length
Debug.Print "| }"
Debug.Print "| hd.body {"
Debug.Print "| classnm : ", hd.body.className
Debug.Print "| filters : ", hd.body.filters.length
Debug.Print "| id : ", hd.body.id
Debug.Print "| lang : ", hd.body.lang
Debug.Print "| language: ", hd.body.language
Debug.Print "| cssText : ", hd.body.Style.cssText
Debug.Print "| }"
Err.Clear
Dim s As String, b As Boolean, i As Integer
s = hd.location.href
dumpItem s, hd
On Error Resume Next
s = CStr(hd.mimeType)
Caption = APP_TITLE & " : " & s
Select Case s
Case "JPEG Image", "GIF Image": getImages hd
Case Else
If hd.links.length Then getLinks hd
If hd.anchors.length Then getAnchors hd
If hd.applets.length Then getApplets hd
If hd.images.length Then getImages hd
If hd.embeds.length Then getEmbeds hd
If hd.plugins.length Then getPlugins hd
If hd.getElementsByTagName("BUTTON").length Or _
hd.getElementsByTagName("OPTION").length Or _
hd.getElementsByTagName("INPUT").length Then
getForms hd
End If
If hd.scripts.length Then getScripts hd
If hd.frames.length Then getFrames hd
End Select
Caption = APP_TITLE
End Sub
Public Sub getApplets(hd As HTMLDocument)
Debug.Print "+------------+"
Debug.Print "| getApplets |_____"
Debug.Print "| hd.applets.length: "; hd.applets.length; "|"
If hd.applets.length Then
Dim em As HTMLObjectElement, c As HTMLElementCollection
Dim cw As New CWinInet_URL, s As String
Set cw = New CWinInet_URL
For Each em In hd.applets
dumpItem em.code, hd
dumpItem em.codeBase, hd
dumpItem em.BaseHref, hd
getEvents em, hd
Next
End If
End Sub
Public Sub getFrames(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getFrames, frames.length: "; hd.frames.length
If hd.frames.length Then
Dim i As Integer
For i = 0 To hd.frames.length - 1
Debug.Print "| frames["; i; "]: TypeName: "; TypeName(hd.frames.Item(i))
Select Case TypeName(hd.frames.Item(i))
Case "HTMLDocument": getAll hd.frames.Item(i)
Case "HTMLWindow2": getAll hd.frames.Item(i).document
End Select
Next
Else
Debug.Print String(Len(line_), "?")
Debug.Print line_
End If ' frames . length
End Sub
Private Sub getAnchors(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getAnchors"
If hd.anchors.length Then
Debug.Print "| anchors.length: "; hd.anchors.length
Dim i As Long
For i = 0 To hd.anchors.length - 1
dumpItem CStr(hd.anchors.Item(i).href), hd
getEvents hd.anchors.Item(i), hd
Next
End If
End Sub
Public Sub getLinks(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getLinks"
Dim ec As HTMLElementCollection
Dim ae As HTMLAnchorElement, i As Integer
Dim s As String
If hd.links.length Then
Debug.Print "| links.length: "; hd.links.length
i = 0
While i < hd.links.length
Set ae = hd.links.Item(i)
dumpItem CStr(ae.href), hd
getEvents ae, hd
i = i + 1
If i Mod 20 = 0 Then DoEvents
Wend
Set ae = Nothing
End If ' length
''''''''''''''''''''''''''''
'PARAM
''''''''''''''''''''''''''''
Set ec = hd.All.tags("PARAM")
If ec.length Then
Debug.Print "| ""param"".length: " & ec.length
Dim pc As HTMLParamElement
i = 0
While i < ec.length And Not stop_
Set pc = ec.Item(i)
If TypeName(pc.Value) = "String" Then
s = CStr(pc.Value)
If (Left(s, 1) <> "#") And (s Like "*?.?*") Then
dumpItem s, hd
getEvents pc, hd
End If
End If
i = i + 1
If i Mod 20 = 0 Then DoEvents
Wend
Set pc = Nothing
End If
''''''''''''''''''''''''''''
'LINK
''''''''''''''''''''''''''''
Set ec = hd.All.tags("LINK")
If ec.length Then
Debug.Print "| ""link"".length: " & ec.length
Dim lk As HTMLLinkElement
i = 0
While i < ec.length
Set lk = ec.Item(i)
s = CStr(lk.href)
dumpItem s, hd
getEvents lk, hd
i = i + 1
If i Mod 20 = 0 Then DoEvents
Wend
Set lk = Nothing
End If
''''''''''''''''''''''''''''
'SCRIPT
''''''''''''''''''''''''''''
Set ec = hd.All.tags("SCRIPT")
If ec.length Then
Debug.Print "| ""script"".length: " & ec.length
Dim sc As HTMLScriptElement
i = 0
While i < ec.length
Set sc = ec.Item(i)
dumpItem CStr(sc.src), hd
getEvents sc, hd
i = i + 1
If i Mod 20 = 0 Then DoEvents
Wend
Set sc = Nothing
End If
''''''''''''''''''''''''''''
'AREA
''''''''''''''''''''''''''''
Set ec = hd.All.tags("AREA")
If ec.length Then
Debug.Print "| ""area"".length: "; ec.length
Dim ar As HTMLAreaElement
While i < ec.length
Set ar = ec.Item(i)
s = CStr(ar.href)
dumpItem s, hd
getEvents ar, hd
i = i + 1
If i Mod 20 = 0 Then DoEvents
Wend
Set ar = Nothing
End If
Set ec = Nothing
Caption = APP_TITLE
End Sub
Public Sub getEmbeds(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getEmbeds"
If hd.embeds.length Then
Debug.Print "| embeds.length: "; hd.embeds.length
Dim em As HTMLEmbed, s As String
For Each em In hd.embeds
s = CStr(em.src)
dumpItem s, hd
getEvents em, hd
Next
Set em = Nothing
End If
End Sub
Public Sub getEvents(ue, hd As HTMLDocument)
Static prevUE
If Not ue <> prevUE Then
Debug.Print line_
Debug.Print "| getEvents"
Debug.Print "| "; TypeName(ue)
Dim s As String
Dim n As Integer
For n = 0 To 2
s = ""
On Error Resume Next
Select Case n
Case 0: s = ue.getAttribute("onclick")
Case 1: s = ue.getAttribute("ondblclick")
Case 2: s = ue.getAttribute("onblur")
'
'
End Select
If Len(s) Then
dumpItem s, hd
Set prevUE = ue
End If
Next
End If
End Sub
Public Sub getImages(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getImages"
If hd.images.length Then
Debug.Print "| images.length: "; hd.images.length
Dim im As HTMLImg, i As Integer
For Each im In hd.images
With im
If Len(.src) Then dumpItem .src, hd
If Len(.lowsrc) Then dumpItem .lowsrc, hd
If Len(.dynsrc) Then dumpItem .dynsrc, hd
getEvents im, hd
End With
i = i + 1
If i Mod 20 = 0 Then DoEvents
Next
Set im = Nothing
End If
End Sub
Public Sub getPlugins(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getPlugins"
If hd.plugins.length Then
Debug.Print "| hd.plugins.length: " & hd.plugins.length
Dim em As HTMLEmbed
For Each em In hd.plugins
dumpItem CStr(em.src), hd
getEvents em, hd
Next
End If
End Sub
Public Sub getScripts(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getscripts |"
If hd.scripts.length Then
Debug.Print "| hd.scripts.length: " & hd.scripts.length
Dim em As HTMLScriptElement
For Each em In hd.scripts
dumpItem CStr(em.src), hd
getEvents em, hd
Next
End If
End Sub
Public Sub getForms(hd As HTMLDocument)
Debug.Print line_
Debug.Print "| getForms"
Dim components
Dim oe As HTMLOptionElement
Dim ie As HTMLInputElement
Dim bt As HTMLButtonElement
Dim b As Boolean
Dim c As Boolean
Dim s As String
Set components = hd.All.tags("OPTION")
Debug.Print "| ""options"".length : "; components.length
For Each oe In components
dumpItem CStr(oe.Value), hd
getEvents oe, hd
Next
Set oe = Nothing
Set components = hd.All.tags("INPUT")
Debug.Print "| ""input"".length : "; components.length
For Each ie In components
dumpItem CStr(ie.Value), hd
getEvents ie, hd
Next
Set ie = Nothing
Set components = hd.All.tags("BUTTON")
Debug.Print "| ""button"".length : "; components.length
For Each bt In components
dumpItem CStr(bt.Value), hd
getEvents bt, hd
Next
Set bt = Nothing
Set components = Nothing
End Sub
' most likely to return true if a string appears
' to be a path or a file of some sort. this function
' is not using cracked urls because of getOptions
' which returns all sorts of strings - not just paths
Private Function isHref(ByVal s As String) As Boolean
'Debug.Print line_
'Debug.Print "| isHref ( "; s; ")"
Dim b As Boolean
b = (Len(s) = 0)
If Not b Then
b = ( _
(s Like "*?/?*") Or (s Like "*?\?*") Or _
(s Like "/?*") Or (s Like "*?/") Or _
(s Like "\?*") Or (s Like "*?\") Or _
(InStr(s, "%3f") < InStr(s, "%5c")) Or _
(InStr(s, "%3f") < InStr(s, "%2f")) Or _
(s Like "*?.?*" And Not s Like "\#*") _
)
End If
'Debug.Print "| returns "; b
isHref = b
End Function
Private Sub addBaseHREF(sRelativeUrl As String, srcDoc As HTMLDocument)
'Debug.Print line_
'Debug.Print "| addBasehref ("; s; ", "; srcDoc.location.href
Dim cw As New CWinInet_URL
Dim path As String, b As Boolean
With srcDoc.location
b = (Right(.pathname, 1) = "/" Or Right(.pathname, 1) = "\")
path = .protocol & "//" & .HostName & IIf(b, "/", "") & Replace(.pathname, "\", "/")
End With
sRelativeUrl = cw.CombineUrl(path, sRelativeUrl, ICU_BROWSER_MODE)
Debug.Print "| result: "; sRelativeUrl
Set cw = Nothing
End Sub
Public Function stringIndex( _
lb_hwnd As Long, strFind As String _
) As Long
stringIndex = SendMessage( _
lb_hwnd, LB_FINDSTRINGEXACT, 0&, ByVal strFind _
)
End Function
Public Sub dumpItem(ByVal s As String, hd As HTMLDocument)
On Error GoTo err_dumpItem
Dim t As String
Trim s
If Len(s) > 0 Then
If isHref(s) Then
If InStr(s, ":/") = 0 And InStr(s, ":\") = 0 Then addBaseHREF s, hd
If stringIndex(List1.hwnd, s) = LB_NOT_FOUND Then
Call SendMessage( _
List1.hwnd, LB_ADDSTRING, 0&, ByVal s _
)
End If
End If
End If
Exit Sub
err_dumpItem:
stop_ = True
debugErr Err
MsgBox Err.Description
End Sub
Private Sub debugErr(e As ErrObject)
Debug.Print line_
Debug.Print "error #"; CStr(e.Number); " {"
Debug.Print , "e.Description: ", e.Description
Debug.Print , "e.LastDllError: ", e.LastDllError
Debug.Print , "e.HelpFile: ", Err.HelpFile
Debug.Print , "e.HelpContext: ", Err.HelpContext
Debug.Print "}"
e.Clear
End Sub
'FORM CODE
Private Sub Form_Load()
line_ = "+" & String(80, "-")
ScaleMode = 1
Caption = APP_TITLE
On Error Resume Next
Icon = stdole.LoadPicture( _
"\vs6\common\Graphics\Icons\Office\CRDFLE07.ICO", _
255, 255, _
Color _
)
Err.Clear
Command1.Caption = "Search"
Command2.Caption = "Stop"
Command3.Caption = "Open"
Command1.Default = True
Command2.Cancel = True
Me.Move _
0#, 0#, _
Screen.Width * 0.5, _
(Screen.Height - 2 * Screen.TwipsPerPixelY) * 0.5
End Sub
Private Sub Form_Resize()
Dim mx As Single, my As Single
mx = 4# * Screen.TwipsPerPixelX
my = 16# * Screen.TwipsPerPixelY
On Error Resume Next
List1.Move 0#, 0#, _
Width - mx, _
Height - Command1.Height - 1.5 * my
Command1.Move mx, List1.Height + my / 8
Command2.Move Command1.Left + Command1.Width, _
List1.Height + my / 8
Command3.Move Command2.Left + Command2.Width, _
List1.Height + my / 8
Command1.ZOrder 0
End Sub
Private Sub Command1_Click()
Command1.Enabled = False
stop_ = False
getBrowsers
Command1.Enabled = True
End Sub
Private Sub Command2_Click()
stop_ = True
End Sub
Private Sub Command3_Click()
Debug.Print line_
Debug.Print "| command3_click"
Dim URL As String
URL = Trim(List1.List(List1.ListIndex))
If Len(URL) = 0 Then Exit Sub
On Error Resume Next
Dim x As New InternetExplorer
Dim hd As New HTMLDocument
Set x = New InternetExplorer
x.Visible = True
x.Navigate2 URL
Debug.Print "| url: "; URL
Do While Not (stop_ Or Err.Number)
If x.readyState = READYSTATE_COMPLETE Then Exit Do
Debug.Print "| waiting: "; Format(Time, "hh:mm:ss")
Sleep 250& ' wait for the document to load
DoEvents ' allow stop button to be clicked
Loop
If Not (stop_ Or Err.Number) Then
Set hd = x.document
Debug.Print "| mimetype: """; hd.mimeType; """"
getAll hd
Else
' you pressed stop or the window is destroyed
End If
If Err.Number Then debugErr Err
Set hd = Nothing
Set x = Nothing
End Sub
Private Sub List1_Click()
Command3.Enabled = (List1.ListCount > 0)
On Error Resume Next
List1.ToolTipText = List1.List(List1.ListIndex)
End Sub
Private Sub List1_DblClick()
If List1.ListCount Then Command3_Click
End Sub
Private Sub outputHtml(fileName As String)
Debug.Print line_
Debug.Print "| outputHTML {"
If List1.ListCount Then
Dim f As Integer, i As Integer
f = FreeFile
On Error Resume Next
Open fileName For Output As f
Print #f, "<html><head><base target=""_BLANK""></head><body><ol>"
For i = 0 To List1.ListCount - 1
Print #f, "<li><a href="""; List1.List(i); """>"; _
List1.List(i); "</a>"
Next
Print #f, "</ol></body></html>"
Close f
If Err.Number Then debugErr Err
End If
Debug.Print "| }"
End Sub
Private Sub List1_KeyUp(KeyCode As Integer, Shift As Integer)
Static isSaving As Boolean
If Not isSaving Then
Debug.Print "| List1_KeyUp("; KeyCode; Shift; ")"
If KeyCode = vbKeyS And Shift = vbCtrlMask Then
isSaving = True
outputHtml Replace(App.path & "\output.html", "\\", "\")
isSaving = False
End If
End If
End Sub
No comments have been posted about How to use ShellWindows to get access to the HTML document in every instance of Internet Explorer (. Why not be the first to post a comment about How to use ShellWindows to get access to the HTML document in every instance of Internet Explorer (.