★Excel2019のVBAからの「Gmail」でのメール送信（Outlook2019利用。「CDO」はGmailでは使えなくなったみたいです。）
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
★ メールが即時送信できる条件
基本、Outlookが起動していること。
起動していない場合は、「Send」メソッドを実行したとしても、「次回起動時」でないと送信されません。
※「起動している」とは、例えばOutlook2019の場合、
(a)普通に画面が見えている状態で普通に起動しているか、
(b)オブジェクト（グローバル変数）として起動され、タスクトレイに常駐しているか、
(c)または、オブジェクト（グローバル変数）として非表示で起動しているか、
（↑(c)は、本当にこの状態があるのかどうかわかりません。未確認です。）
のどれか、です。
※参考図
(b)の場合のタスクトレイ常駐例
なお、(b)の場合は、「普通に画面が見えている状態」ではないわけですが、でも、ちゃんとメールが送れます。日時指定してあっても送れます。（ただし、以降に書いた注意事項を守る必要があります。）
あと、(b)と(c)の、『 オブジェクト（グローバル変数）として起動している場合 』は、そのオブジェクト（グローバル変数）のコードが書かれたExcelファイルを閉じると、それと道連れに『 Outlookが起動した状態 』が消滅してしまうので、メールが送れないことが多々あります。
なので（少なくともメールが全部送れるまでは）、その「コードが書かれたExcelファイル」を閉じないように注意しなければなりません。
もし、例えば(b)の場合で、「数日後に指定した時刻にメールを送れるようにしたい」という場合は、その日時が来るまで、パソコンをシャットダウンさせずに、かつ、その「コードが書かれたExcelファイル」を閉じないで開きっぱなしにしておく必要があります。（もし１度でもパソコンをシャットダウンさせてしまったのなら、その指定した日時まで、毎日、Outlookを「普通に開きっぱなし」にしておかないと指定した日時にメールが送信されません。）
※後日判明：日時指定は、(b)と(c)の場合、コード実行時刻から数時間が空いてしまうと、メールが送れないもようです。送信トレイに溜まったままでした。
Outlookをちゃんと通常起動してないとダメでした。
即送信や30分以内くらいの時間指定なら、もちろん(b)や(c)でもOKですが、
結局のところ、「Outlookを普通に起動・開いたほうが無難」な気がします。
★ 「Gmail」でメール送信
参考
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q11243243566
メール送信には、「CDO」というものを使う・・・、という方法もあるようですが、
https://www.ka-net.org/blog/?p=12806
にも書いてありますが、
2021年5月現在、「Gmailに限って」はそれは使えなくなったようです。
事前に、「Outlook」で「Gmail」が「送受信」できる状態にしておかなければなりません。
その際、Gmail側でも少し設定が要ります。
その際、以下の、２と３だけは先にやっておいたほうがいいかもです。
Outlook2016/2019でGmailのPOP/IMAP・SMTPが設定できない時の対処法
そのうえで、以下のようにOutlookで設定してみます。
Gmail アカウントを Outlook に追加する
サンプルダウンロード
https://euc-access-excel-db.com/00000WPZIP/gmail_make_pdf_send.zip
一覧表から、「名前」で絞り込んだ結果のリストを「PDF化」し、「名前」に紐付いたメールアドレスにGamailにて送信する・・・というサンプルです。
ESETでウィルスチェックしてあります。
書き換える場所は以下です。
(01)「抽出条件」シートの「PDF出力先フォルダ」の内容
実在するフォルダパスに変更してください。
(02)同じく「抽出条件」の「自分のアドレス（送信元）」の内容
Outlookで送受信できるメアドにしてください。
（Gmailじゃなくても可）
(03)「メアド一覧」シートの表の「宛先」の列のメアド
実在するアドレスならなんでもいいです。
もちろん、(02)のアドレスにして、自分に送ってもOKです。
（※ただし、Gmailの場合、既定値だと自分宛てのメールが届かないので、
それを、届くように設定し直さないといけません。
設定するには以下のページの
「★ 自分宛てのメールが届かないトラブルの回避」を参照してください。
https://euc-access-excel-db.com/tips/ct09_biz-pctec/gmail-1st-config01
一応最低限書き換えるのは以上の３か所です。
あとは、「作業一覧」の内容と、
各シートの薄いイエローのセルが書き換えOKのセルです。
実行は、「抽出条件」シートの「PDFファイル生成とメール送信」
ボタンを押すだけです。
(02)で指定したフォルダに社員番号＋名前+年月のPDFができて、
それが添付ファイルとして目的の人にメール送信されます。
一応、Qutlookの挙動が高速じゃないので、
VBAの速度についてこれないのか、ちょっと変なので、
トラブらないように１０秒間隔で送信するようにしてあります。
２秒間隔でもOKでしたけど、マシンの状態に合わせて秒数は変えられます。
なお、Oulookは実行前に事前に立ち上げてあってもOKです。
（内蔵ドライブがSSDじゃなくてHDDのパソコンだとそのほうがおかしな挙動にならなくていいかもです）
あと、もし、「抽出条件」や「メアド一覧」、「作業一覧」などの、
表や設定セルの構造をかえるときは、
プログラムのほうの「test001」というプログラムだけを
いじればOKなようになってます。
その際は、わかりにくいくてすみませんが、
コメントも結構書いたのでそちらもご参考にしてください。
ただ、このサンプルは本番では絶対に使わないでください。
低レベルなのでどんな不具合が起こるかわかりません。
あくまでもヒントにするだけにしてください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
' ' Option Explicit Sub test001() '各ワークシートの設定に使う変数 Dim o_DataWs01 As Worksheet Dim o_JyoukenWs01 As Worksheet Dim o_MailWs01 As Worksheet Dim o_PdfWs01 As Worksheet '主に詳細設定フィルタ（AdvancedFilter）に使う変数 Dim l_MailWsLastRow01 As Long Dim o_CelItem01 As Range Dim l_GyouCount01 As Long '主にPDF生成などに使う変数 Dim s_SyainNo As String Dim s_SyainName As String Dim s_PdfOutPutFolderNm As String Dim s_PdfName As String '主にメール送信に使う変数 Dim o_olApp01 As Object ' Dim v As Variant ' Const olFormatPlain = 1 'Outlook.OlBodyFormat Dim s_TenpuFileFullPath01 As String Dim s_MyMailAddr01 As String Dim s_ToMailAddr01 As String Dim s_MailCc01 As String Dim s_MailBcc01 As String Dim s_MailSubject01 As String Dim s_MailBody01 As String 'メール送信をゆっくりやるための処理に使う変数 Dim d_OldTime As Date '★ 事前準備 ' 'Outlookが起動していないと送信できない場合があるので事前に起動 ' ' ※プログラムを実行する・動かす前に、先に事前に ' ' Outlookを起動しておいても良いです。 Call OutlookBoot(o_olApp01) On Error GoTo 0 '★ 設定部 Set o_DataWs01 = Application. _ ThisWorkbook. _ Worksheets("作業一覧") Set o_JyoukenWs01 = Application. _ ThisWorkbook. _ Worksheets("抽出条件") Set o_MailWs01 = Application. _ ThisWorkbook. _ Worksheets("メアド一覧") Set o_PdfWs01 = Application. _ ThisWorkbook. _ Worksheets("pdf作成") '↑各種シートの設定。 ' 各作業用シートをオブジェクト変数に代入して扱いやすくします。 l_GyouCount01 = 2 '↑メアド一覧シートの社員名が２行目からなので「２」をセット l_MailWsLastRow01 = o_MailWs01.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row '↑メアド一覧シートの最終行をセット '★ 実動部 For Each o_CelItem01 In o_MailWs01.Range("B2:B" & l_MailWsLastRow01) '↑「メアド一覧」シートに対して、その一覧通り、最後の行までを、 ' 上から順番に１行ずつ、以下の処理。 If o_DataWs01.FilterMode = True Then Call OFFAdvancedFilter01(o_DataWs01) Else End If '↑もし、前回のフィルタ結果が解除されて無かったら解呪する。 o_JyoukenWs01.Range("C2") = o_CelItem01.Value '↑「抽出条件」シートの C2セルに、 ' o_CelItem01 セル（つまりメアド一覧シートのB列のセル）の値 ' つまり、社員名を入力 ' 入力と同時にVLOOKUP関数でメールアドレスが切り替わります。 Call RunAdvancedFilter01(o_DataWs01, _ "A1:F", _ o_JyoukenWs01, _ "A1:C2") '↑「抽出条件」シートの条件通りに、フィルタを実行。 ' オートフィルタではなくて、詳細設定フィルタで。 o_PdfWs01.Range("A4:F500").Rows.Delete '一応、500行分を「初期化」の意味で削除。必要に応じて変える。 o_DataWs01.UsedRange.Copy Destination:=o_PdfWs01.Range("A4") '↑PDF精製用データの用意（「pdf作成」シートに。） ' 罫線は「作業一覧」シートで書いておき、それもろとも、データコピー。 ' なのでその罫線を切りよく転記するために、いったん、行ごと消してしまっています。 s_SyainNo = o_CelItem01.Offset(0, -1).Value '現在の社員名のセルの左のセルの値＝社員番号を指定 s_SyainName = o_CelItem01.Value '↑PDFにつける名前の準備 s_PdfOutPutFolderNm = o_JyoukenWs01.Range("F2").Value '↑PDFの格納先の設定 s_PdfName = s_SyainNo & _ s_SyainName & _ o_JyoukenWs01.Range("C4") & _ ".pdf" '↑社員番号や年月を付加したファイル名の生成 Call PdfMake01(o_PdfWs01, s_PdfOutPutFolderNm, s_PdfName) '↑PDFの生成と、指定したフォルダへの格納 s_TenpuFileFullPath01 = s_PdfOutPutFolderNm & "\" & s_PdfName '添付PDFのフルパス s_MyMailAddr01 = o_JyoukenWs01.Range("H2") '自分のメアド s_ToMailAddr01 = o_JyoukenWs01.Range("E2") '宛先のメアド s_MailCc01 = "" 'CC s_MailBcc01 = "" 'BCC s_MailSubject01 = s_SyainName & o_JyoukenWs01.Range("H5") '件名 s_MailBody01 = s_SyainName & o_JyoukenWs01.Range("H8") '本文 '↑メール送信に関する設定 Debug.Print s_ToMailAddr01 Call OutlookSendMail01(o_olApp01, _ s_TenpuFileFullPath01, _ s_MyMailAddr01, _ s_ToMailAddr01, _ s_MailCc01, _ s_MailBcc01, _ s_MailSubject01, _ s_MailBody01) '↑Outlookを利用して実際にメール送信 ' ThisWorkbook.Worksheets("作業一覧").Activate Call OFFAdvancedFilter01(o_DataWs01) '↑一応、念のためにフィルタ解除 l_GyouCount01 = l_GyouCount01 + 1 '↑メアド一覧シートのB列の次行の値をGetするために、＋１する。 ' ThisWorkbook.Worksheets("pdf作成").Activate ' ThisWorkbook.Worksheets("抽出条件").Activate d_OldTime = Now Debug.Print d_OldTime Do Until d_OldTime + TimeValue("0:00:05") < Now DoEvents Loop '↑一度に一気に送るとOutlookがフリーズしたみたいになったり ' 挙動がおかしいので、１０秒おきにゆっくり送信する｡ ' 大丈夫なら「TimeValue("0:00:10")」の「10」を７や５、２、などに変えてみる。 ' テストでは２でもいけた。 ' DoEventsの使い方があってるかわからないけど、とりあえずこれで。 ' DoEventsしておかないと、Excel画面が最小化できないので。 Next o_CelItem01 MsgBox "完了しました！" End Sub '##################################################################################### ' Outlookを起動するだけの処理。 ' https://www.ka-net.org/blog/?p=12806 を少し改変。 ' Outlookが起動していないと送信できない場合があるので事前に起動します。 ' ※プログラムを実行する・動かす前に、先に事前に ' 先にOutlookを起動しておいても良いです。' ' その状況にも対応しています。 '##################################################################################### Sub OutlookBoot(ByRef olApp01 As Object) 'https://www.ka-net.org/blog/?p=12806 On Error Resume Next Set olApp01 = GetObject(, "Outlook.Application") '↑すでにOutlookが起動している場合専用のコード。 ' すでにOutlookが起動していたら、それをゲットして ' オブジェクト変数の「olApp01」に代入する。 ' Outlookが起動していないとエラーになってしまうので、 ' 前行の「On Error Resume Next」でエラー回避しています。 If olApp01 Is Nothing Then '↑オブジェクト変数の「olApp01」の中身が空っぽだったら ' ＝Outlookが起動したいなかったら以下の処理 Shell "OUTLOOK.EXE", vbNormalFocus '↑Outlookを起動。 Do Set olApp01 = GetObject(, "Outlook.Application") DoEvents Loop While olApp01 Is Nothing '↑Outlookが起動しきるまで待つ？ ' olApp01が空っぽの間ぢゅうは、 ' ＝Outlookが起動してない間ぢゅうは、 ' 次へ行かずに、ここでこのまま、 ' ずーっと無限ループし続ける。 End If On Error GoTo 0 End Sub '##################################################################################### ' 「詳細設定」のフィルタを実行するだけの処理。（「オートフィルタ」ではなく。） ' 'o_DataWs02：絞り込み対象（フィルタ対象）のシートをWorksheetオブジェクトとして指定 's_DataRngAddr02：そのシートの絞込み対象の「表」のセル範囲をA1形式で指定。 'o_JyoukenWs02：フィルタの条件のセルが在るシートをWorksheetオブジェクトとして指定 's_JyoknRngAddr02：そのフィルタ条件の在るセル範囲をA1形式で指定。 '##################################################################################### Sub RunAdvancedFilter01(o_DataWs02 As Worksheet, _ s_DataRngAddr02 As String, _ o_JyoukenWs02 As Worksheet, _ s_JyoknRngAddr02 As String) Dim l_LastRow As Long l_LastRow = o_DataWs02.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row o_DataWs02.Range(s_DataRngAddr02 & l_LastRow).AdvancedFilter _ Action:=xlFilterInPlace, _ CriteriaRange:=o_JyoukenWs02.Range(s_JyoknRngAddr02), _ Unique:=False End Sub '##################################################################################### ' フィルタを解除するだけの処理 ' 'DataWs02：フィルタを解除したいシートを、Worksheetオブジェクトとして指定 '##################################################################################### Sub OFFAdvancedFilter01(DataWs02 As Worksheet) DataWs02.ShowAllData End Sub '##################################################################################### ' 指定したシートをPDF化するだけの処理。 ' 'o_PdfWs02：PDF化したいシートを 's_OutPutPath02：PDFを書き出したい実在するフォルダの「フルパス」の指定 's_PdfName02：PDFにつけたい名前。 '##################################################################################### Sub PdfMake01(o_PdfWs02 As Worksheet, _ s_OutPutPath02 As String, _ s_PdfName02 As String) o_PdfWs02.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=s_OutPutPath02 & "\" & s_PdfName02, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False '↑構造タグを埋め込まずに、書き出してもAcrobatなどを開かずにPDF作成。 ' 構造タグを埋め込んでしまうと、正常なテキスト検索ができなくなるので ' ここではそれを回避しています。（バージョン２０１０だけかも？未チェックです。） ' 「ExportAsFixedFormat」では、基本、同名のPDFは自動的に上書きされます。 End Sub '##################################################################################### ' Outlookでメールを送る前の準備だけをする処理 ' https://www.ka-net.org/blog/?p=12806 を少し改変 ' ' ' '##################################################################################### Public Sub OutlookSendMail01(o_olApp02 As Object, _ s_TenpuFileFullPath02 As String, _ s_MyMailAddr02 As String, _ s_ToMailAddr02 As String, _ s_MailCc02 As String, _ s_MailBcc02 As String, _ s_MailSubject02 As String, _ s_MailBody02 As String) ' Dim olApp As Object Dim v As Variant Const olFormatPlain = 1 'Outlook.OlBodyFormat ' ' 'Outlookが起動していないと送信できない場合があるので事前に起動 ' On Error Resume Next ' Set olApp = GetObject(, "Outlook.Application") ' If olApp Is Nothing Then ' Shell "OUTLOOK.EXE", vbNormalFocus ' Do ' Set olApp = GetObject(, "Outlook.Application") ' DoEvents ' Loop While olApp Is Nothing ' End If ' On Error GoTo 0 '添付ファイル ' v = Array("C:\temp\job_barista_man.png", _ ' "C:\temp\job_barista_woman.png", _ ' "C:\temp\job_cafe_tenin_woman.png") ' v = Array("D:\1\autofit.xlsm") v = Array(s_TenpuFileFullPath02) SendGmailUsingOutlook01 _ MailApp:=o_olApp02, _ AccountAddress:=s_MyMailAddr02, _ MailTo:=s_ToMailAddr02, _ MailCc:=s_MailCc02, _ MailBcc:=s_MailBcc02, _ MailSubject:=s_MailSubject02, _ MailBody:=s_MailBody02, _ MailBodyFormat:=olFormatPlain, _ AttachmentFilePath:=v, _ FlgSend:=True End Sub '##################################################################################### ' Outlookでメール送信するだけの処理。 ' https://www.ka-net.org/blog/?p=12806 の「まんま」 ' ' ' '##################################################################################### Private Sub SendGmailUsingOutlook01( _ ByVal MailApp As Object, _ ByVal AccountAddress As String, _ ByVal MailTo As String, _ ByVal MailCc As String, _ ByVal MailBcc As String, _ ByVal MailSubject As String, _ ByVal MailBody As String, _ Optional ByVal MailBodyFormat As Long = 1, _ Optional ByVal AttachmentFilePath As Variant = Empty, _ Optional ByVal FlgSend As Boolean = True) 'Outlookを使ってGmail送信を行うVBAマクロ '※要Gmailアカウントの追加 'https://support.office.com/ja-jp/article/70191667-9c52-4581-990e-e30318c2c081 参照 Dim accGmail As Object 'Outlook.Account Dim i As Long Const olMailItem = 0 Set accGmail = MailApp.Session.Accounts.Item(AccountAddress) If accGmail Is Nothing Then Exit Sub With MailApp.CreateItem(olMailItem) .To = MailTo If Len(Trim(MailCc)) > 0 Then .CC = MailCc If Len(Trim(MailBcc)) > 0 Then .BCC = MailBcc .Subject = MailSubject .BodyFormat = MailBodyFormat If Not IsEmpty(AttachmentFilePath) Then For i = LBound(AttachmentFilePath) To UBound(AttachmentFilePath) .Attachments.Add AttachmentFilePath(i) Next End If .Body = MailBody Set .SendUsingAccount = accGmail If FlgSend Then .Send Else .Display End If End With End Sub ' ' |
- 投稿タグ
- AccessVBA, Accessの独学, Access操作の基礎, ExcelVBA, Excelの独学, Excel操作の基礎, Excel連携VBA, Gmail, Outlookの基礎, PDF, パソコンでの自動化, ビジネスパソコンの基礎, ビジネス一般常識, マクロ, 独学, 自動化
