AccessのデータをOutlookのメール本文に流し込む

メモ

Outlook2010
Access2010

Sub CreateEmailfromAccdb()

   dt = InputBox("抽出する日付を入力してください", , Date - 1)
   If IsEmpty(dt) Then '空っぽだったらとめる
       Exit Sub
   ElseIf IsDate(dt) = False Then '日付じゃなかったらとめる
       MsgBox "日付を入力してください"
       Exit Sub
   End If


   Set objWshShell = CreateObject("WScript.Shell")
　'デスクトップの
   dbp = objWshShell.SpecialFolders("Desktop") & "\hoge.accdb"

   Set cn = CreateObject("ADODB.Connection")
   Set rs = CreateObject("ADODB.Recordset")

   cn.ConnectionString = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & dbp & ";"
   cn.Open

   sql = "select * from table1 as t1 inner join table2 as t2 on t1.t = t2.t where l.date1=#" & dt & "#"

   With rs
       .Open sql, cn, 3, 2
       If Not .EOF Then
               buf = "<table border=1 cellpadding=3 style=border-collapse:collapse;font-family:Meiryo UI;>"
           Do While Not .EOF
               buf = buf & "<tr>"
               buf = buf & "<td style=background-color:#fff3b8;font-size:x-small;>" & .Fields(0).Value
               buf = buf & "</td><td style=background-color:#fff3b8;font-size:x-small;>" & .Fields(1).Value
               buf = buf & "</td><td style=background-color:#fff3b8;font-size:x-small;>" & .Fields(2).Value & "</td></tr>"
               buf = buf & "<tr><td colspan=3 style=font-size:x-small;>" & Replace(.Fields(3).Value, vbCrLf, "<br>") & "<p> 　</p></td></tr>"
               .movenext
           Loop
               buf = buf & "</table>"
       End If
       .Close
   End With

   cn.Close
   Set rs = Nothing
   Set cn = Nothing


   Dim objItem As MailItem
   Set objItem = Application.ActiveInspector.CurrentItem '新規作成メール
   objItem.BodyFormat = olFormatHTML 'HTML形式にする

   objItem.Subject = "Log " & dt '件名
   objItem.HTMLBody = buf '本文

End Sub