Outlook 2016/2013/2010 のセキュリティ修正プログラム 2017 年 10 月分がリリース

10/10 に Office 2016, 2013 および 2010 のセキュリティ修正プログラムがリリースされました。以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 のセキュリティ修正

2016 の Outlook のセキュリティ更新プログラムの説明: 2017 年 10 月 10日
2 件のセキュリティ修正と 11 件のセキュリティ以外の修正が行われています。

Word 2016 の修正

2017 年 10 月 3日を Word 2016 (KB4011140) の更新します。
2 件の Outlook 2016 に関する修正が行われています。

Office 2013

Outlook 2013 のセキュリティ修正

Outlook 2013 のセキュリティ更新プログラムの説明: 2017 年 10 月 10日
2 件のセキュリティ修正と 6 件のセキュリティ以外の修正が行われています。

Word 2013 の修正

2017 年 10 月 3日は、Word 2013 (KB4011150) の更新します。
1 件の Outlook 2016 に関する修正が行われています。

Office 2010

Outlook 2010 のセキュリティ修正

Outlook 2010 用のセキュリティ更新プログラムの説明: 2017 年 10 月 10日
1 件のセキュリティ修正が行われています。

広告

受信したメールから取得したキーワードにより Excel を検索し、情報を追記して転送するマクロ

コメントにて以下のご要望をいただきました。


コメント失礼します。

windows7 outlook2010です。

やりたいことは、特定のメールから受信し、自動で編集して、再送したいです。今考えているのは受信後自動で各項目ごとにエクセルに転記、転記されたデータをvlookupで別データから参照し値を抽出、その抽出したデータを元のメール文章に追加して送信できればと思っています。

特定のメールアドレスから顧客番号が記載されて送られてきますが、顧客名と住所をいちいち調べなければなりません。現状は顧客名と住所を調べて、元のメール文に追記して再送しています。

それを自動化できればと考えています。

