プロが教える店舗＆オフィスのセキュリティ対策術

マジレス希望

【Excel VBA】自動メール送信の機能追加

解決済

  • 質問者：まさまちゃ
  • 質問日時：
  • 回答数：5件

現在、下記のコードでsheetの更新をし保存で閉じた際自動でメール送信をする
マクロで約半年運用しております。
今回、以下の指定した範囲以外を更新した時は「別アドレス」「別メール」を同じ様に
自動送信したいと思っております。※件名、本文も別
（現範囲）　S4:S200
（追加範囲）M4:M200
追記可能であればご教授頂ければと思っております。
よろしくお願い致します。
----------------------------------------------------------------------------
Option Explicit
Private SavedFlg As Boolean '//保存の変数
Private ChangeFlg As Boolean '//範囲変更の変数
'標準モジュールに別途「 Public myShFlg() As Boolean 」記述あり
Private Sub Workbook_Open()

Dim i As Long
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数の準備を下記「Workbook_BeforeClose」にする
For i = 1 To ThisWorkbook.Sheets.Count
myShFlg(i) = False '念のために全てFalseをセット
Next i
End Sub

'範囲指定フラグ
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

'If Intersect(Target, Sh.Range("S1")) Is Nothing Then Exit Sub '【メンテナンス用】

If Intersect(Target, Sh.Range("S4:S200")) Is Nothing Then Exit Sub '//指定範囲　日計表処理が「済」
ChangeFlg = True '//範囲外ならMail送信しないフラグ
myShFlg(Sh.Index) = True '//更新されたシートのフラグをTrueに

End Sub

'保存フラグ
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
SavedFlg = True
End Sub

'ファイルを閉じ保存した時に更新シート別にメールを送信
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Const olMailItem = 0
Const olFormatPlain = 1

If Not Saved Then
Select Case MsgBox("'" & ThisWorkbook.Name & "' の変更内容を保存しますか？", vbExclamation + vbYesNoCancel)
Case vbYes
Application.EnableEvents = False
ThisWorkbook.Save
Application.EnableEvents = True
SavedFlg = True
Case vbNo
ThisWorkbook.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If

If Not SavedFlg Then Exit Sub
If Not ChangeFlg Then Exit Sub

'//シートごとのアドレス設定＿複数Add設定は「;」で区切る。
'myShFlg(〇)はタブ左からのNo.

'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス", Worksheets(1).Name)
'sheet2
If myShFlg(2) Then Call myMailSend("メールアドレス", Worksheets(2).Name)
'sheet3
If myShFlg(3) Then Call myMailSend("メールアドレス", Worksheets(3).Name)
　　'実際は24タブあり

Exit Sub
End Sub

続く・・・

質問者からの補足コメント

  • どう思う？

    'ファイルを閉じ保存した時更新シート別にメールを送信
    Sub myMailSend(myToAdd As String, myShName As String)

    On Error GoTo ErrorHandler
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    続く・・・

      補足日時：2022/09/29 12:57
    通報する

  • With objOutlook.CreateItem(olMailItem)
    .To = myToAdd
    .CC = "メールアドレス"
    .BCC = ""
    .Subject = "【" & myShName & "】 " & "更新のお知らせ(自動送信)"
    .Body = "担当者 様" & vbCrLf & _
    "処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
    "ご確認下さい。"

    .BodyFormat = olFormatPlain '//テキストメール指定
    .Send
    End With

      補足日時：2022/09/29 12:58
    通報する

  • Finally:
    Set objOutlook = Nothing
    Exit Sub
    ErrorHandler:
    MsgBox "メールの送信に失敗しました。", vbOKOnly + vbCritical
    Resume Finally

    End Sub
    ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
    長くなりましたが以上です。
    よろしくお願いいたします。

      補足日時：2022/09/29 12:59
    通報する
通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (5件)

No.4ベストアンサー

  • 回答者： Qchan1962
  • 回答日時：

連投すみません


シートごとのフラグをたてる必要がありますね（変数スコープは不明）
判り難くなってしまうかもなので今与えられているコードの添削します　

Private SavedFlg As Boolean '//保存の変数
Private ChangeFlg As Boolean '//範囲変更の変数
Private RangeFlg() As Boolean
Private myShFlg() As Boolean

