VBA управление IE.....

Option Compare Database
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal _
lpClassName As String, ByVal lpWindowName As String) As Long
 
Private Declare Function EnumChildWindows _
Lib "user32" (ByVal hwnd As Long, ByVal _
lpWndProc As Long, ByVal lp 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 Declare Function RegisterWindowMessage Lib "user32.dll" 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, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
    
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) 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 Sub Êíîïêà0_Click()
Dim hW As Long
Dim HTMLDoc As Object
 
hW = FindWindow(vbNullString, "Àâòîðèçàöèÿ - Microsoft Internet Explorer" & Chr(0))
MsgBox (hW)
Set HTMLDoc = IEDOMFromhWnd(hW)
HTMLDoc.navigate = "about:blank"
End Sub
 
Public 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
      EnumChildWindows hwnd, AddressOf EnumChildProc, hwnd
    End If
    If hwnd <> 0 Then
      lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
      SendMessageTimeout hwnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes
      If lRes Then
        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
        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
  sClassName = String$(100, 0)
  lRes = GetClassName(hwnd, sClassName, Len(sClassName))
  sClassName = Left$(sClassName, lRes)
  IsIEServerWindow = StrComp(sClassName, "Internet Explorer_Server", vbTextCompare) = 0
End Function
 
 
Public Function EnumChildProc(ByVal hW As Long, lParam As Long) As Long
  If IsIEServerWindow(hW) Then
    lParam = hW
  Else
    EnumChildProc = 1
  End If
End Function

Option Explicit
 
Sub IE_Internet_Explorer()
 
    Dim objCollectionIf As Object
    Dim Shell As Object
    Dim Wins As Object
    Dim WinItem As Variant
    Dim oDoc As Object
    Dim InputName As String
    Const SiteURL As String = "http://www.yandex.ru/"
    Dim WinItemLocationURL As String
    Dim FullWinItemLocationURL As String
    Dim objCollectionIfName As String
    Dim objCollectionIfValue As String
    Dim Все_ссылки As String
 
    Dim objCollectionIfLength_input As Integer
    Dim objCollectionIfLength_a As Integer
    Dim objCollectionIfType As String
    Dim i As Integer
    Dim WinItemLocationURLCount As Integer
    Dim Ссылки As Integer
 
    Dim Страница_IE_найдена As Boolean
 
    Set Shell = CreateObject("shell.application")
 
    For Each WinItem In Shell.Windows
 
        WinItemLocationURL = WinItem.LocationURL
        If Mid$(WinItemLocationURL, 1, 7) <> "file://" Then
            WinItemLocationURLCount = WinItemLocationURLCount + 1
            FullWinItemLocationURL = FullWinItemLocationURL & WinItemLocationURLCount & ": " & WinItemLocationURL & Chr$(13)
 
            If WinItem.LocationURL = SiteURL Then
                Set oDoc = WinItem.Document
                Страница_IE_найдена = True
            Else
            End If
        End If
    Next
 
    If Страница_IE_найдена = True Then
        MsgBox$ _
                "Найдено вкладок Internet Explorer: " & WinItemLocationURLCount & Chr$(13) & _
                                                      FullWinItemLocationURL, vbOKOnly, _
                                                      "Внимание"
    Else
        MsgBox$ _
                "Не найдена требуемая страница: " & SiteURL & Chr$(13) & _
                                                  "Программа не может быть продолжена" & Chr$(13) & _
                                                  "Найдено вкладок Internet Explorer: " & WinItemLocationURLCount & Chr$(13) & _
                                                  FullWinItemLocationURL, vbOKOnly, _
                                                  "Внимание"
        GoTo Конец
    End If
 
    Set objCollectionIf = oDoc.getElementsByTagName("input")
 
    objCollectionIfLength_input = objCollectionIf.Length
 
    'проходит по всем кнопкам, полям
    While i < objCollectionIf.Length
        'кнопки имеют Type "submit"
        objCollectionIfType = objCollectionIf(i).Type
        objCollectionIfName = objCollectionIf(i).Name
        objCollectionIfValue = objCollectionIf(i).Value
 
        'вводим в поле требуемый текст
        If objCollectionIf(i).Name = "text" Then
            objCollectionIf(i).Value = "Нужный текст"
        End If
 
        i = i + 1
    Wend
    i = 0
 
    Set objCollectionIf = oDoc.getElementsByTagName("a")
 
    objCollectionIfLength_a = objCollectionIf.Length
 
    While i < objCollectionIf.Length
        If Len((objCollectionIf(i).Title)) <> 0 Then
            Ссылки = Ссылки + 1
            Все_ссылки = Все_ссылки & Ссылки & ": " & objCollectionIf(i).Title & Chr$(13)
            'MsgBox$ (objCollectionIf(i).Title)
            If objCollectionIf(i).Title = "Уточнить сведения" Then
                'вызываем событие клика у полученного элемента
                objCollectionIf(i).onclick
            End If
        End If
        i = i + 1
    Wend
 
    MsgBox$ _
          i & Chr$(13) & _
            "Ссылки: " & Ссылки & Chr$(13) & _
            Все_ссылки, vbOKOnly, _
            "Внимание"
 
    Selection.TypeText Text:=i & Chr$(13) & _
                             "Ссылки: " & Ссылки & Chr$(13) & _
                             Все_ссылки
    i = 0
 
    'установка объекта в значение Nothing требуется для освобождения памяти, которая была выделена для создания этого объекта
    Set objCollectionIf = Nothing
    Set oDoc = Nothing
