ExcelVBAでWebメール自動作成

#コピペメールを大量に送るのがしんどい
派遣社員さんにお願いしている業務の中で宛先と本文の一部を変更して数十通のメールを送る作業がありました。
ファイルの添付もあり地味ながら辛い作業ということでどうにか自動化できないかといろいろ試してみた結果、IEオブジェクトからHTMLタグ操作すればいいじゃんということで実装してみました。
具体的にはブックの本文シートと送付先シートに情報を記載してもらって実行という流れです。
開発にあたってはFireFoxのインスペクター機能を活用しました。
Sleepのところは別の手法があるのでそちらの方がよいかも。
あとExcelの設定でオブジェクトを有効にするのもお忘れなく。
ただしiFrameタグ、てめーはダメだ。

```sample.bas
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

Sub sample()

    Dim book As Workbook
    Set book = ThisWorkbook
    
    Dim body As Worksheet
    Set body = book.Worksheets("本文")
    
    Dim list As Worksheet
    Set list = book.Worksheets("送付先")

    'IEの起動（参照設定でMicrosoft Internet Controlsにチェックを入れています）
    Dim objIE As InternetExplorerMedium
    Set objIE = New InternetExplorerMedium
    objIE.Visible = True
    
    '送信先の代入
    Dim strURL As String
    strURL = "任意のURL（ログイン画面）"
    
    '.Navigate メソッドでPost送信
    objIE.Navigate strURL
    
    Sleep 1000
    
    'ユーザ名とパスワードを入力してログイン
    objIE.Document.getElementById("user-id").Value = "任意のユーザ名"
    
    Sleep 1000
    
    objIE.Document.getElementById("pw-id").Value = "任意のパスワード"
    
    Sleep 1000
       
    'サインインボタン押下
    Dim objTag1 As Object
    
    For Each objTag1 In objIE.Document.getElementsByTagName("input")
        If InStr(objTag1.outerHTML, "サインイン") > 0 Then
            objTag1.Click
            Exit For
        End If
    Next
    
    Sleep 1000
    
    Dim i As Long
    
    For i = 1 To list.Cells(Rows.Count, 2).End(xlUp).Row - 1
    
    subject = "件名"
    
    '新しく開いたIEオブジェクトを取得
    Dim objShell As Object
    Dim objWin As Object
    
    Set objShell = CreateObject("Shell.Application")
    
    For Each objWin In objShell.Windows
        If objWin.Name = "Internet Explorer" Then
            Set objIE = objWin
        End If
    Next
    
    'メールリンク押下
    Dim objTag2 As Object
    
    For Each objTag2 In objIE.Document.getElementsByTagName("a")
        If objTag2.innerHTML = "メール" Then
            objTag2.target = "_self"
            objTag2.Click
            Exit For
        End If
    Next
    
    Sleep 1000
        
    For Each objWin In objShell.Windows
        If objWin.Name = "Internet Explorer" Then
            Set objIE = objWin
        End If
    Next
        
    Dim objFrame As Object
    
    Set objFrame = objIE.Document.frames
            
    Sleep 1000
        
    '新規メール作成クリック
    Dim objTag3 As Object
    Dim objTag4 As Object
    Dim flg1 As Boolean
    
    flg = False
    
    For Each objTag3 In objFrame("s_MainFrame").Document.getElementsByTagName("table")
        For Each objTag4 In objTag3.Document.getElementsByTagName("span")
            If objTag4.innerHTML = "新規" Then
                objTag4.Click
                flg1 = True
                Exit For
            End If
        Next
        If flg1 = True Then
            Exit For
        End If
    Next
    
    Sleep 1000
    
    Dim objTag5 As Object
    Dim objTag6 As Object
    
    
    'メール内容記載
    For Each objTag5 In objFrame("s_MainFrame").Document.getElementsByTagName("form")
        For Each objTag6 In objTag5.Document.getElementsByTagName("textarea")
            If InStr(objTag6.outerHTML, "sendto") Then
                objTag6.Value = list.Cells(i + 1, 5).Value
            End If
            If InStr(objTag6.outerHTML, "copyto") Then
                If InStr(objTag6.outerHTML, "blindcopyto") Then
                Else
                    If list.Cells(i + 1, 7).Value <> "" Then
                        objTag6.Value = list.Cells(i + 1, 7).Value
                    End If
                End If
            End If
            If InStr(objTag6.outerHTML, "subject") Then
                objTag6.Value = subject
            End If
            If InStr(objTag6.outerHTML, "bodyplain-editor") Then
                    objTag6.Value = list.Cells(i + 1, 4).Value & vbCrLf _
                                    & list.Cells(i + 1, 5).Value & "様" _
                                    & vbCrLf & vbCrLf _
                                    & body.Range("A1")
            End If
        Next
    Next
    
    Sleep 1000
    
    
    Dim objTag7 As Object
    Dim path As String
    Dim cbData As New DataObject
    
    path = list.Cells(i + 1, 8).Value
    
    If path <> "" Then
    
    'ファイル添付
    For Each objTag7 In objFrame("s_MainFrame").Document.getElementsByTagName("table")
        If InStr(objTag7.outerHTML, "ファイルの添付") Then
            objTag7.Document.Script.setTimeout "javascript:document.getElementById('e-actions-mailedit-attach').click()", 200
            Sleep 1000
            cbData.SetText path
            cbData.PutInClipboard
            SendKeys "^v", True
            Sleep 1000
            SendKeys "%o", True
            Sleep 1000
            Exit For
        End If
    Next
    
    End If
    
    Sleep 1000
    
    Dim objTag8 As Object
    Dim objTag9 As Object
    Dim flg2 As Boolean
    
    flg2 = False
    
    '保存クリック
    For Each objTag8 In objFrame("s_MainFrame").Document.getElementsByTagName("table")
        For Each objTag9 In objTag8.Document.getElementsByTagName("span")
            If objTag9.innerHTML = "保存" Then
                objTag9.Click
                flg2 = True
                Exit For
            End If
        Next
        If flg2 = True Then
            Exit For
        End If
    Next
    
    Sleep 1000
        
    objIE.Quit
    
    Sleep 1000
        
    Next i
        
    Set objIE = Nothing
        
 End Sub
```