IE操作とスクリーンショット撮りをExcelVBAで自動化する。※SJISコードは文字化けした為、UTF8コードも用意した。

IE管理者_SJIS.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "IE�Ǘ���"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'IE�Ǘ���.cls
'Copyright (c) 2014 nezuq
'This software is released under the MIT License.
'http://opensource.org/licenses/mit-license.php

'[�Q�Ɛݒ�]
'Microsoft HTML Object Library
'Microsoft Internet Controls

'[���ʒ萔]
Private Const WAITTIME_BEFOREPRINT As Integer = 2

'[���ʕϐ�]
Private ie As InternetExplorer
Private doc As HTMLDocument

'[COM�֐�]
'64bit��
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long _
        )
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
    ByVal hwindow As Long, _
    ByVal cmdshow As Long _
        ) As Long
'32bit��
'Private Declare Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long _
        )
'Private Declare Function ShowWindow Lib "user32" ( _
    ByVal hwindow As Long, _
    ByVal cmdshow As Long _
        ) As Long
        
'[���ʊ֐�]
Private Sub sleep(ByVal sec As Integer)
    Dim ymdTo As Date
    ymdTo = DateAdd("s", sec, Now)
    While Now < ymdTo
       DoEvents
    Wend
End Sub

Private Sub clearClipBoard()
    Range("A1").Copy
    Excel.Application.CutCopyMode = False
End Sub

Private Sub ieNavWait(ByRef ie As InternetExplorer)
    Do While ie.Busy = True Or ie.readyState <> 4
        DoEvents
    Loop
End Sub

Private Sub paste(ByRef nmeSht As String, ByVal nmeCel As String)
    sleep WAITTIME_BEFOREPRINT
    Dim sht As Worksheet
    Set sht = Worksheets(nmeSht)
    Dim rng As Range
    Set rng = sht.Range(nmeCel)
    sht.paste Destination:=rng
End Sub

'[���J�֐�]
Public Sub �J��(ByVal URL As String)
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = True
    Dim ret As Variant
    ret = ShowWindow(CLng(ie.Hwnd), 3)
    ie.navigate URL
    ieNavWait ie
End Sub

Public Sub �t�H�[�J�X�𓖂Ă�(ByVal ����ID As String)
    Set doc = ie.document
    doc.getElementById(����ID).Focus
End Sub

Public Sub ���͂���(ByVal ����ID As String, ByVal �l As String)
    �t�H�[�J�X�𓖂Ă� ����ID
    SendKeys �l
End Sub

Public Sub ���x���őI��(ByVal ����ID As String, ByVal ���x�� As String)
    Set doc = ie.document
    Dim slct As HTMLSelectElement
    Set slct = doc.getElementById(����ID)
    Dim opt As Variant
    For Each opt In slct.Children
        If (opt.Label = ���x��) Then
            slct.selectedIndex = opt.Index
            Exit Sub
        End If
    Next
End Sub

Public Sub �ԍ��őI��(ByVal ����ID As String, ByVal �ԍ� As Integer)
    Set doc = ie.document
    Dim slct As HTMLSelectElement
    Set slct = doc.getElementById(����ID)
    slct.selectedIndex = �ԍ�
End Sub

Public Sub �l�őI��(ByVal ����ID As String, ByVal �l As String)
    Set doc = ie.document
    Dim slct As HTMLSelectElement
    Set slct = doc.getElementById(����ID)
    Dim opt As Variant
    For Each opt In slct.Children
        If (opt.Value = �l) Then
            slct.selectedIndex = opt.Index
            Exit Sub
        End If
    Next
End Sub

Public Sub �N���b�N����(ByVal ����ID As String)
    Set doc = ie.document
    doc.getElementById(����ID).Click
    ieNavWait ie
End Sub

Public Sub �^�ƒl�ŃN���b�N����(ByVal �^ As String, ByVal �l As String)
    Set doc = ie.document
    Dim elm As Object
    For Each elm In doc.all
        If (StrConv(elm.tagName, vbLowerCase) = StrConv(�^, vbLowerCase)) Then
            If (StrConv(elm.Value, vbLowerCase) = StrConv(�l, vbLowerCase)) Then
                elm.Click
                Exit Sub
            End If
        End If
    Next
End Sub

Public Sub �҂�(ByVal �b As Integer)
    sleep �b
End Sub

Public Sub �S�̂��B��(ByVal �V�[�g�� As String, ByVal �Z���� As String)
    clearClipBoard
    keybd_event vbKeySnapshot, 0&, &H1, 0&
    keybd_event vbKeySnapshot, 0&, &H1 Or &H2, 0&
    paste �V�[�g��, �Z����
End Sub

Public Sub �A�N�e�B�u���ʂ��B��(ByVal �V�[�g�� As String, ByVal �Z���� As String)
    clearClipBoard
    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&
    paste �V�[�g��, �Z����
End Sub

Public Sub �]������( _
    ByVal �R�}���h�� As String, _
    Optional ByVal ����1 As String, _
    Optional ByVal ����2 As String)
    
    Select Case �R�}���h��
        Case "�J��"
            �J�� ����1
        Case "�t�H�[�J�X�𓖂Ă�"
            �t�H�[�J�X�𓖂Ă� ����1
        Case "���͂���"
            ���͂��� ����1, ����2
        Case "���x���őI��"
            ���x���őI�� ����1, ����2
        Case "�ԍ��őI��"
            �ԍ��őI�� ����1, ����2
        Case "�l�őI��"
            �l�őI�� ����1, ����2
        Case "�N���b�N����"
            �N���b�N���� ����1
        Case "�^�ƒl�ŃN���b�N����"
            �^�ƒl�ŃN���b�N���� ����1, ����2
        Case "�҂�"
            �҂� ����1
        Case "�S�̂��B��"
            �S�̂��B�� ����1, ����2
        Case "�A�N�e�B�u���ʂ��B��"
            �A�N�e�B�u���ʂ��B�� ����1, ����2
    End Select
    
End Sub

IE管理者_UTF8.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "IE管理者"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'IE管理者.cls
'Copyright (c) 2014 nezuq
'This software is released under the MIT License.
'http://opensource.org/licenses/mit-license.php

'[参照設定]
'Microsoft HTML Object Library
'Microsoft Internet Controls

'[共通定数]
Private Const WAITTIME_BEFOREPRINT As Integer = 2

'[共通変数]
Private ie As InternetExplorer
Private doc As HTMLDocument

'[COM関数]
'64bit版
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long _
        )
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
    ByVal hwindow As Long, _
    ByVal cmdshow As Long _
        ) As Long
'32bit版
'Private Declare Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long _
        )
'Private Declare Function ShowWindow Lib "user32" ( _
    ByVal hwindow As Long, _
    ByVal cmdshow As Long _
        ) As Long
        
