概要
Excelで表形式になっている一覧の更新を内容とともに通知するサンプルです。
通知はOutlookメール、クリップボードに格納のいずれかを選べます。
元のExcelのフォーマットによりカスタマイズして使うことを想定しています。
ソース
Sub Excelの更新を通知する()
'--------------------------------------
'Excelで表形式で管理されている情報を更新後に通知する
' Outlookメール作成またはクリップボードに通知を格納
'--------------------------------------
'参照設定が必要なライブラリ（[ツール]-[参照設定]で設定しておく）
'Microsoft Outlook XX.X Object Library
'"C:\Windows\System32\FM20.DLL"または"C:\Windows\System32\FM20.DLL" 'クリップボード
Dim MsgRtn As Integer 'Msgbox返り値
Dim shName As String '対象シート名
Const HeaderRow As Long = 3 'ヘッダー行（1行のみ指定可）
Dim rng As Range '選択範囲
Dim strRows As String '選択範囲（確認メッセージ用の行のみの文字列）
Dim strMsg As Variant '通知メッセージ全量
Dim strVerb As String '通知メッセージ内依頼文
Dim objOutlook As Outlook.Application 'Outlook
Dim objMail As Outlook.MailItem 'Outlookメール
'シート名チェック
shName = "ファイルリスト"
If ActiveSheet.Name <> shName Then
MsgRtn = MsgBox("シート名エラーです。中断します。" _
, vbOKOnly + vbExclamation, Title:="エラー")
Exit Sub
End If
'--------------------------------------
'開始メッセージ
'--------------------------------------
strRows = ""
For Each rng In Selection.Rows
If strRows = "" Then
strRows = rng.Row
Else
strRows = strRows & " ," & rng.Row
End If
Next rng
If vbYes = MsgBox(strRows & " 行目が出力されます。" & vbLf & vbLf & _
"選択した行の内容が出力されます。出力したい行を選んでから実行してください（複数行選択も可）。" _
, vbYesNo + vbInformation, Title:="開始") Then
Else
Exit Sub
Set rng = Nothing
End If
'--------------------------------------
'★依頼文を変えたい場合はここを変更する
'起票か回答か確認（更新通知の文面の依頼分が変わる）
'--------------------------------------
MsgRtn = MsgBox("起票ですか？回答ですか？" & _
vbLf & vbLf & _
"起票：はい" & vbLf & _
"回答：いいえ" & vbLf _
, vbYesNo + vbInformation, Title:="起票 or 回答")
If MsgRtn = vbYes Then
strVerb = "起票しました。回答お願いします。"
ElseIf MsgRtn = vbNo Then
strVerb = "回答しました。確認お願いします。"
End If
'--------------------------------------
'更新内容取得
'--------------------------------------
strMsg = "★ファイル名★" & vbCrLf
strMsg = strMsg & "★格納先★" & vbCrLf & vbCrLf
strMsg = strMsg & String(50, "-") & vbCrLf
For Each rng In Selection.Rows
'出力したい列分書く
strMsg = strMsg & "[" & Replace(Cells(HeaderRow, 1), vbLf, "") & "] " & Cells(rng.Row, 1) & vbCrLf
strMsg = strMsg & "[" & Replace(Cells(HeaderRow, 3), vbLf, "") & "] " & Cells(rng.Row, 3) & vbCrLf
strMsg = strMsg & "[" & Replace(Cells(HeaderRow, 5), vbLf, "") & "] " & Cells(rng.Row, 5) & vbCrLf
strMsg = strMsg & vbCrLf
Next rng
strMsg = strMsg & String(50, "-") & vbCrLf & vbCrLf
strMsg = strMsg & "以上"
'--------------------------------------
'更新通知の出力
'--------------------------------------
MsgRtn = MsgBox("結果の出力先を選んでください。" & _
vbLf & vbLf & _
"はい ：Outlookメール" & vbLf & _
"いいえ：クリップボード" & vbLf _
, vbYesNoCancel + vbInformation, Title:="結果")
'クリップボード
If MsgRtn = vbYes Then
Set objOutlook = New Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
''.To = "address" '宛先
.Subject = "表を更新しました。" '件名
.Body = strMsg '本文
.BodyFormat = olFormatPlain 'メール形式
.Display
End With
Set objMail = Nothing
Set objOutlook = Nothing
'完了メッセージ出さない（Outlookメールが前面に出るため）
''MsgRtn = MsgBox("メールを作成しました。" _
'' , vbOKOnly + vbInformation, Title:="完了")
'Outlookメール
ElseIf MsgRtn = vbNo Then
With New MSForms.DataObject
.SetText strMsg 'DataObjectに格納
.PutInClipboard 'クリップボードに格納
End With
'完了メッセージ
MsgRtn = MsgBox("クリップボードに格納しました。" _
, vbOKOnly + vbInformation, Title:="完了")
End If
'終了処理
Set rng = Nothing
End Sub
