コピペメールを大量に送るのがしんどい
派遣社員さんにお願いしている業務の中で宛先と本文の一部を変更して数十通のメールを送る作業がありました。
ファイルの添付もあり地味ながら辛い作業ということでどうにか自動化できないかといろいろ試してみた結果、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