'標準モジュールに別途「 Public myShFlg() As Boolean 」記述あり
Private Sub Workbook_Open()
Dim i As Long
ReDim myShFlg(1 To ThisWorkbook.Sheets.Count) 'シート数の準備を下記「Workbook_BeforeClose」にする
ReDim RangeFlg(1 To ThisWorkbook.Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
myShFlg(i) = False '念のために全てFalseをセット
RangeFlg(i) = False
Next i
End Sub

'範囲指定フラグ
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'If Intersect(Target, Sh.Range("S1")) Is Nothing Then Exit Sub '【メンテナンス用】
If Intersect(Target, Sh.Range("S4:S200,M4:M200")) Is Nothing Then Exit Sub '//指定範囲　日計表処理が「済」
If Target.Column = 13 Then
RangeFlg(Sh.Index) = True
Else
RangeFlg(Sh.Index) = False
End If
ChangeFlg = True '//範囲外ならMail送信しないフラグ
myShFlg(Sh.Index) = True '//更新されたシートのフラグをTrueに
End Sub

'保存フラグ
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
SavedFlg = True
End Sub

'ファイルを閉じ保存した時に更新シート別にメールを送信
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Const olMailItem = 0
Const olFormatPlain = 1

If Not Saved Then
Select Case MsgBox("'" & ThisWorkbook.Name & "' の変更内容を保存しますか？", vbExclamation + vbYesNoCancel)
Case vbYes
Application.EnableEvents = False
ThisWorkbook.Save
Application.EnableEvents = True
SavedFlg = True
Case vbNo
ThisWorkbook.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If

If Not SavedFlg Then Exit Sub
If Not ChangeFlg Then Exit Sub

'//シートごとのアドレス設定＿複数Add設定は「;」で区切る。
'myShFlg(〇)はタブ左からのNo.
'M4:M200が変更された場合、RangeFlg＝True
Dim myCCAdd() As String
ReDim myCCAdd(24, 1)
'M列アドレス
myCCAdd(1, 0) = "メールアドレス1"
myCCAdd(2, 0) = "メールアドレス2"
myCCAdd(3, 0) = "メールアドレス3"
myCCAdd(4, 0) = "メールアドレス4"
'実際は24タブあり
'S列アドレス
myCCAdd(1, 1) = "メールアドレス1"
myCCAdd(2, 1) = "メールアドレス2"
myCCAdd(3, 1) = "メールアドレス3"
myCCAdd(4, 1) = "メールアドレス4"
'実際は24タブあり

For i = 1 To UBound(myShFlg)
'M列ならば
If RangeFlg(i) Then
If myShFlg(i) Then Call myMailSend(myCCAdd(i, 0), Worksheets(i).Name, RangeFlg(i))
Else
If myShFlg(i) Then Call myMailSend(myCCAdd(i, 1), Worksheets(i).Name, RangeFlg(i))
End If
Next

Exit Sub
End Sub
    • good
    • 1
    • 件
通報する
この回答へのお礼

長文ありがとうございました。
こちらをベストアンサーとさせて頂きます。
ありがとうございました。

通報する
お礼日時：2022/09/30 22:44

No.5

  • 回答者： Qchan1962
  • 回答日時：

続き


Sub myMailSend(myToAdd As String, myShName As String, rngFlg As Boolean)
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim myBody As String
If rngFlg Then
'M用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
Else
'S用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
End If

With objOutlook.CreateItem(olMailItem)
.To = myToAdd
.CC = "メールアドレス"
.BCC = ""
.Subject = "【" & myShName & "】 " & "更新のお知らせ(自動送信)"
.Body = myBody
.BodyFormat = olFormatPlain '//テキストメール指定
.Send
End With
Finally:
Set objOutlook = Nothing
Exit Sub
ErrorHandler:
MsgBox "メールの送信に失敗しました。", vbOKOnly + vbCritical
Resume Finally

End Sub
    • good
    • 1
    • 件
通報する

No.3

  • 回答者： Qchan1962
  • 回答日時：

続き


④メール作成プロシージャ　引数を増やしBody文字列を作成
Sub myMailSend(myToAdd As String, myShName As String, rngFlg As Boolean)
On Error GoTo ErrorHandler
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim myBody As String
If rngFlg Then
'M用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
Else
'S用メッセージ
myBody = "担当者 様" & vbCrLf & _
"処理が完了致しましたのでお知らせ致します。" & vbCrLf & _
"ご確認下さい。"
End If

With objOutlook.CreateItem(olMailItem)
.To = myToAdd
.CC = "メールアドレス"
.BCC = ""
.Subject = "【" & myShName & "】 " & "更新のお知らせ(自動送信)"
.Body = myBody
.BodyFormat = olFormatPlain '//テキストメール指定
.Send
End With
.Subjectも変更したいようですが、内容がわからないので
.Body = myBodyを参考に変更すれば容易と思われます

もっと複雑な条件、内容が必要な場合はシートのセルを使ったり
Select Caseで条件分岐して必要なアドレス、件名、本文を文字列として作成するのが良いと思います

以上4か所ですが、想像の範疇もありますがどうでしょう
    • good
    • 1
    • 件
通報する

No.2

  • 回答者： Qchan1962
  • 回答日時：

やはり文章では無理か‥


＃１の内容をコードにしてみました
＞'標準モジュールに別途　など不明な処理があるので上手くいくかは分かりませんが、M4:M200を追加して　その時にメールの内容を変える
出来るだけ既存コードの変更をしない・・・と下記の箇所を書き換えてみてください（必ずコピーファイルでテストしてください）
記載モジュールを変更する必要はないと思います
追加場所は、重複するコードで判断してください
①1行のみ追加
Option Explicit
Private SavedFlg As Boolean '//保存の変数
Private ChangeFlg As Boolean '//範囲変更の変数
Private RangeFlg As Boolean '//範囲のカラム位置を判定する変数
'標準モジュールに別途「 Public myShFlg() As Boolean 」記述あり

②　,M4:M200　If Target.Column = 13 Then RangeFlg = True　追加

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'If Intersect(Target, Sh.Range("S1")) Is Nothing Then Exit Sub '【メンテナンス用】
If Intersect(Target, Sh.Range("S4:S200,M4:M200")) Is Nothing Then Exit Sub '//指定範囲　日計表処理が「済」
If Target.Column = 13 Then RangeFlg = True
ChangeFlg = True '//範囲外ならMail送信しないフラグ

③　アドレス設定、範囲フラグを追加
（多分、もっとシンプルだと思いますが）

//シートごとのアドレス設定＿複数Add設定は「;」で区切る。
'myShFlg(〇)はタブ左からのNo.
'M4:M200が変更された場合、RangeFlg＝True
If RangeFlg Then
'M列ならば
'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス1", Worksheets(1).Name, RangeFlg)
'sheet2
If myShFlg(2) Then Call myMailSend("メールアドレス1", Worksheets(2).Name, RangeFlg)
'sheet3
If myShFlg(3) Then Call myMailSend("メールアドレス1", Worksheets(3).Name, RangeFlg)
'実際は24タブあり
Else
'S列ならば
'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス", Worksheets(1).Name, RangeFlg)
'sheet2
If myShFlg(2) Then Call myMailSend("メールアドレス", Worksheets(2).Name, RangeFlg)
'sheet3
If myShFlg(3) Then Call myMailSend("メールアドレス", Worksheets(3).Name, RangeFlg)
'実際は24タブあり
End If

文字数制限の為、続く
    • good
    • 1
    • 件
通報する
この回答へのお礼

理解不足の為、大変お手数お掛け致しました。
少しカスタマイズさせて頂き、無事作動を確認致しました。
本当にありがとうございました。

通報する
お礼日時：2022/09/30 22:47

参考程度に

No.1

  • 回答者： Qchan1962
  • 回答日時：

こんにちは


ご質問を理解していなかったらスルーしてください

＞以下の指定した範囲以外を更新した時
（現範囲）　S4:S200
（追加範囲）M4:M200
でフラグをたてるのであれば、Workbook_SheetChangeイベントを変更すれば良いと思います
'範囲指定フラグ
If Intersect(Target, Sh.Range("S4:S200,M4:M200")) Is Nothing Then Exit Sub '//指定範囲　日計表処理が「済」
とすれば実行範囲を広げられます

シートの振り分けについては　Sh.Index　で設定しているようですので
Select Case Sh.Index　とか・・If Sh.Indexとかで　フラグ設定すれば良さそうですね
シート振り分け、範囲振り分けはどちらを先にするかは、考察してください
（シート又は範囲振り分け時に下記のフラグ設定も可能）

メールアドレス、本文については
現状　myMailSendの引数でメールアドレス、件名を設定しているようですね
'sheet1
If myShFlg(1) Then Call myMailSend("メールアドレス", Worksheets(1).Name)
やり方は色々あると思いますが
引き数を増やして（メールアドレス、件名、本文またはフラグ）にして条件や新たなフラグ設定などで振り分けるとかですかね

文章の説明なので上手く伝わりますでしょうかね？
    • good
    • 1
    • 件
通報する
この回答へのお礼

ご回答ありがとうございます。
質問が伝わりにくかったようで申し訳ございません。
範囲のS４:S400 は現行のマクロ
範囲のM4:M400 の更新は別アドレス宛（件名・本文も別設定）
ド素人の為、なるべく現在のマクロをいじりたくなく、追加（多少の変更）で対処したいのです。

通報する
お礼日時：2022/09/29 13:56

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

ページトップページトップ

Q質問する（無料）

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報