Excel VBA automation: Download data from Internet Explorer

'//
'// HTMLDocInterface.bas
'//
 
Option Explicit
 
Private Const Module_HTMLDocInterface As String = "HTMLDocInterface"
 
' You may freely use and or distribute this module so long as the header
' content is included. This also applies to posting to any online source,
' whether via attatchment or source code. This includes the following.
' Author, Date, Contact , Version and support information.
 
' You may contact me if you have any suggestions.
' ===============================================
' Author    :   EGL
' Date      :   Aug 01 2009
' Contact   :   egl1044@gmail.com
' Version   :   1.0
' ===============================================
' Supports  :
' ===============================================
'             Internet Explorer 4.0 +
'             Windows 2000
'             Windows NT 4.0 with Service Pack 6
'             Windows XP
'             Windows Vista
'             Windows 7
' ===============================================
 
' User defined error.
Public Const ERROR_DOCUMENT_NOT_RUNNING As Long = (-1)
Public Const ERROR_DOCUMENT_NOT_READY As Long = (-2)
Public Const DOCUMENT_READY As Long = 200
 
' HRESULT success constant.
Private Const S_OK As Long = &H0
 
' User defined constants
Private Const CLASS_BUFFER_SIZE As Long = (512 - 1)
Private Const CLASS_IE_DOCUMENT As String = "Internet Explorer_Server"
Private Const CLASS_IE_FRAME As String = "IEFrame"
 
' SendMessageTimeout constants
Private Const SMTO_ABORTIFHUNG As Long = &H2
 
' IID_IHTMLDocument
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
 
' Windows 95, Windows NT 3.1
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
 
' Windows 95, Windows NT 3.1
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
 
