VBAを使ってIEの入力補助を行うコード
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long _
)
'Win32 APIのSetForegroundWindowを使用する
' Excel 64bit用
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" ( _
ByVal hwnd As LongPtr) As Long
Const 入力開始行 As Long = 4
Const Form属性列 As Long = 1
Const FormID列 As Long = 2
Const FormName列 As Long = 3
Const Form値 As Long = 4
Dim Form入力行 As Long
Dim bodyHeight As Long
Dim windowHeight As Long
Dim bottomPoint As Long
Dim currentPos As Long
Dim pastePos As Long
Sub 自動入力()
' Application.ScreenUpdating = False ' Excelの画面の変化を表示をしないことで高速に実行できる
'起動済みのIEを取得する
Dim shl As Object 'シェルオブジェクト生成
Set shl = CreateObject("Shell.Application")
With Worksheets("入力")
Dim targetTitle As String '取得したいウィンドウのタイトルを設定
targetTitle = .Cells(1, 3).Value 'C1固定
Dim win As Object, getFlag As Boolean
For Each win In shl.Windows '起動中のウィンドウを順番にみていく
'IEとエクスプローラがシェルで取得されるため、IEのみ処理
If TypeName(win.document) = "HTMLDocument" Then
If win.document.Title = targetTitle Then
Dim objIE As New InternetExplorer
Set objIE = win
getFlag = True '正しく取得できた
Exit For
End If
End If
Next
If getFlag = False Then
MsgBox "目的の画面が開かれていません。", vbExclamation
Exit Sub
End If
Form入力行 = 入力開始行
Do While .Cells(Form入力行, 1).Value = "入力" Or .Cells(Form入力行, 1).Value = "クリック"
If .Cells(Form入力行, 1).Value = "入力" Then
If .Cells(Form入力行, FormID列).Value <> "" Then
objIE.document.getElementById(.Cells(Form入力行, FormID列).Value).Value = .Cells(Form入力行, Form値).Value
ElseIf .Cells(Form入力行, FormName列).Value <> "" Then
objIE.document.getElementsByName(.Cells(Form入力行, FormName列).Value)(0).Value = .Cells(Form入力行, Form値).Value
End If
End If
If .Cells(Form入力行, 1).Value = "クリック" Then
If .Cells(Form入力行, FormID列).Value <> "" Then
objIE.document.getElementById(.Cells(Form入力行, FormID列).Value).Click
ElseIf .Cells(Form入力行, FormName列).Value <> "" Then
objIE.document.getElementsByName(.Cells(Form入力行, FormName列).Value)(0).Click
End If
End If
Form入力行 = Form入力行 + 1
Loop
' ボタンクリック 一つの想定
Do While .Cells(Form入力行, 1).Value = "送信"
If .Cells(Form入力行, FormID列).Value <> "" Then
objIE.document.getElementById(.Cells(Form入力行, FormID列).Value).Click
ElseIf .Cells(Form入力行, FormName列).Value <> "" Then
objIE.document.getElementsByName(.Cells(Form入力行, FormName列).Value)(0).Click
End If
Form入力行 = Form入力行 + 1
Loop
End With
' 表示されるまで待機
Call IEWait(objIE)
'IEを最前面に表示
Sleep (500)
SetForegroundWindow (objIE.hwnd)
bodyHeight = objIE.document.body.clientHeight ' bodyの高さを取得
windowHeight = objIE.document.DocumentElement.clientHeight 'windowの高さを取得
bottomPoint = bodyHeight - windowHeight ' ページ最下部までスクロールしたかを判定するための位置を計算
' スクリーンショット
Sleep (1000)
Call アクティブ画面を撮る
pastePos = 1
Sleep (1000)
Worksheets("エビデンス").Cells(pastePos, 1).PasteSpecial
'currentPos = objIE.Window.pageYOffset ' スクロール量を取得
currentPos = 0
' スクロールが最下部になるまで
Do While bottomPoint > currentPos
Sleep (1000)
objIE.navigate "JavaScript:" & "scrollBy(0, " & windowHeight & ")"
Sleep (2000)
Call アクティブ画面を撮る
Sleep (1000)
pastePos = pastePos + windowHeight / 15
Worksheets("エビデンス").Cells(pastePos, 1).PasteSpecial
'currentPos = objIE.Window.pageYOffset ' スクロール量を取得
currentPos = currentPos + windowHeight
Sleep (2000)
Loop
Application.ScreenUpdating = True ' Excelの表示を元に戻す
MsgBox "完了"
End Sub
'---IEを待機する関数---
Function IEWait(ByRef objIE As Object)
Const READYSTATE_COMPLETE = 4
Do While objIE.Busy = True Or objIE.readyState <> READYSTATE_COMPLETE
DoEvents
Loop
End Function
Public Sub アクティブ画面を撮る()
keybd_event &HA4, 0&, &H1, 0&
keybd_event vbKeySnapshot, 0&, &H1, 0&
keybd_event vbKeySnapshot, 0&, &H1 Or &H2, 0&
keybd_event &HA4, 0&, &H1 Or &H2, 0&
End Sub