Option Explicit
 
Dim IEApp As InternetExplorer   'Need a reference to Microsoft Internet Controls
Sub AsyncIE(ByVal URL As String)
     'URL contains the complete string to pass to IE, _
      e.g., http://www.google.com/search?q=tushar+mehta
    On Error Resume Next
    IEApp.Navigate URL
    If Err.Number <> 0 Then
     Set IEApp = Nothing
     Set IEApp = New InternetExplorer
     IEApp.Visible = True    'Some things don't work unless it's visible
     IEApp.Navigate URL
     End If
    If IEApp Is Nothing Then Exit Sub
    End Sub

 Option Explicit
Public xmlHttpRequest As MSXML2.XMLHttp 'объявляем наш объект

Sub Test()

   On Error GoTo FailedState
   'If Not xmlHttpRequest Is Nothing Then Set xmlHttpRequest = Nothing 

   Dim MyXmlHttpHandler As CXMLHTTPHandler 'объявляем обработчик 
   Dim url As String
   
   url = "http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=60760&TITLE_SEO=60760-mnogopotochnost-ili-ee-imitatsiya&MID=508807&result=edit#message508807"
   
   Set xmlHttpRequest = New MSXML2.XMLHttp 'ниже описал, что НЕЛЬЗЯ 2 сразу загружать ТОЛЬКО 1 сайт

   ' Create an instance of the wrapper class. \ Инициализируем обработчик
  Set MyXmlHttpHandler = New CXMLHTTPHandler
   MyXmlHttpHandler.Initialize xmlHttpRequest

   ' Assign the wrapper class object to onreadystatechange. \ объясняем как действовать во время загрузки - с помощью обработчика
  xmlHttpRequest.OnReadyStateChange = MyXmlHttpHandler

   ' Get the page stuff asynchronously. \ загружаем страницу
  xmlHttpRequest.Open "GET", url, True
   xmlHttpRequest.Send "" 'никаких подвисаний

   Exit Sub

FailedState:
   MsgBox Err.Number & ": " & Err.Description
End Sub

Sub MyXmlHttpHandler()
  'выполняем ЛЮБЫЕ действия после загрузки сайта, единственное не знаю как вернуться в основную процедуру делать метки? resume next?
  MsgBox xmlHttpRequest.responseText
End Sub  

Option Explicit
Dim m_xmlHttp As MSXML2.XMLHttp

Public Sub Initialize(ByRef xmlHttpRequest As MSXML2.XMLHttp)
  Set m_xmlHttp = xmlHttpRequest
End Sub

Sub OnReadyStateChange()
Debug.Print m_xmlHttp.readyState
  If m_xmlHttp.readyState = 4 Then
    If m_xmlHttp.Status = 200 Then
      MsgBox m_xmlHttp.responseText ' вот эта строка не срабатывает, но срабатывает в обработчике
    Else
      'Error happened
    End If
  End If
End Sub

Dim XMLHttpManager As New clsXMLHttpManager
Dim XMLHttpServerManager As New clsXMLHttpServerManager
Public AsyncXMLHttpResponse() As String, AsyncXMLHttpURLS() As String, PublicI As Long

Sub InicializeAsyncXMLHttp(Optional ByVal StartNumber As Long = 0)
  PublicI = StartNumber
  ReDim AsyncXMLHttpResponse(0 To PublicI)
  ReDim AsyncXMLHttpURLS(0 To PublicI)
End Sub

Sub AsyncXMLHttpGet(ByVal URL As String)
  If RECheck(URL) Then XMLHttpManager.XMLHttpCall "GET", URL, "AsyncXMLHttpProcessor"
End Sub

Sub AsyncXMLHttpServerGet(ByVal URL As String)
  If RECheck(URL) Then XMLHttpServerManager.XMLHttpCall "GET", URL, "AsyncXMLHttpProcessor"
End Sub

Sub AsyncXMLHttpProcessor(XMLHttpReq As Object, _
                          ByVal URL As String, ByVal sMsg As String)

  ReDim Preserve AsyncXMLHttpResponse(0 To PublicI + 1)
  ReDim Preserve AsyncXMLHttpURLS(0 To PublicI + 1)

  If XMLHttpReq.ResponseText <> "" Then
    AsyncXMLHttpResponse(PublicI) = XMLHttpReq.ResponseText
  Else
    AsyncXMLHttpResponse(PublicI) = "Error"
  End If

  AsyncXMLHttpURLS(PublicI) = URL
  PublicI = PublicI + 1

'  ReDim Preserve AsyncXMLHttpResponse(0 To PublicI + 1)
'  ReDim Preserve AsyncXMLHttpURLS(0 To PublicI + 1)

End Sub

 

     If LastRow(Sheets(1), 4) = 1 Then
      InicializeAsyncXMLHttp

      For I = 2 To LastRow(Sheets(1), 3)
        pi.SubAction , "Обрабатывается ссылка $index из $count", "$time"
        ReadSettings
        If I = NextI Then
          Erase AsyncXMLHttpResponse
          If Not LastRow(Sheets(1), 3) < I Then
            For K = I To I + 7
              AsyncXMLHttpGet (Cells(K, 3).Value)
              Sleep 100: DoEvents
            Next
            NextI = I + 7
          End If
        End If

        While PublicI = (I - 2): DoEvents: Wend
        pi.SubAction , "Обрабатывается ссылка $index из $count", "$time"
        html$ = AsyncXMLHttpResponse(I - 2)
        Set FindsImg = GetTxt(html$, "src=.(.*?\.(\w){3})(.\d{1,}){1,}\.\w{3}""")

        Id = AsyncXMLHttpURLS(I - 2)
        rowNum = Application.Match(Id, Rng, 0)
        If FindsImg.Count >= 1 Then
          If CInt(CountImages) > CInt(FindsImg.Count - 1) Then CountImages = FindsImg.Count - 1
          Cells(rowNum, 4) = ""
          For J = 1 To CountImages
            Cells(rowNum, 4) = Cells(rowNum, 4) & FindsImg(J).SubMatches(0) & ",": DoEvents
          Next
        End If

      Next