'[共通関数]
Private Sub sleep(ByVal sec As Integer)
    Dim ymdTo As Date
    ymdTo = DateAdd("s", sec, Now)
    While Now < ymdTo
       DoEvents
    Wend
End Sub

Private Sub clearClipBoard()
    Range("A1").Copy
    Excel.Application.CutCopyMode = False
End Sub

Private Sub ieNavWait(ByRef ie As InternetExplorer)
    Do While ie.Busy = True Or ie.readyState <> 4
        DoEvents
    Loop
End Sub

Private Sub paste(ByRef nmeSht As String, ByVal nmeCel As String)
    sleep WAITTIME_BEFOREPRINT
    Dim sht As Worksheet
    Set sht = Worksheets(nmeSht)
    Dim rng As Range
    Set rng = sht.Range(nmeCel)
    sht.paste Destination:=rng
End Sub

'[公開関数]
Public Sub 開く(ByVal URL As String)
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = True
    Dim ret As Variant
    ret = ShowWindow(CLng(ie.Hwnd), 3)
    ie.navigate URL
    ieNavWait ie
End Sub

Public Sub フォーカスを当てる(ByVal 項目ID As String)
    Set doc = ie.document
    doc.getElementById(項目ID).Focus
End Sub

Public Sub 入力する(ByVal 項目ID As String, ByVal 値 As String)
    フォーカスを当てる 項目ID
    SendKeys 値
End Sub

Public Sub ラベルで選ぶ(ByVal 項目ID As String, ByVal ラベル As String)
    Set doc = ie.document
    Dim slct As HTMLSelectElement
    Set slct = doc.getElementById(項目ID)
    Dim opt As Variant
    For Each opt In slct.Children
        If (opt.Label = ラベル) Then
            slct.selectedIndex = opt.Index
            Exit Sub
        End If
    Next
End Sub

Public Sub 番号で選ぶ(ByVal 項目ID As String, ByVal 番号 As Integer)
    Set doc = ie.document
    Dim slct As HTMLSelectElement
    Set slct = doc.getElementById(項目ID)
    slct.selectedIndex = 番号
End Sub

Public Sub 値で選ぶ(ByVal 項目ID As String, ByVal 値 As String)
    Set doc = ie.document
    Dim slct As HTMLSelectElement
    Set slct = doc.getElementById(項目ID)
    Dim opt As Variant
    For Each opt In slct.Children
        If (opt.Value = 値) Then
            slct.selectedIndex = opt.Index
            Exit Sub
        End If
    Next
End Sub

Public Sub クリックする(ByVal 項目ID As String)
    Set doc = ie.document
    doc.getElementById(項目ID).Click
    ieNavWait ie
