IEdoc.getelementbyid("popup-photos").Click
    Set CurItem = IEdoc.getelementbyid("form1")
    CurItem.Focus
    CurItem.Click
    CurItem(0).Click 'открывает диалог выбора файла

Public Sub Upload_Set_Filename(sFilePathName As String)
'    'Populate the 'File name:' edit window in the Choose File to Upload dialogue with the specified folder and/or filename.
'
'
'    'The Choose File to Upload has the following child window hierarchy:
'
'    '   #32770  Choose File to Upload   Static             Look &in:
'ComboBox           N / A
'Static             N/A
'ToolbarWindow32    N / A
'ToolbarWindow32    N / A
'ListBox            N / A
'SHELLDLL_DefView   N/A         1376604 SysListView32   FolderView
'Static             File &name:
'ComboBoxEx32       N/A         8520100 ComboBox        N/A 1245594 Edit    N/A
'Static             Files of &type:
'ComboBox N / A
'Button             Open as &read-only
'Button             &Open
'Button             Cancel
'Button             &Help
'ScrollBar N / A

  Dim hWnd As Long
  Dim timeout As Date
  'MsgBox ""
  'Debug.Print "Save_As_Set_Filename " & folder
  'Find the Window, waiting a maximum of 10 seconds for it to appear
  timeout = Now + TimeValue("00:00:10")
  Do
    hWnd = FindWindow("#32770", "Выбор выкладываемого файла") 'Choose File to Upload
    DoEvents
    Sleep 200
  Loop Until hWnd Or Now > timeout
  If hWnd Then
    SetForegroundWindow (hWnd)
    'Find the child ComboBoxEx32 window
    hWnd = FindWindowEx(hWnd, 0, "ComboBoxEx32", vbNullString)
    'Debug.Print "   ComboBoxEx32 "; Hex(hWnd)
  End If
  If hWnd Then
    'Find the child ComboBox window
    hWnd = FindWindowEx(hWnd, 0, "ComboBox", "")
    'Debug.Print "   ComboBox "; Hex(hWnd)
  End If
  If hWnd Then
    SetForegroundWindow (hWnd)
    'Find the child Edit window
    hWnd = FindWindowEx(hWnd, 0, "Edit", "")
    'Debug.Print "   Edit "; Hex(hWnd)
  End If
  If hWnd Then

    'Populate the Edit window with the full file name
    '        Sleep 200
    SendMessageByString hWnd, WM_SETTEXT, Len(sFilePathName), sFilePathName
  End If

End Sub

Public Sub Upload_Click_Open(Optional cmb As String)

  Dim hWnd As Long
  Dim timeout As Date

  'Debug.Print "File_Download_Click_Save"

  'Find the File Download window, waiting a maximum of 30 seconds for it to appear

  timeout = Now + TimeValue("00:00:10")
  Do
    hWnd = FindWindow("#32770", "Выбор выкладываемого файла")
    DoEvents
    Sleep 200
  Loop Until hWnd Or Now > timeout

  'Debug.Print "   File Download window "; Hex(hWnd)

  If hWnd Then
    'Find the child Open button

    hWnd = FindWindowEx(hWnd, 0, "Button", "&Открыть")
    'Debug.Print "   Save button "; Hex(hWnd)
  End If

  If hWnd Then

    'Click the Open button

    SetForegroundWindow (hWnd)
    Sleep 600     'this sleep is required and 600 miiliseconds seems to be the minimum that works
    SendMessage hWnd, BM_CLICK, 0, 0
  End If
End Sub
 

                    .Document.parentWindow.execScript "document.all.DLIUploader1.UnselectAll;", "jscript" 
                    .Document.parentWindow.execScript "if(document.all.DLIUploader1.FileCount>199) document.all.DLIUploader1.SelectFile(1);", "jscript" 'online repository accept 200 files at one time per data record
                    .Document.parentWindow.execScript "document.all.DLIUploader1.RemoveSelectedFiles();", "jscript" 
                    .Document.parentWindow.execScript "document.all.DLIUploader1.UploadFile(" & sFile & ")", "jscript"  

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

Option Explicit
 
Dim XMLHttpReq As MSXML2.XMLHttp, _
    bIAmAvailable As Boolean, _
    ResponseProcessor As String, _
    sURL As String, sMsg As String
 
Property Get IAmAvailable() As Boolean
    IAmAvailable = bIAmAvailable
    End Property
 
Sub ReadyStateChangeHandler()
    'Debug.Print XMLHttpReq.readyState
    If XMLHttpReq.readyState = 4 Then
        If XMLHttpReq.Status = 200 Then
            'Process the response here
            'hrefToHyperLink XMLHttpReq.responseText, ActiveCell
            Application.Run ResponseProcessor, XMLHttpReq, sURL, sMsg
            bIAmAvailable = True
        Else
            Debug.Print XMLHttpReq.Status & ", " & XMLHttpReq.responseText
            End If
        End If
    End Sub
 
Public Sub XMLHttpCall(ByVal ReqMethod As String, _
        ByVal URL As String, ByVal uResponseProcessor As String, _
        Optional ByVal AsyncCall As Boolean = True, _
        Optional ByVal uMsg As String = "")
    Set XMLHttpReq = New MSXML2.XMLHTTP
    If AsyncCall Then
        sURL = URL: sMsg = uMsg
        ResponseProcessor = uResponseProcessor
        XMLHttpReq.OnReadyStateChange = Me
        End If
    With XMLHttpReq
    .Open ReqMethod, URL, AsyncCall
    .send uMsg
    If Not AsyncCall Then Application.Run uResponseProcessor, XMLHttpReq, URL, uMsg
        End With
    End Sub

 Option Explicit
Option Base 0
 
Dim XMLHttpMon() As clsXMLHttpMonitor
 
Private Function findAvailMon() As clsXMLHttpMonitor
    Dim I As Integer, Done As Boolean
    I = LBound(XMLHttpMon)
    Do
        If XMLHttpMon(I) Is Nothing Then
            Done = True
        ElseIf XMLHttpMon(I).IAmAvailable Then
            Done = True
        Else
            I = I + 1
            Done = I > UBound(XMLHttpMon)
            End If
        Loop Until Done
    If I > UBound(XMLHttpMon) Then _
        ReDim Preserve XMLHttpMon(UBound(XMLHttpMon) + 1)
    Set XMLHttpMon(I) = New clsXMLHttpMonitor
    Set findAvailMon = XMLHttpMon(I)
    End Function
Public Sub XMLHttpCall(ByVal ReqMethod As String, _
        ByVal URL As String, ByVal uResponseProcessor As String, _
        Optional ByVal AsyncCall As Boolean = True, _
        Optional ByVal uMsg As String)
    Dim XMLHttpMon As clsXMLHttpMonitor
    Set XMLHttpMon = findAvailMon()
    XMLHttpMon.XMLHttpCall ReqMethod, URL, uResponseProcessor, AsyncCall, uMsg
    End Sub
 
Private Sub Class_Initialize()
    ReDim XMLHttpMon(0)
    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

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