EXCEL VBA メール送信でファイル添付

質問

現在、使用しているVBAを利用したメンバー向け案内メール配信で、ファイルを添付できないかと考えております。
G列に入力したアドレスのファイルを添付して送信できればと思うのですが、ご教授願えませんでしょうか。

現在のVBAは企業名、宛先共に変えられるように下記のような形となっております。
添付ファイルも宛先毎に異なります。

B列：送信先メールアドレス
C列：メール件名
D列：送信先所属名
E列：送信先宛名
F列：メール本文

コマンドボタンで一括配信となっております。

【以下記述】
Sub Mail_Send()

Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Dim i, LastRow As Integer

' CDOオブジェクト初期設定
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Worksheets("Sheet1").Range("C2").Value
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Worksheets("Sheet1").Range("C3").Value
.Update
End With

' 送信範囲設定
LastRow = Worksheets("Sheet1").Range("B7").End(xlDown).Row

' メール送信ループ
For i = 8 To LastRow

' 送信状況メッセージクリア
Worksheets("Sheet1").Range("F2").Value = ""

' メール本文作成
strbody = Worksheets("Sheet1").Range("D" & i).Value & vbCrLf & "　" & _
Worksheets("Sheet1").Range("E" & i).Value & "　様" & vbCrLf & vbCrLf & _
Worksheets("Sheet1").Range("F" & i).Value

' 改行変換（送信環境によってはここの修正が必要かも）
tmpstrbody = Replace(strbody, vbLf, vbCrLf)
strbody = Replace(tmpstrbody, vbCr & vbCrLf, vbCrLf)

' メール送信
With iMsg
Set .Configuration = iConf
.From = Worksheets("Sheet1").Range("C4").Value
.To = Worksheets("Sheet1").Range("B" & i).Value
.BCC = Worksheets("Sheet1").Range("C5").Value
.Subject = Worksheets("Sheet1").Range("C" & i).Value
.TextBody = strbody
.Send
End With

' 送信状況メッセージ更新
Worksheets("Sheet1").Range("F2").Value = Worksheets("Sheet1").Range("B" & i).Value & " まで送信成功！"

' ３秒停止
Application.Wait [ NOW() + "0:00:03" ]

Next i

End Sub

回答No.2

hallo-2007 · ベストアンサー

確認していませんが、こんな感じで出来たと思います。
・・・
.From = Worksheets("Sheet1").Range("C4").Value
.To = Worksheets("Sheet1").Range("B" & i).Value
.BCC = Worksheets("Sheet1").Range("C5").Value
.Subject = Worksheets("Sheet1").Range("C" & i).Value
.Attachments.Add Worksheets("Sheet1").Range("G" & i).Value'←ここ
.TextBody = strbody
・・・

補足

この記述は私も試してみましたが上手くいきませんでした。
実行時エラー”１３”『型が一致しません』というエラーが出ます。

回答No.3

hallo-2007

原因はわかりませんがとりあえず、昔作成したVBAです。
今でも。（OutLook2002でも）作動はしました。
Microsoft　Outlook　10.0 Object Library にチェックが入っていました。

Sub ボタン1_Click()
'********* OutLook2000を使ってメールを送る *********
'### 使用するクラスを宣言
Dim myOLApp As Object
Dim myDATA As MailItem
'### OUTLOOKのオブジェクトを作成後、メールを新規作成する。
Set myOLApp = CreateObject("Outlook.Application")
Set myDATA = myOLApp.CreateItem(olMailItem)
'### メールの宛先、題名、本文、添付ファイルを設定する。
'（宛先のアドレス）
myDATA.To = Range("B3").Value
myDATA.CC = Range("F3").Value
myDATA.Subject = Range("C3").Value
myDATA.Body = Range("D3").Value + Chr(13)
myDATA.Attachments.Add Range("G3").Value
'### メールを送信
myDATA.Send
'### お約束の後始末。
Set myDATA = Nothing
Set myOLApp = Nothing
End Sub

参考にしてください。

お礼

VBAの参照設定を確認してみたところ、
Microsoft CDO for Windows 2000 Libraryにチェックが入っておりませんでした。
チェックを入れたところ、先にアドバイス頂いた記述で機能致しました。
ありがとうございます。

回答No.1

NNori

この方のページを参照すれば可能だと思います。

参考URL：

http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800_080.html