' Windows 95, Windows NT 3.1
Private Declare Function GetClassNameW Lib "user32" (ByVal hWnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
 
' Windows 95, Windows NT 3.1 (Microsoft Layer for Unicode (MSLU)
Private Declare Function RegisterWindowMessageW Lib "user32" (ByVal lpString As Long) As Long
 
' Windows 95, Windows NT 3.1 (Microsoft Layer for Unicode (MSLU)
Private Declare Function SendMessageTimeoutW Lib "user32" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
 
' Windows 2000, or for Windows NT 4.0 with Service Pack 6
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As UUID, ByVal wParam As Long, ppvObject As Any) As Long
 
 
  ' The Documents() array is populated with the
  ' handles of internet explorer documents that
  ' are currently active after making a call to
  ' the EnumIEDocumentInstances() method.
  
  ' The handles within the Documents() array can be
  ' used to get a fully marshaled IHTMLDocument2 pointer
  ' by calling IHTMLDocumentPointer() method.
  
  Public Documents() As Long
  Public DocumentsCount As Long
  
  
  Private Function GetClassObjectName(ByVal lphWnd As Long) As String
  
  ' Returns the classname associated with hWnd handle.
  
    Dim Buffer(CLASS_BUFFER_SIZE) As Byte
    Dim BufferLength As Long
    
    ' Retrieves the name of the class to which the specified window belongs.
    BufferLength = GetClassNameW(lphWnd, VarPtr(Buffer(0)), CLASS_BUFFER_SIZE)
    
    If BufferLength <> 0 Then
      ' Return this as TCHAR string length.
      GetClassObjectName = Left$(Buffer, BufferLength)
      
    Else
      
      GetClassObjectName = vbNullString
      
    End If
    
    ' Free memory
    Erase Buffer
    
  End Function
  
  
  Public Function EnumIEDocumentInstances() As Long
  
  ' NOTE: The Documents() array is zero bound array.
  '       Remember that the the count value is one
  '       less when enumerating the array. Consider
  '       using LBound() and UBound() to ensure the
  '       correct bounds are consistent.
  
    ' We must reset our DocumentsCount value.
    DocumentsCount = 0
    ' Do we really need this? It shouldn't hurt.
    Erase Documents
    ' Enumerate the IEFrames and child windows of each IEFrame instance.
    EnumWindows AddressOf EnumFramesProc, 0
    
    If DocumentsCount = 0 Then
      ' Returns ERROR_DOCUMENT_NOT_RUNNING
      EnumIEDocumentInstances = ERROR_DOCUMENT_NOT_RUNNING
    Else
      ' Returns the DocumentsCount value.
      EnumIEDocumentInstances = DocumentsCount
    End If
  
  End Function
  
  
  Public Function IHTMLDocumentPointer(ByVal dwDocumenthWnd As Long, Optional ByRef dwError As Long = 0) As Object
 
  ' Returns a fully marshaled IHTMLDocument2 pointer.
  
  ' ERROR_DOCUMENT_NOT_RUNNING    ::: Internet Explorer not running
  ' ERROR_DOCUMENT_NOT_READY      ::: Document not ready
  ' DOCUMENT_READY                ::: Document ready
  
    Dim IID_IHTMLDocument As UUID
    
    Dim Message As Long
    Dim Success As Long
    Dim lpResult As Long
    Dim hr As Long
    
    Message = RegisterWindowMessageW(StrPtr("WM_HTML_GETOBJECT"))
    
    If Message <> 0 Then
    
    ' The message is successfully registered.
    
    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
    
    Success = SendMessageTimeoutW(dwDocumenthWnd, Message, 0, 0, SMTO_ABORTIFHUNG, 1000, lpResult)
    
      If Success <> 0 Then
      
        hr = ObjectFromLresult(lpResult, IID_IHTMLDocument, 0, IHTMLDocumentPointer)
        
          If hr = S_OK Then
          
            ' document ready.
            dwError = DOCUMENT_READY
            
          Else
          
            ' document not ready.
            dwError = ERROR_DOCUMENT_NOT_READY
            
          End If
        
        
      Else
    
      ' Internet Explorer is not running.
      dwError = ERROR_DOCUMENT_NOT_RUNNING
    
      
      End If
    
    
    Else
    
    ' The message failed to register.
    dwError = ERROR_DOCUMENT_NOT_READY
    
    End If
  
  
  End Function
  
 
  
  ' EnumWindows:::EnumWindowsProc
  Public Function EnumFramesProc(ByVal hWnd As Long, ByVal lParam As Long) As Boolean
    
  
    If StrComp(GetClassObjectName(hWnd), CLASS_IE_FRAME, vbTextCompare) = 0 Then
      ' We found an instance of "IEFrame" class.
      ' Enumerates the child windows that belong to the parent window.
      EnumChildWindows hWnd, AddressOf EnumDocumentsProc, 0
      
    End If
 
    ' push enumeration.
    EnumFramesProc = True
  
  
  
  End Function
 
 
 
 
  ' EnumChildWindows:::EnumChildProc
  Public Function EnumDocumentsProc(ByVal hWnd As Long, ByVal lParam As Long) As Boolean
    
 
    If StrComp(GetClassObjectName(hWnd), CLASS_IE_DOCUMENT, vbTextCompare) = 0 Then
      ' We found an instance of "Internet Explorer_Server" class.
      ' Redimension to DocumentsCount value.
      ReDim Preserve Documents(DocumentsCount) As Long
      ' Add the hWnd to our Documents array.
      Documents(DocumentsCount) = hWnd
      ' Increment the DocumentsCount value.
      DocumentsCount = (DocumentsCount + 1)
      
    End If
    
    ' push enumeration.
    EnumDocumentsProc = True
  
  
  
  End Function
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
'//
'// example usage
'//
 
Option Explicit
 
' Reference Microsoft HTML Object Library.
Dim HTMLDoc As HTMLDocument
 
Private Sub Command1_Click()
  
  Dim IEInstance As Long
 
  ' Returns ERROR_DOCUMENT_NOT_RUNNING, If Internet Explorer is not running.
  If EnumIEDocumentInstances <> ERROR_DOCUMENT_NOT_RUNNING Then
 
    For IEInstance = LBound(Documents) To UBound(Documents)
 
     Set HTMLDoc = IHTMLDocumentPointer(Documents(IEInstance))
      
      '// do something with document(s).
      Debug.Print HTMLDoc.url
      
     Set HTMLDoc = Nothing
     
    Next IEInstance
    
  Else
  
    Debug.Print "Internet Explorer is not running"
    
  End If
  
End Sub
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316: