'↓↓↓↓マウス操作のおまじない開始↓↓↓↓
Private Type Position
    x As Long
    y As Long
End Type
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Declare Sub mouse_event Lib "user32" ( _
    ByVal dwFlags As Long, _
    Optional ByVal dx As Long = 0, _
    Optional ByVal dy As Long = 0, _
    Optional ByVal dwDate As Long = 0, _
    Optional ByVal dwExtraInfo As Long = 0)
Declare Function GetCursorPos Lib "user32" _
    (lpPoint As Position) As Long
    
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'mouse_event用の定数宣言
Private Const MOUSEEVENTF_ABSOLUTE = &H8000
Private Const MOUSEEVENTF_MOVE = &H1
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_RIGHTDOWN = &H8
Private Const MOUSEEVENTF_RIGHTUP = &H10
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20
Private Const MOUSEEVENTF_MIDDLEUP = &H40

'Public Class Form1
    Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Integer, ByVal dwExtraInfo As Integer)
'↑↑↑↑マウス操作のおまじない終了↑↑↑↑
'↓↓↓↓ここからメインプログラム↓↓↓↓

Sub マウスクリック()

    SetCursorPos 900, 140 '左から900ピクセル、上から140ピクセルの位置にカーソルを移動

    Sleep 200

    mouse_event MOUSEEVENTF_LEFTDOWN  '左ボタン押下（範囲選択のクリックのつもり）

    mouse_event MOUSEEVENTF_LEFTUP  '左ボタン解放


End Sub

Sub 座標校正()
  
  Dim sht As Worksheet
  
  Sleep 500
  
  Const CN = 5
  
    Dim pos As Position
    
    i = 0
  
  Dim currentClickNum As Long
  Do While i < CN
    If GetAsyncKeyState(1) < 0 Then
      i = i + 1
    Call GetCursorPos(pos)
      Cells(i + 2, 3) = pos.x
      Cells(i + 2, 4) = pos.y
      Sleep 500
    End If
  Loop
  
End Sub

SetCursorPos Worksheets("座標校正").Cells(2, 3).Value, Worksheets("座標校正").Cells(2, 4).Value

Sub IEoutput2()
  
 Application.ScreenUpdating = False
   
'IEの起動
Dim objIE As Object
   
Set objIE = GetObject("", "InternetExplorer.Application")
   
objIE.Visible = True
       
       
    objIE.Navigate "https://furunavi.jp/Product/Search?subcategoryid=164,165,166,167,168&categoryid=17&order=3&layout_toggle=2&pagesize=100"  ' このURLを任意に変更
       
    ' ページの表示完了待ち｡
    While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Wend
   
    On Error Resume Next      '値がないとエラーが出るので、エラー回避用
  
    i = 1  '開始行を指定
    J = objIE.document.ALL.Length  '要素の数を知る
      
     
     Dim A As Object
     
        Application.Wait Now() + TimeValue("00:00:03")
     
       
    Dim YOUSO(10000, 0 To 14) As String
    J = 0
        
    For Each A In objIE.document.getElementsbytagname("*")
    
    If A.className = "product-info" Then

        For Each B In A.ALL
         YOUSO(i + 1, J) = B.INNERTEXT
         J = J + 1
         
        Next

        J = 0
        i = i + 1
           
       
    End If
                    

        
    Next
      
    Range(Cells(2, 2), Cells(i, 15)) = YOUSO
 
     Cells.WrapText = False
  
  
 Application.ScreenUpdating = True
 Application.StatusBar = False
  
   
End Sub

Sub IEdisplay2()

'IEの起動
Dim objIE As Object 'IEを格納する変数（オブジェクト型）
Dim sh As Object '起動中のShellWindow一式を格納する変数
Dim win As Object 'ShellWindowを格納する変数

Dim document_title As String 'ドキュメントタイトルの一時格納変数
'起動中のShellWindow一式を変数winsに格納
Set sh = CreateObject("Shell.Application")
'ShellWindowから1つずつ取得して処理
For Each win In sh.Windows
'ドキュメントタイトル取得失敗を無視（処理継続）
On Error Resume Next
document_title = ""
document_title = win.document.Title

Debug.Print document_title

On Error GoTo 0
'タイトルバーにGoogleが含まれるかチェック
If InStr(document_title, "Google") > 0 Then
'変数ieに取得したwinを格納
Set objIE = win
'ループを抜ける
Exit For
End If
Next


    Dim A As Object
        
    For Each A In objIE.document.getElementsByTagName("INPUT") '①FOR EACH でINPUTをすべて抜き出す。
       
        If A.Name = "q" Then A.Value = "nujonoa_blog" '②IF分で入力したい要素を見つけて　③値を代入
        
    Next
    For Each A In objIE.document.getElementsByTagName("INPUT") '①FOR EACH でINPUTをすべて抜き出す。
       
        If A.Name = "btnK" Then A.Click '②IF分で入力したい要素を見つけて　③Click
        
    Next
       
    On Error GoTo 0

End Sub

Sub IEoutput2()
 
 Application.ScreenUpdating = False
  
'*****↓ここまでは以前と一緒***************************************************
'IEの起動
Dim objIE As Object
  
Set objIE = GetObject("", "InternetExplorer.Application")
  
objIE.Visible = True
      
      
    objIE.Navigate "https://www.google.com/?hl=ja"  ' このURLを任意に変更
      
    ' ページの表示完了待ち｡
    While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Wend
'*****↑ここまでは以前と一緒***************************************************
  
'****今日はここから↓***************************************************
  
    On Error Resume Next      '値がないとエラーが出るので、エラー回避用
 
    i = 1  '開始行を指定
    J = objIE.document.all.Length  '要素の数を知る
     
    Cells(i, 1).Value = "uniqueID"
    Cells(i, 2).Value = "tagname"
    Cells(i, 3).Value = "Type"
    Cells(i, 4).Value = "NAME"
    Cells(i, 5).Value = "ID"
    Cells(i, 6).Value = "className"
    Cells(i, 7).Value = "TABINDEX"
    Cells(i, 8).Value = "Vakue"
    Cells(i, 9).Value = "checked"
    Cells(i, 10).Value = "親のtagname"
    Cells(i, 11).Value = "innertext"
    Cells(i, 12).Value = "outertext"
    Cells(i, 13).Value = "outherhtml"
    Cells(i, 14).Value = "innerhtml"
     
     Dim A As Object
      
    Dim YOUSO(1000, 1 To 15) As String
    
       
    For Each A In objIE.document.getElementsbytagname("*")
      
      
 
        YOUSO(i + 1, 1) = A.uniqueID                'uniqueID
        YOUSO(i + 1, 2) = A.TAGNAME                 '親のTAG
        YOUSO(i + 1, 3) = A.Type                    'タイプ ※selectボックスは”select-one”と取得
        YOUSO(i + 1, 4) = A.Name                    '名前
        YOUSO(i + 1, 5) = A.ID                      'ID
        YOUSO(i + 1, 6) = A.className               'クラス名
        YOUSO(i + 1, 7) = A.TabIndex                'フォーカス順序 (Tabでの移動順)
        YOUSO(i + 1, 8) = A.Value                   '値
        YOUSO(i + 1, 9) = A.Checked                 'チェック状態 (True = チェック有り､false = チェック無し)
                                                    'checkboxやradioボタンから取得します
        YOUSO(i + 1, 10) = A.parentElement.TAGNAME  '親のTAG
  
  
  
        If Len(A.innerHTML) > 50 Then
          
            YOUSO(i + 1, 11) = Left(A.innertext, 10) & "   ~~~   " & Right(A.innertext, 10)
            YOUSO(i + 1, 12) = Left(A.outertext, 10) & "   ~~~   " & Right(A.outerrext, 10)
            YOUSO(i + 1, 13) = Left(A.outerHTML, 10) & "   ~~~   " & Right(A.outerHTML, 10)
            YOUSO(i + 1, 14) = Left(A.innerHTML, 10) & "   ~~~   " & Right(A.innerHTML, 10)
  
        Else
          
            YOUSO(i + 1, 11) = A.innertext
            YOUSO(i + 1, 12) = A.outertext
            YOUSO(i + 1, 13) = A.outerHTML
            YOUSO(i + 1, 14) = A.innerHTML
                      
        End If
          
        Dim C(20) As String
 
        '階層を表示
        For Z = 1 To 20
            C(Z) = A.TAGNAME
            If A.TAGNAME = "HTML" Then Exit For
            Set A = A.parentElement
        Next
 
        For L = Z To 1 Step -1
            Cells(i + 1, 30 + Z - L) = C(L)
        Next
          
          
        i = i + 1
          
        'ステータスバーに進捗を表示
        Application.StatusBar = i & "/" & J
       
    Next
     
    Range(Cells(2, 1), Cells(i, 14)) = YOUSO 

     Cells.WrapText = False
 
 
 Application.ScreenUpdating = True
 Application.StatusBar = False
 
'表示を固定
Columns(1, 9).AutoFit
Cells(1, 2).EntireColumn.Interior.ColorIndex = 6
Cells(2, 3).Select
ActiveWindow.FreezePanes = True
objIE.document.getElementsByName("q")(0).Value = "テスト"
  
End Sub

 
'Public Class Form1
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Integer, ByVal dwExtraInfo As Integer)

Private Declare Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)

Sub winを押す()

       Call keybd_event(&H5B, 0, 0, 0) 'Windowsキーを押す
        Call keybd_event(&H10, 0, 0, 0) 'Shiftキーを押す
        Call keybd_event(83, 0, 0, 0) 'sキーを押す

        Sleep(100)

        Call keybd_event(&H5B, 0, 2, 0) 'Windowsキーをあげる 
        Call keybd_event(&H10, 0, 2, 0) 'Shiftキーをあげる  
        Call keybd_event(83, 0, 2, 0) 'sキーをあげる(キーを上げる動作がないとおかしくなる)

End Sub

Private Type Position
    x As Long
    y As Long
End Type
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Declare Sub mouse_event Lib "user32" ( _
    ByVal dwFlags As Long, _
    Optional ByVal dx As Long = 0, _
    Optional ByVal dy As Long = 0, _
    Optional ByVal dwDate As Long = 0, _
    Optional ByVal dwExtraInfo As Long = 0)
Declare Function GetCursorPos Lib "user32" _
    (lpPoint As Position) As Long
    
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'mouse_event用の定数宣言
Private Const MOUSEEVENTF_ABSOLUTE = &H8000
Private Const MOUSEEVENTF_MOVE = &H1
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_RIGHTDOWN = &H8
Private Const MOUSEEVENTF_RIGHTUP = &H10
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20
Private Const MOUSEEVENTF_MIDDLEUP = &H40

'Public Class Form1
    Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Integer, ByVal dwExtraInfo As Integer)

'↓ここからメインプログラム

Sub 画面切り取り()

        Call keybd_event(&H5B, 0, 0, 0) 'Windowsキーを押す
        Call keybd_event(&H10, 0, 0, 0) 'Shiftキーを押す
        Call keybd_event(83, 0, 0, 0) 'sキーを押す

        Call keybd_event(&H5B, 0, 2, 0) 'Windowsキーをあげる  『キーをあげる操作を忘れないようにしてください』
        Call keybd_event(&H10, 0, 2, 0) 'Shiftキーをあげる    『忘れるとプログラムを終了するまでWindowsの動作がおかしくなります』
        Call keybd_event(83, 0, 2, 0) 'sキーをあげる

    DoEvents
    Application.Wait [Now()] + 50 / 86400000
    
    SetCursorPos 900, 140 '左から900ピクセル、上から140ピクセルの位置にカーソルを移動

    Sleep 200

    mouse_event MOUSEEVENTF_LEFTDOWN  '左ボタン押下（範囲選択のクリックのつもり）

    Sleep 200

    SetCursorPos 1599, 641 '範囲選択のマウス移動

    Sleep 200

    mouse_event MOUSEEVENTF_LEFTUP  '左ボタン解放

    Sleep 200

    Cells(1 1).PasteSpecial

End Sub

SendKeys "123" '1→2→3と順番に入力
SendKeys "{BS}"　’Back spaceを押す
SendKeys "^c"　’Ctrl+Cを押す(コピー)
SendKeys "{TAB} 10"　’TABを10回押す。　コマンド　回数で反復可能

Sub IE_SENDKEYS()

 Application.ScreenUpdating = False
 
'IEの起動
Dim objIE As Object
 
Set objIE = GetObject("", "InternetExplorer.Application")
 
objIE.Visible = True
     
     
    objIE.Navigate "https://www.google.co.jp/"  ' このURLを任意に変更
     
    ' ページの表示完了待ち｡
    While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Wend
    
SendKeys "test"
waitTime = Now + TimeValue("0:00:01")
Application.Wait waitTime
SendKeys "{TAB}"
SendKeys "{ENTER}"

    
End Sub

Sub IEoutputyahoo()

Application.ScreenUpdating = False
Dim objIE As Object
Set objIE = GetObject("", "InternetExplorer.Application")
objIE.Visible = True
     
    objIE.Navigate "https://www.yahoo.co.jp/"  ' このURLを任意に変更
     
    ' ページの表示完了待ち｡
    While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Wend

    Dim objTABLE As Object
    Set objTABLE = objIE.document
     
    On Error Resume Next　'結構エラーが伴うのでつけとく

    Dim A As Object
    
    For i = 2 To 73
    
    objIE.document.getElementbyid("srchfield").Value = Cells(i, 2)
    objIE.document.getElementbyid("srchfield").Select
    SendKeys "{BS}"
    SendKeys Cells(i, 2)

    Application.Wait Now() + TimeValue("00:00:01")

    
Cells(i, 4).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(0).INNERTEXT
Cells(i, 5).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(1).INNERTEXT
Cells(i, 6).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(2).INNERTEXT
Cells(i, 7).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(3).INNERTEXT
Cells(i, 8).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(4).INNERTEXT
Cells(i, 9).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(5).INNERTEXT
Cells(i, 10).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(7).INNERTEXT
Cells(i, 11).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(8).INNERTEXT
Cells(i, 12).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(9).INNERTEXT
Cells(i, 13).Value = objIE.document.getElementbyid("srchAssistLists").getElementsbytagname("A")(10).INNERTEXT
            
        ' ページの表示完了待ち｡
    While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Wend

    Next

 Application.ScreenUpdating = True

End Sub

Sub IE_table_output()
    
 Application.ScreenUpdating = False
     
'IEの起動
Dim objIE As Object
     
Set objIE = GetObject("", "InternetExplorer.Application")
     
objIE.Visible = True
         
    objIE.Navigate "https://www.rakuten-sec.co.jp/web/fund/find/search/result.html"  ' このURLを任意に変更
         
    ' ページの表示完了待ち｡
    While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Wend
     
    On Error Resume Next      '値がないとエラーが出るので、エラー回避用
    
    I = 1  '開始行を指定
    L = 0
    J = objIE.document.all.Length  '要素の数を知る
        
    Cells(I, 1).Value = "No"
              
    Dim A As Object
         
    For Each A In objIE.document.getElementsByTagName("tr")
    
        For L = 0 To 20
    
            Cells(I, L + 1) = A.Children(L).innertext
           
        Next
        
        I = I + 1
            
        'ステータスバーに進捗を表示
        Application.StatusBar = I & "/" & J
         
    Next
        
    On Error GoTo 0
  
    Cells.WrapText = False
    
Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

 Application.ScreenUpdating = False
     
'IEの起動
Dim objIE As Object
     
Set objIE = GetObject("", "InternetExplorer.Application")
     
objIE.Visible = True
         
         
    objIE.Navigate "https://www.rakuten-sec.co.jp/web/fund/find/search/result.html"  ' このURLを任意に変更
         
    ' ページの表示完了待ち｡
    While objIE.ReadyState <> 4 Or objIE.Busy = True
        DoEvents
    Wend
     
    On Error Resume Next      '値がないとエラーが出るので、エラー回避用
    
    I = 1  '開始行を指定
    L = 0
    J = objIE.document.all.Length  '要素の数を知る
        
    Cells(I, 1).Value = "No"
              
    Dim B As Object
         
    For Each B In objIE.document.getElementsByTagName("tr")
    
        For L = 0 To 20
    
            Cells(I, L + 1) = B.Children(L).innertext
           
        Next
        
        I = I + 1
        
            
        'ステータスバーに進捗を表示
        Application.StatusBar = I & "/" & J
         
    Next
        
    On Error GoTo 0
  
    Cells.WrapText = False
    
    
Application.ScreenUpdating = True
Application.StatusBar = False

     
     
End Sub