Конец:
    Set Shell = Nothing
 
End Sub

Set objCollectionIf = oDoc.getElementsByTagName("input") ' получили все поля и кнопки
 
    'проходит по всем кнопкам, полям
    While i < objCollectionIf.Length
        If (objCollectionIf(i).Name = "Найти" or objCollectionIf(i).Type = "submit") Then ' ищем инпут с типом субмит(кнопку)
            objCollectionIf(i).OnClick ' нажимаем ее
goto next 'выходим из цикла
        End If
 
        i = i + 1
    Wend
    i = 0
next:

 objCollectionIf(i).OnClick ' нажимаем ее

Set objCollectionIf = oDoc.getElementsByTagName("input")
 
    objCollectionIfLength_input = objCollectionIf.Length
 
    'проходит по всем кнопкам, полям
    While i < objCollectionIf.Length
        'кнопки имеют Type "submit"
        objCollectionIfType = objCollectionIf(i).Type
        objCollectionIfName = objCollectionIf(i).Name
        objCollectionIfValue = objCollectionIf(i).Value
 
        'вводим в поле требуемый текст
        If objCollectionIf(i).Name = "text" Then
            objCollectionIf(i).Value = "VBA"
        End If
 
        i = i + 1
    Wend
    i = 0
 
   While i < objCollectionIf.Length
         'нашли кномпку с Value = Найти и типом submit и нажали ее
        If objCollectionIf(i).Value = "Найти" And objCollectionIf(i).Type = "submit" Then
            objCollectionIf(i).Click ' тут просто Клик нужен был а не онКлик вот и ошибка вылетала
        End If
 
        i = i + 1
    Wend
    i = 0

 While i < objCollectionIf.Length
         'ищщем чек бокс отмечаем его
        If objCollectionIf(i).Name = "twoweeks" And objCollectionIf(i).Type = "checkbox" Then
            objCollectionIf(i).Checked = True
        End If
 
        i = i + 1
    Wend
    i = 0

'отмечаем checkbox ...
            objCollectionIf(i).Checked = True

If (objCollectionIf(i).Name = "Найти" And objCollectionIf(i).Type = "submit") Then

If objCollectionIf(i).Name = "twoweeks" And objCollectionIf(i).Type = "checkbox" Then
   objCollectionIf(i).Checked = True
End If

If objCollectionIf(i).Value = "Найти" And objCollectionIf(i).Type = "submit" Then
            objCollectionIf(i).Click ' тут просто Клик нужен был а не онКлик вот и ошибка вылетала
 End If

If Len((objCollectionIf(i).Title)) <> 0 Then

   While i < objCollectionIf.Length
         'ищщем чек бокс отмечаем его
        If objCollectionIf(i).Name = "twoweeks" And objCollectionIf(i).Type = "checkbox" Then
            If objCollectionIf(i).Checked = True Then
            objCollectionIf(i).Checked = False
            ElseIf objCollectionIf(i).Checked = False Then
            objCollectionIf(i).Checked = True
            End If
        End If
         i = i + 1
    Wend
    i = 0

If objCollectionIf(i).Type = "checkbox" And objCollectionIf(i).Name = "twoweeks" Then
            'отмечаем checkbox ...
            objCollectionIf(i).Checked = True  'ошибка 70!!!!!    Permission denied Доступ запрещен

Set objCollectionIf = oDoc.getElementsByTagName("label")

If objCollectionIf(i).Value = "логин"  Then ' а сам текст должен быть Value
   objCollectionIf(i).onClick ' у лейблов вроде онклик а не клик
End If

Set oDoc = WinItem.Document.Frame[0].Document ' порядок нумерации фреймов в нете видел, но сам делал методом научного тыка

Set objCollectionIf = oDoc.getElementsByTagName("label")
 objCollectionIfLength_input = objCollectionIf.Length
    'проходит по всем label - ("label")
    While i < objCollectionIf.Length
        'objCollectionIfType = objCollectionIf(i).Type ошибка 438
        'objCollectionIfName = objCollectionIf(i).Name ошибка 438
        'objCollectionIfValue = objCollectionIf(i).Value ошибка 438
        
If objCollectionIf(i).Value = "логин" Then  ' а сам текст должен быть Value
   objCollectionIf(i).onclick ' у лейблов вроде онклик а не клик
End If
       
        i = i + 1
    Wend
    i = 0