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/s … = 2
.Item("http://schemas.microsoft.com/cdo/configuration/s … = Worksheets("Sheet1").Range("C2").Value
.Item("http://schemas.microsoft.com/cdo/configuration/s … = 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 回答日時： 2008/07/31 18:25

確認していませんが、こんな感じで出来たと思います。

・・・
.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
・・・

この回答への補足

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

補足日時：2008/07/31 18:53

No.3 回答者： hallo-2007 回答日時： 2008/08/01 13:51

原因はわかりませんがとりあえず、昔作成した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にチェックが入っておりませんでした。
チェックを入れたところ、先にアドバイス頂いた記述で機能致しました。
ありがとうございます。

お礼日時：2008/08/01 17:47

No.1 回答者： NNori 回答日時： 2008/07/31 18:14

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

参考URL：http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub0 …