AccessデータベースからEメールを送る（サンプル付き）

Option Compare Database

Private Sub cmd_送信_Click()
    Dim rs As DAO.Recordset
    Set rs = CurrentDb.OpenRecordset("T_メール送信履歴", dbOpenTable)
    
    With rs
        .AddNew
        .Fields("送信日時") = Now
        .Fields("本文") = "本文"
        .Fields("可否") = cdoSendMail
        .Update
    End With
    
    rs.Close
    Set rs = Nothing
End Sub

'------------------------------------------------------------
'   処理内容:CDOメール送信
'   引数:なし
'   戻り値:True/False
'   参考Webサイト：https://asbepartners.com/send_mail/
'------------------------------------------------------------
Public Function cdoSendMail() As Boolean

    Dim objCDO
    Dim MSgw
    
    Dim txtアドレス As String
    Dim txtパスワード As String
    Dim txt社員 As String
    Dim sql As String
    
    Dim rs As DAO.Recordset
    
    sql = "SELECT * FROM T_社員 WHERE 社員コード=" & 10001 'メールする人を選択
    Set rs = CurrentDb.OpenRecordset(sql)
    txtアドレス = rs.Fields("アドレス")
    txtパスワード = rs.Fields("パスワード")

    
    On Error GoTo Err_Exit
    
    '戻り値の初期化
    cdoSendMail = False
      
    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") = "mail.biglobe.ne.jp" 'Biglobeでテストしました。各自の環境に合わせて要書き換えてください！
        'SMTPサーバーのポート
        .Item(MSgw & "smtpserverport") = 465 'Biglobeでテストしました。各自の環境に合わせて要書き換えてください！
        '差出人ユーザー名
        .Item(MSgw & "sendusername") = txtアドレス
        '認証コード
        .Item(MSgw & "sendpassword") = txtパスワード
        'SSL認証要
        .Item(MSgw & "smtpusessl") = True
        '認証方式(1)
        .Item(MSgw & "smtpauthenticate") = cdoBasic
        'タイムアウト
        .Item(MSgw & "smtpconnectiontimeout") = 60
        .Update
    End With
     
    '差出人メールアドレス
    objCDO.From = txtアドレス
    
    'あて先メールアドレス
    objCDO.To = txtアドレス '管理者のメールアドレスなどに書き換えてください
    
    'CCメールアドレス
    'objCDO.CC = Me.txtCC '必要に応じて書き換えてください
    
    '件名
    objCDO.subject = "送信テスト件名" '必要に応じて書き換えてください
    '本文
    objCDO.textBody = "送信テスト本文" '必要に応じて書き換えてください
    
    '文字化け対応のため追加
    objCDO.TextBodyPart.Charset = "ISO-2022-JP"
     
    objCDO.send
    
    MsgBox "メールを送信しました。", vbOKOnly + vbInformation, "送信完了"
    
    '正常終了
    cdoSendMail = True

    Set rs = Nothing
    rs.Close
    
    Exit Function
    
Err_Exit:
    MsgBox Err.Number & ":" & Err.Description, vbOKOnly + vbCritical, "cdoSendMail()"

End Function

Public Function cdoSendMail(txtアドレス As String,txtパスワード as String) As Boolean