メール文 (例

受信日時 〇〇〇〇

顧客コード 〇〇〇〇〇〇〇〇

内容 〇〇〇〇〇〇〇〇

下記のコードでエクセルに本文を転記することができました。

<コード略>

これだとマクロを実行しないとエクセルに転記されません。

受信毎で自動でエクセルに転記したいです。どこにコードを足せばよいですか?

このあと、エクセルの関数で項目ごとに各セルに振り分けし、(A1:受信日時 B1:顧客コード C1:内容)顧客コードからvlookupで顧客名と住所を抽出まではできましたが、そこから自動でメールを作り、送ることは可能でしょうか?


まず、メールを受信したら自動でマクロを実行したいという場合、Application_NewMailEx を使用します。
Excel に転記するマクロを自動で実行したいとのことですが、転記した後 Excel 側で処理をし、そのうえでメール作成となるとちょっとややこしいことになります。
Outlook で自動処理をしたいのであればすべてを Outlook で実装したほうが効率的でしょう。
Outlook でも本文からデータを取得したり、Excel のシートを検索するという処理を記述することは可能です。
受信したメールから顧客コードを取り出し、Excel を検索して対応する名前と住所を本文に追記して転送するというマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const WORKFLOW_SENDER = "sample@example.com" ' 特定のメールアドレス
     Dim objMail As Object
     Set objMail = Application.Session.GetItemFromID(EntryIDCollection)
     '
     If objMail.MessageClass = "IPM.Note" Then
         If objMail.Sender.Address = WORKFLOW_SENDER Then
             AddNameAndAddressThenSend objMail
         End If
     End If
End Sub
' Excel から顧客情報を取得して送信するプロシージャ
Public Sub AddNameAndAddressThenSend(ByVal objMail As MailItem)
     Const EXCEL_FILE = "C:\sample\sample.xlsx" ' 顧客情報の Excel ファイル
     Const CUSTOMER_SHEET = 1 ' 顧客コードが格納されているシート番号
     Const COL_CODE = 1 ' 顧客コードが格納されている列番号
     Const COL_NAME = 2 ' 顧客名が格納されている列番号
     Const COL_ADDR = 3 ' 住所が格納されている列番号
     Const ROW_START = 2 ' 顧客情報を格納している最初の行
     Dim iPtrCode As Integer
     Dim strCode As String
     Dim objBook 'As Excel.Workbook
     Dim objSheet 'As Excel.Worksheet
     Dim r As Integer
     ' 本文から顧客コードを取得
     iPtrCode = InStr(objMail.Body, "顧客コード")
     If iPtrCode = 0 Then Exit Sub ' 顧客コードが見つからなければ終了
     iPtrCode = iPtrCode + 5
     strCode = Mid(objMail.Body, iPtrCode)
     ' 顧客コードに続く文字列を改行コードまで取得
     strCode = Left(strCode, InStr(strCode, vbCrLf) - 1)
     ' 前後の空白を削除
     strCode = Trim(strCode)
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     Set objSheet = objBook.Sheets(CUSTOMER_SHEET)
     ' 顧客コードをシートから検索
     r = ROW_START
     With objSheet
         While .Cells(r, COL_CODE) <> strCode And .Cells(r, COL_CODE) <> ""
             r = r + 1
         Wend
         '
         If .Cells(r, COL_CODE) = strCode Then ' 顧客コードが見つかったら
             Dim fwdMail As MailItem
             ' 再送メールを作成
             Set fwdMail = CreateItem(olMailItem)
             ' メールの内容を再送メールに転記
             fwdMail.Subject = objMail.Subject
             fwdMail.To = objMail.To
             fwdMail.CC = objMail.CC
             ' 本文に顧客名と住所を追加
             fwdMail.Body = objMail.Body & _
                 "顧客名 " & .Cells(r, COL_NAME) & vbCrLf & _
                 "住所 " & .Cells(r, COL_ADDR) & vbCrLf
             ' メール送信
             fwdMail.Send
         End If
     End With
     objBook.Close
End Sub

マクロの登録方法やメニューへの追加について

送信者が自分以外のメールを受信した際に添付ファイルを自動保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。


いつもありがとうございます。
  「受信したメールの添付ファイルを自動保存するマクロ」を使用させていただいています。

追加機能として、自分が送付したメールの添付を自動保存から除外するマクロを教えていただけませんでしょうか。
VBA初心者で、色々試してみましたが、出来ませんでした。
お力をお借りできますと幸いです。(グループアドレス等に送信する場合、自分にもメールが入るので、その際除外できればと考えています。)


まず、メールの送信者のアドレスは、MailItem オブジェクトの Sender.Address プロパティにより取得できます。
(SenderEmailAddress というプロパティもありますが、こちらは Outlook 2013 以降でのみ使用可能です。)
一方、自分自身のアドレスは Session.CurrentUser.Address により取得できます。
そのため、添付ファイルの保存の前にこの二つのアドレスを比較し、一致していたら保存をキャンセルするという処理を追加することでご要望を実現することができます。

以前のマクロにこの処理を追加したものは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim i As Integer
     Dim c As Integer
     Dim colID As Variant
     '
     If InStr(EntryIDCollection, ",") = 0 Then
         SaveAttachments EntryIDCollection
     Else
         colID = Split(EntryIDCollection, ",")
         For i = LBound(colID) To UBound(colID)
             SaveAttachments colID(i)
         Next
     End If
End Sub
'
' 添付ファイルの保存を行うサブ プロシージャ
Private Sub SaveAttachments(ByVal strEntryID As String)
     Const SAVE_PATH = "C:\attachments\"
     Dim objFSO As Object ' FileSystemObject
     Dim objMsg As Object
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer: c = 1
     '
     Set objMsg = Application.Session.GetItemFromID(strEntryID)
     '
     If LCase(objMsg.Sender.Address) = LCase(Session.CurrentUser.Address) Then
         Exit Sub
     End If
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     '
     ' ここで条件指定
     '
     For Each objAttach In objMsg.Attachments
         With objAttach
           
             strFileName = SAVE_PATH & objAttach.FileName
            
             While objFSO.FileExists(strFileName)
                 strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                     & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                 c = c + 1
             Wend
            
             .SaveAsFile strFileName
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub

マクロの登録方法やメニューへの追加について

受信したメールの本文を 1 行ごとに処理するマクロ

決まった件名のメッセージを受信したら、データを CSV ファイルに保存するマクロのコメントにて以下のご要望をいただきました。


度々申し訳ございません。メールの本文を1行毎に処理するというのは可能でしょうか。

メール本文が何行あるかは定まってなく、
任意の文字列1
任意の文字列2
任意の文字列3

といった内容のメールが来た時、
任意の文字列1がXXで終わってたらXXの前N文字を取得してCSVに書き出し、
無ければ任意の文字列1を全てCSVに書き出すという処理を、
メール本文終わりまで行いたいです。


プログラミングにおいて「行」というのは改行コード (キャラクタ コード 13 および 10 ) で終わる一連の文字列となります。
そのため、本文を Split 関数で改行コードにより分割し、分割された文字列に対して必要な処理を行うことで、1 行ずつの処理ができます。
マクロは以下のようになります。
XX や N は冒頭の Const  で指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const XX = "XX"
     Const N = 5
     Const CSV_FILE = "c:\temp\report.csv"
     Dim objItem As Object
     Dim arrLine As Variant
     Dim strLine As String
     Dim i As Integer
     '
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     If objItem.MessageClass = "IPM.Note" Then
         ' CSV ファイルを追記モードで開く
         Open CSV_FILE For Append As #1
         ' 本文を改行コードで行に分割
         arrLine = Split(objItem.Body, vbCrLf)
         For i = LBound(arrLine) To UBound(arrLine)
             strLine = arrLine(i)
             ' 行が指定のキーワードで終わるか確認
             If strLine Like "*" & XX Then
                 ' 行が指定のキーワードより前に文字列を含むかチェック
                 If Len(strLine) > Len(XX) Then
                     ' 行末の指定のキーワードを削除
                      strLine = Left(strLine, Len(strLine) - Len(XX))
                     ' 残りが N 以上か確認
                     If Len(strLine) >= N Then
                         ' N 文字だけ抜き出す
                          strLine = Mid(strLine, Len(strLine) - N + 1)
                     End If
                 End If
             End If
             If Len(strLine) > 0 Then
                 ' 取得した行を CSV ファイルに書き出す
                 Print #1, strLine
             End If
         Next
         Close #1
     End If
End Sub

マクロの登録方法やメニューへの追加について

Outlook 2016/2013/2010/ 2007 のセキュリティ修正プログラム 2017 年 9 月分がリリース

9/12 に Office 2016, 2013, 2010 および 2017 のセキュリティ修正プログラムがリリースされました。以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 のセキュリティ修正

Outlook 2016 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正と 8 件のセキュリティ以外の修正が行われています。

Office 2016 共通コンポーネントの修正

2017 年 9 月 5日で、更新プログラム Office 2016 (KB3191923)
1 件の Outlook 2016 に関する修正が行われています。

2017 年 8 月 22日、更新プログラム Office 2016 (KB4011093)
1 件の Outlook 2016 に関する修正が行われています。

Word 2016 の修正

2017 年 9 月 5日を Word 2016 (KB4011039) の更新します。
1 件の Outlook 2016 に関する修正が行われています。

Office 2013

Outlook 2013 のセキュリティ修正

Outlook 2013 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正と 1 件のセキュリティ以外の修正が行われています。

Office 2010

Outlook 2010 のセキュリティ修正

Outlook 2010 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正が行われています。

Office 2007

Outlook 2007 のセキュリティ修正

Outlook 2007 セキュリティ更新プログラムについて2017 年 9 月 12 日
1 件のセキュリティ修正が行われています。

メッセージ受信時に游ゴシックを別のフォントに置き換えるマクロ

コメントにて以下のご要望をいただきました。


コメント失礼します。

Windows10でoutlook2016を使用しております。

游ゴシックを使用したHTMLメールが大変読みにくく(Outlook2016のデフォルトでしょうか…)

画面の調整では限度あり、かすれたような読みにくさは、

PCの環境によっては、回避できない場合もあります。

Outlookの設定では、HTMLメールをテキスト形式として受信する設定があり、

かつ、テキストメールの設定を所望のフォントにしておけば、

見やすさは確保できるのですが、

余計な改行が入る、表などの書式もなくなってしまうことから

この機能に頼ることはできません。

そもそも、

HTMLメールに游ゴシックを使わない、(好きな方ゴメンナサイ。)

HTMLメールで改行するときは、SHIFT+ENTERで!

と送信時に、ひと手間かけていただければ解決するのですが、

それはそれで、難しい話です。

ご提案なのですが、

HTMLメール受信時に、特定のフォント(游ゴシック)を、

特定のフォント(MeiryoUIやMSゴシック)に置換し

表示するマクロがあると、救われる方々が大勢いらっしゃると思います。

是非、ご一考いただければ幸いです。


メッセージ受信時に発生する NewMailEx イベントで HTML 本文を保持する HTMLBody プロパティ内のフォントの文字列を Replace 関数で置き換えれば実現は可能です。

ただし、HTMLBody の文字列を丸ごと一括置換してしまうと、フォント指定ではなく本文の文面として「游ゴシック」という言葉を使ったときにも置き換えられてしまいます。
そのため、HTML のタグの中だけを置き換えるという処理が必要となります。

実装は以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     On Error GoTo END_OF_EVENT
     Const YU_GOTHIC1 = "游ゴシック"
     Const YU_GOTHIC2 = "Yu Gothic"
     Const DEFAULT_FONT = "Meiryo UI"
     Dim objItem As MailItem
     Dim strOldHTML As String
     Dim strNewHTML As String
     Dim iHeader As Integer
     Dim iStart As Integer
     Dim iEnd As Integer
     Dim strHeader As String
     Dim strTag As String
     ' 受信アイテムを取得
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     ' HTML 形式の場合のみ処理
     If objItem.BodyFormat = olFormatHTML Then
         strOldHTML = objItem.HTMLBody
         ' ヘッダー部分の取得
         iHeader = InStr(1, strOldHTML, "</head>", vbTextCompare)
         If iHeader > 0 Then
             ' ヘッダー内のフォント記述は一括置換
             strHeader = Left(strOldHTML, iHeader - 1)
             strHeader = Replace(strHeader, YU_GOTHIC1, DEFAULT_FONT)
             strHeader = Replace(strHeader, YU_GOTHIC2, DEFAULT_FONT)
             strOldHTML = Mid(strOldHTML, iHeader)
             ' 置き換えたヘッダーをコピー
             strNewHTML = strHeader
         Else
             strNewHTML = ""
         End If
         '
         iEnd = 0
         ' タグの始まりを検索
         iStart = InStr(1, strOldHTML, "<")
         While iStart > 0 ' タグが存在する間繰り返す
             ' タグの終わりまではそのままコピー
             strNewHTML = strNewHTML & Mid(strOldHTML, iEnd + 1, iStart - iEnd - 1)
             ' タグの終わりを検索
             iEnd = InStr(iStart, strOldHTML, ">")
             ' タグ文字列を取得
             strTag = Mid(strOldHTML, iStart, iEnd - iStart + 1)
             ' タグ文字列内のフォントを置換
             strTag = Replace(strTag, YU_GOTHIC1, DEFAULT_FONT)
             strTag = Replace(strTag, YU_GOTHIC2, DEFAULT_FONT)
             ' 置き換えたタグをコピー
             strNewHTML = strNewHTML & strTag
             ' タグの始まりを検索
             iStart = InStr(iEnd + 1, strOldHTML, "<")
         Wend
         ' 最後のタグの後に文字列があれば追加し、HTML 本文を置き換え
         objItem.HTMLBody = strNewHTML & Mid(strOldHTML, iEnd + 1)
         ' アイテムを保存
         objItem.Save
     End If
END_OF_EVENT:
End Sub

マクロの登録方法やメニューへの追加について

複数フォルダーに格納されている特定の件名のメールの情報を Excel ファイルにエクスポートするマクロ

コメントにて以下のご要望をいただきました。


いつもブログ拝見させていただいています。

私は、ある会社で新人研修のスタッフを行っております。
  新入社員は一日の終わりに日報をメールで作成して送るのが義務に
  なっています。

そこで新入社員が送信したメールデータをExcelファイルにエクスポートする
  マクロはございますでしょうか。
  (新入社員が日報を送ったかチェックするためです。)

■メール抽出条件
・件名が”【日報】”となっているもの
  ・日付を指定して抽出する
  ・受信フォルダを複数指定して抽出

■Excelに抽出する際に必要情報な情報
・件名
・差出人(CC情報も含む)
・宛先

利用環境はOutlook2016です。

ご教授頂きたく、宜しくお願い致します。


「フォルダを複数指定して抽出」という処理をマクロで実装する場合、配列などにフォルダーのパスを指定しておき、フォルダーごとに抽出処理を行う必要があります。
また、パスからフォルダーを取得するということ自体もちょっと面倒なのですが、この処理は GetFolderByPath という関数で実装しています。
Excel に抽出する際に必要な情報にフォルダーがなかったのですが、フォルダーも必要なのではないかと思ったので追加しています。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub ExportDailyReport()
     Const SUBJECT_PATTERN = "【日報】*"
     Dim dtExport As String
     Dim arrExportFolder As Variant
     Dim i As Integer
     Dim iRow As Integer
     Dim appExcel As Object
     Dim objBook As Object
     Dim objSheet As Object
     Dim fldExport As Folder
     Dim colItems As Items
     Dim itmReport As Variant ' MailItem
     ' フォルダーを "" でくくって指定します
     arrExportFolder = Array("受信トレイ", "受信トレイ\Sub1", "Root1")
     dtExport = Now
     'dtExport = DateAdd("d", -1, Now) ' 既定の日付を昨日にする場合はこちら
     dtExport = InputBox("エクスポートする日付を入力してください", _
         "日付の入力", FormatDateTime(dtExport, vbShortDate))
     '
     ' Excel ワークシートの準備
     Set appExcel = CreateObject("Excel.Application")
     Set objBook = appExcel.Workbooks.Add()
     Set objSheet = objBook.Sheets(1)
     objSheet.cells(1, 1) = "件名"
     objSheet.cells(1, 2) = "差出人"
     objSheet.cells(1, 3) = "宛先"
     objSheet.cells(1, 4) = "Cc"
     objSheet.cells(1, 5) = "フォルダー"
     iRow = 2
     ' フォルダーごとにエクスポート処理
     For i = LBound(arrExportFolder) To UBound(arrExportFolder)
         ' フォルダーを取得
         Set fldExport = GetFolderByPath(arrExportFolder(i))
         Set colItems = fldExport.Items
         ' 受信日時でアイテムを検索
         Set itmReport = colItems.Find("[受信日時] >= '" & dtExport & " 00:00' and [受信日時] < '" _
             & DateAdd("d", 1, dtExport) & " 00:00'")
         While Not itmReport Is Nothing
             ' 件名がパターンと合致したらアイテムの情報を書き出す
             If itmReport.Subject Like SUBJECT_PATTERN Then
                 With itmReport
                     objSheet.cells(iRow, 1) = .Subject
                     objSheet.cells(iRow, 2) = .SenderName
                     objSheet.cells(iRow, 3) = .To
                     objSheet.cells(iRow, 4) = .CC
                     objSheet.cells(iRow, 5) = arrExportFolder(i)
                     iRow = iRow + 1
                 End With
             End If
             Set itmReport = colItems.FindNext
         Wend
     Next
     ' Excel ファイルの表示
     appExcel.Visible = True
     objBook.windows(1).Visible = True
End Sub
'
' パスからフォルダーを取得する関数
'
Private Function GetFolderByPath(ByVal strPath As String) As Folder
     Dim fldRoot As Folder
     ' 既定のメール ストアのルートを取得
     Set fldRoot = Session.DefaultStore.GetRootFolder
     ' パスに \ を含まなければルート直下のフォルダーを取得
     If InStr(strPath, "\") = 0 Then
         Set GetFolderByPath = fldRoot.Folders(strPath)
     Else
         Dim arrPath As Variant
         Dim fldSub As Folder
         Dim i As Integer
         ' パスを \ で分割
         arrPath = Split(strPath, "\")
         ' 分割したパスをたどってフォルダーを取得
         For i = LBound(arrPath) To UBound(arrPath)
             Set fldSub = fldRoot.Folders(arrPath(i))
             Set fldRoot = fldSub
         Next
         Set GetFolderByPath = fldSub
     End If
End Function

マクロの登録方法やメニューへの追加について