Access VBA CDOで添付ファイルを行ごとに記載されているアドレス宛にメールする。

Question

前提

objCDO.AddAttachment について教えて頂けないでしょうか？

ACCESS　VBA　

実現したいこと

ACCESSのVBAで添付メール１個を複数の人に送りたい。
（ACCESS2016でメールの一括送信は実現している。）

発生している問題・エラーメッセージ

objCDO.AddAttachment ”フルバス" で
１通目　aという１ファイル添付
２通目　aという２ファイル添付
３通目　aという３ファイル添付
という倍数ゲームになってしまった。

呼び出すテーブルにはメールアドレスやあて名が入っていて
本文セクションをメールして次の行にいく感じになってます。

Option Compare Database

Public Function cdoSendMail_yoyaku_ka() As Boolean

Dim objCDO
Dim MSgw
Dim lbRet   As Boolean
Dim lsMsg   As String

On Error GoTo Err_Exit

 '--- 初期値セット ---
lbRet = False
lsMsg = ""

'戻り値の初期化
cdoSendMail_yoyaku_ka = True
  
Set objCDO = CreateObject("CDO.Message")

'CDOのスキーマを定義
MSgw = "http://schemas.microsoft.com/cdo/configuration/"

With objCDO.Configuration.Fields
    
'メール送信方法
    .Item(MSgw & "sendusing") = 2
    
    'SMTPサーバーのアドレス
    .Item(MSgw & "smtpserver") = ""
    
    'SMTPサーバーのポート
    .Item(MSgw & "smtpserverport") = 465
    
    '差出人ユーザー名
    .Item(MSgw & "sendusername") = ""
    
    '認証コード
    .Item(MSgw & "sendpassword") = ""
    
    'SSL認証要
    .Item(MSgw & "smtpusessl") = True
    
    '認証方式(1)
    .Item(MSgw & "smtpauthenticate") = cdoBasic
    
    'タイムアウト
    .Item(MSgw & "smtpconnectiontimeout") = 60
    
    .Update
    
End With
 

'差出人メールアドレス

objCDO.From = ""


Dim dbo As DAO.Database
Dim rst As DAO.Recordset
Dim sSqlStr As String
Dim sTo As String
Dim sCC As String
Dim sBCC As String
Dim skibou As String
Dim sname As String
Dim bumon As String
Dim renraku As String
Dim dkibou As String
Dim stime As String
Dim etime As String
Dim uke As String

sSqlStr = "SELECT * FROM 該当のテーブル名"
Set dbo = CurrentDb
Set rst = dbo.OpenRecordset(sSqlStr)

 
Do Until rst.EOF

'あて先メールアドレス
objCDO.To = rst.Fields("メールアドレス")

sTo = rst.Fields("メールアドレス")

　　　'BCCメール指定
objCDO.BCC = ""

'件名
objCDO.Subject = "件名をココ"



'申請者氏名
sname = rst.Fields("氏名")


'本文

objCDO.TextBody = " " _
& vbNewLine & sname + "様" _
& vbNewLine _
& vbNewLine & "２行目はココ" _
& vbNewLine & "３行目はココ" _
& vbNewLine & "４行目はココ" _


'添付ファイル
objCDO.AddAttachment "C:\work\hoge.zip"

'文字化け対応のため追加
objCDO.TextBodyPart.Charset = "ISO-2022-JP"
 
objCDO.Send

rst.MoveNext

Loop

'CDOオブジェクトの解放
Set objCDO = Nothing

MsgBox "メールを送信しました。", vbOKOnly + vbInformation, "送信完了"

cdoSendMail_hoge = True

lbRet = True

rst.Close

dbo.Close

Exit Function

Err_Exit:

Select Case Err.Number
Case -2147220977

lsMsg = Err.Description & Err.Number & vbCrLf

Call sOutputLoglist(lsMsg)

    Resume Next

Case Else
       
   MsgBox Err.Number & ":" & Err.Description & vbCrLf, vbOKOnly + vbCritical + vbSystemModal, "その他のエラー"

'CDOオブジェクトの解放
Set objCDO = Nothing

End Select

End Function

ソースコード

試したこと

objCDO.AddAttachment "C:\work\hoge.zip"　の記載を
違うところに置いたりと，色々と試してみたけど，
根本的な理解がないのでなにか違うような気がします・・・。

補足情報（FW/ツールのバージョンなど）

なんかすみません。

Answer 1

全て同じファイルを送付するのなら、ループの前に1回だけ追加すればいいのでは。

'略

objCDO.AddAttachment "C:\work\hoge.zip" 
Do Until rst.EOF

'略

Loop

違うファイルなら、送信後に削除する(Removeメソッド)ことになると思います。

Attachments.Remove メソッド (Outlook) | Microsoft Learn

Comments

[emplus]

解決しました。思考回路の違いを実感しました。開発陣はすごいですね。
rst.MoveNext の前後に一回「解放」「解除」という方向しか考えてませんでした。

'添付ファイル
objCDO.AddAttachment "hoge.zip"

Do Until rst.EOF

'文字化け対応のため追加
objCDO.TextBodyPart.Charset = "ISO-2022-JP"

objCDO.Send

rst.MoveNext

Loop
Loop