End Sub

Public Sub 型と値でクリックする(ByVal 型 As String, ByVal 値 As String)
    Set doc = ie.document
    Dim elm As Object
    For Each elm In doc.all
        If (StrConv(elm.tagName, vbLowerCase) = StrConv(型, vbLowerCase)) Then
            If (StrConv(elm.Value, vbLowerCase) = StrConv(値, vbLowerCase)) Then
                elm.Click
                Exit Sub
            End If
        End If
    Next
End Sub

Public Sub 待つ(ByVal 秒 As Integer)
    sleep 秒
End Sub

Public Sub 全体を撮る(ByVal シート名 As String, ByVal セル名 As String)
    clearClipBoard
    keybd_event vbKeySnapshot, 0&, &H1, 0&
    keybd_event vbKeySnapshot, 0&, &H1 Or &H2, 0&
    paste シート名, セル名
End Sub

Public Sub アクティブ画面を撮る(ByVal シート名 As String, ByVal セル名 As String)
    clearClipBoard
    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&
    paste シート名, セル名
End Sub

Public Sub 評価する( _
    ByVal コマンド名 As String, _
    Optional ByVal 引数1 As String, _
    Optional ByVal 引数2 As String)
    
    Select Case コマンド名
        Case "開く"
            開く 引数1
        Case "フォーカスを当てる"
            フォーカスを当てる 引数1
        Case "入力する"
            入力する 引数1, 引数2
        Case "ラベルで選ぶ"
            ラベルで選ぶ 引数1, 引数2
        Case "番号で選ぶ"
            番号で選ぶ 引数1, 引数2
        Case "値で選ぶ"
            値で選ぶ 引数1, 引数2
        Case "クリックする"
            クリックする 引数1
        Case "型と値でクリックする"
            型と値でクリックする 引数1, 引数2
        Case "待つ"
            待つ 引数1
        Case "全体を撮る"
            全体を撮る 引数1, 引数2
        Case "アクティブ画面を撮る"
            アクティブ画面を撮る 引数1, 引数2
    End Select
    
End Sub

LICENSE.TXT

The MIT License (MIT)

Copyright (c) 2014 nezuq

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.

デモ_SJIS.bas

Attribute VB_Name = "�f��"
Option Explicit

'IE�Ǘ���.cls
'Copyright (c) 2014 nezuq
'This software is released under the MIT License.
'http://opensource.org/licenses/mit-license.php

Public Sub �f�����s()
    Dim c As New ie�Ǘ���
    c.�]������ "�J��", "http://search.nicovideo.jp/video/search/"
    c.�]������ "���͂���", "search-text", "���b�g��������"
    c.�]������ "�҂�", 3
    c.�]������ "�N���b�N����", "tile-view-button"
    c.�]������ "�t�H�[�J�X�𓖂Ă�", "sort-select"
    c.�]������ "�҂�", 2
    c.�]������ "���x���őI��", "sort-select", "�}�C���X�g����������"
    c.�]������ "�҂�", 2
    c.�]������ "�ԍ��őI��", "sort-select", 0
    c.�]������ "�҂�", 2
    c.�]������ "�l�őI��", "sort-select", "view_counter"
    c.�]������ "�^�ƒl�ŃN���b�N����", "input", "����"
    c.�]������ "�S�̂��B��", ActiveSheet.Name, "A1"
    c.�]������ "�A�N�e�B�u���ʂ��B��", ActiveSheet.Name, "A70"
    MsgBox "�������������܂����B"
End Sub

デモ_UTF8.bas

Attribute VB_Name = "デモ"
Option Explicit

'IE管理者.cls
'Copyright (c) 2014 nezuq
'This software is released under the MIT License.
'http://opensource.org/licenses/mit-license.php

Public Sub デモ実行()
    Dim c As New ie管理者
    c.評価する "開く", "http://search.nicovideo.jp/video/search/"
    c.評価する "入力する", "search-text", "ラットが死んだ"
    c.評価する "待つ", 3
    c.評価する "クリックする", "tile-view-button"
    c.評価する "フォーカスを当てる", "sort-select"
    c.評価する "待つ", 2
    c.評価する "ラベルで選ぶ", "sort-select", "マイリスト数が多い順"
    c.評価する "待つ", 2
    c.評価する "番号で選ぶ", "sort-select", 0
    c.評価する "待つ", 2
    c.評価する "値で選ぶ", "sort-select", "view_counter"
    c.評価する "型と値でクリックする", "input", "検索"
    c.評価する "全体を撮る", ActiveSheet.Name, "A1"
    c.評価する "アクティブ画面を撮る", ActiveSheet.Name, "A70"
    MsgBox "処理が完了しました。"
End Sub