メールの本文で選択されたキーワードを指定したコードページでエンコードして Web で検索するマクロ

メールの本文で選択されたキーワードを Web で検索するマクロのコメントにて以下のご要望をいただきました。


上記マクロをカスタムしてみたいのですが、各検索の引数の値を文字コードを指定してURLエンコードしたいのですが可能でしょうか?


以下のようなマクロで実現できます。

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

' コードページ変換の API を定義
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32.dll" ( _
     ByVal CodePage As Long, _
     ByVal dwFlags As Long, _
     ByVal lpWideCharStr As LongPtr, _
     ByVal cchWideChar As Long, _
     ByVal lpMultiByteStr As LongPtr, _
     ByVal cchMultiByte As Long, _
     ByVal lpDefaultChar As LongPtr, _
     ByVal lpUsedDefaultChar As Long) As Long
' コードページの定数
Private Const CP_UTF8 As Long = 65001
Private Const CP_SJIS As Long = 932
'
' UTF-8 で Google 検索を行うマクロ
Public Sub GoogleSearchUTF8()
     WebSearchWithCP "https://www.google.co.jp/search?q=", CP_UTF8
End Sub
' Shift-JIS で Google 検索を行うマクロ
Public Sub GoogleSearchSJIS()
     WebSearchWithCP "https://www.google.co.jp/search?q=", CP_SJIS
End Sub
' コードページ指定で検索を実行する共通マクロ
Private Sub WebSearchWithCP(strCmd As String, lCodePage As Long)
     Dim objDoc As Object ' Word.Document
     Dim strKey As String
     Dim objShell As Object
     Dim lBufSize As Long
     Dim abBuf() As Byte
     Dim i As Integer
     Dim strHex As String
     ' 選択された文字列を取得
     Set objDoc = ActiveInspector.WordEditor
     strKey = Trim(objDoc.Application.Selection.Text)
     ' 文字列を指定されたコードページに変換した際のバイト数を取得
     lBufSize = WideCharToMultiByte(lCodePage, 0, StrPtr(strKey), Len(strKey), 0, 0, 0, 0)
     ' 必要なサイズにバッファを設定
     ReDim abBuf(lBufSize)
     ' 文字列を指定されたコードページに変換
     WideCharToMultiByte lCodePage, 0, StrPtr(strKey), Len(strKey), VarPtr(abBuf(0)), lBufSize, 0, 0
     ' 変換されたバイト配列を %xx の形式に変換
     strKey = ""
     For i = 0 To lBufSize - 1
         strHex = Right("0" & Hex(abBuf(i)), 2)
         strKey = strKey & "%" & strHex
     Next
     ' 取得した文字列を引数に追加して実行
     Set objShell = CreateObject("WScript.Shell")
     objShell.Run strCmd & strKey
End Sub

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

広告

フォルダーに含まれるメールに添付されている PDF をすべて印刷するマクロ

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


こんばんわ。
特定の受信トレイに仕分けされたメールの添付ファイル(pdf)を、指定のプリンタで自動で印刷する方法を教えて頂きたいです(今は日に150-200件のメールの添付ファイルを、右クリック⇒印刷して対応しています)。
よろしくお願い致します。

OS:windows7 office2013


以前、仕訳ルールでメールの本文と PDF のみ印刷するマクロとして公開したマクロを応用すると、特定のフォルダーにあるすべてのメールの PDF ファイルを印刷することができます。
マクロは以下のようになります。
なお、このマクロで印刷のために保存された PDF ファイルは自動では削除されないので、必要に応じて手動で削除してください。

' ここをトリプルクリックでマクロ全体を選択できます。
' 以下はソースの先頭に記載する必要があります。
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                 (ByVal hwnd As Long, ByVal lpszOp As String, _
                  ByVal lpszFile As String, ByVal lpszParams As String, _
                  ByVal LpszDir As String, ByVal FsShowCmd As Long) _
                  As Long
'
Public Sub PrintAllPDFInCurrentFolder()
     Dim fldCurrent As Folder
     Dim objItem As Object '
     ' 現在選択されているフォルダーを取得
     Set fldCurrent = ActiveExplorer.CurrentFolder
     For Each objItem In fldCurrent.Items
         ' アイテムがメールだった場合だけ印刷
         If TypeName(objItem) = "MailItem" Then
             PrintPDFAttach objItem
         End If
     Next
End Sub
'
Private Sub PrintPDFAttach(ByVal objItem As MailItem)
     On Error Resume Next
     Const ATTACH_PATH = "c:\temp\" ' 添付ファイルを保存するフォルダー
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer
     ' 添付ファイルの印刷
     Dim objFSO 'As FileSystemObject
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     For Each objAttach In objItem.Attachments
         If LCase(objAttach.FileName) Like "*.pdf" Then
             ' ファイルが PDF の場合のみ保存して印刷
             c = 1
             With objAttach
                 strFileName = .FileName
                 While objFSO.FileExists(ATTACH_PATH & strFileName)
                     strFileName = Left(.FileName, InStrRev(.FileName, ".") - 1) _
                         & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                     c = c + 1
                 Wend
                 .SaveAsFile ATTACH_PATH & strFileName
             End With
             '    保存したファイルを印刷する
             ShellExecute 0, "print", ATTACH_PATH & strFileName, 0, ATTACH_PATH, 0
         End If
     Next
End Sub

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

決まった時間範囲外のメール送信を自動的に遅延させるマクロ

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


いつも大変お世話になっております。
  1つ実現可否について教えていただきたことがあります。

送信時の処理として、指定した時間内は送らないという処理は可能でしょうか?
  具体的には、17:00~翌朝8:00の間は、メールの送信トレイに残しっぱなしで、8:01以降は送信対象となる。という状況にしたいです。
ただ、配信タイミングの手動設定はせずに、指定した時間になったら上記処理になるようなマクロは可能でしょうか?


現在の日時は Now 関数で取得ができますので、この関数で取得した時間が 8:01 より前か、17:00 以降の場合には MailItem オブジェクトの DeferredDeliveryTime プロパティで配信時間を 8:01 に設定することでご要望は実現可能です。
8:00 から 17:00 の間だけ送信ということは営業時間内のみの送信を想定していると考えられたので、土日には送信しないというロジックも追加しました。
土日の考慮が不要なら dtSend = GetNextWeekday() を  dtSend = DateAdd("d", 1, Now()) に置き換えてください。

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

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     If Format(Now(), "hh:mm") < "08:01" Then
         ' 現在時刻が 8:01 より前なら 8:01 に送信
         Item.DeferredDeliveryTime = _
             CDate(Format(Now(), "yyyy/mm/dd 08:01"))
     ElseIf Hour(Now()) >= 17 Then
         Dim dtSend As Date
         ' 現在時刻が 17:00 以降なら
         ' 次の平日を取得
         dtSend = GetNextWeekday()
         ' 土日の送信を考慮しないなら単に以下の通り設定
         ' dtSend = DateAdd("d", 1, Now())
         ' 指定日の 8:01 に送信
         Item.DeferredDeliveryTime = _
             CDate(Format(dtSend, "yyyy/mm/dd 08:01"))
     End If
End Sub
'
Private Function GetNextWeekday()
     Dim dtSend As Date
     If Weekday(Now) = vbFriday Then
         ' 今日が金曜日なら 3 日後に送信
         dtSend = DateAdd("d", 3, Now())
     ElseIf Weekday(Now) = vbSaturday Then
         ' 今日が土曜日なら 2 日後に送信
         dtSend = DateAdd("d", 2, Now())
     Else
         ' 今日が日-木曜日なら翌日に送信
         dtSend = DateAdd("d", 1, Now())
     End If
     GetNextWeekday = dtSend
End Function

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

Outlook 起動時に PST のサイズをチェックして一定サイズを超えたらメールで通知するマクロ

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


はじめまして。
outlookの問題解決で参考にさせて頂いております。
outlook起動時に任意のファイル名のPSTファイル(アーカイブも含む)の容量が閾値を超えたらメールで管理部門に通知するような事はマクロで可能でしょうか。

Windows7 office2013

よろしくお願いします。


Outlook の起動時に何らかの処理をさせるには、Application オブジェクトの Startup イベントを使用します。

また、ファイルのサイズを確認するには、VBA の FileLen 関数を使用します。

マクロは以下のようになります。

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

Private Sub Application_Startup()
     ' PST のファイル名を指定
     Const PST_FILE = "c:\pst\archive.pst"
     ' 閾値を MB 単位で指定
     Const WARN_SIZE_MB = 100
     ' メールの宛先アドレスを指定
     Const REPORT_TO = "administrator@example.com"
     ' メールの件名を指定
     Const REPORT_SUBJECT = "PST ファイル サイズ レポート"
     ' メールの本文を指定
     Const REPORT_BODY = "PST ファイルのサイズが閾値を超えました。"
     ' ファイル サイズが閾値を超えたらメール送信
     If FileLen(PST_FILE) / 1024 / 1024 > WARN_SIZE_MB Then
         Dim itmReport As MailItem
         Set itmReport = CreateItem(olMailItem)
         ' 宛先を指定し名前解決
         itmReport.To = REPORT_TO
         itmReport.Recipients.ResolveAll
         ' 件名と本文を指定
         itmReport.Subject = REPORT_SUBJECT
         itmReport.Body = REPORT_BODY
         ' 通知メールを送信
         itmReport.Send
     End If
End Sub

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

メール送信の際に本文のリンク文字列の前後に <> がついていない場合に警告を表示するマクロ

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


困ったときにはいつも参照させて頂いております。

早速ですが,メール本文にリンクアドレスを挿入する場合,山括弧”<>”で囲むことでリンク途切れを防ぐことが出来ます。このことを皆さんに周知するのですが,未だ山括弧を付けずに送信される方が後を絶ちません。

メール送信時にリンクアドレスが山括弧で囲まれていないとアラートを出すような仕組みは作れないでしょうか?

よろしくお願い致します。


メール送信時に何らかの処理を行う場合は ApplicationItemSend イベントを使用します。
HTML 形式やリッチテキスト形式の場合は <> で囲まなくてもリンク切れせずに正しくリンクを挿入することができますので、本文がテキスト形式の場合だけ本文をチェックすればよいでしょう。
本文形式は MailItem オブジェクトの BodyFormat プロパティで確認ができます。
リンクが <> で囲まれているかどうかは本文が格納されている Body プロパティについてリンク文字列の先頭である http:// や https:// を InStr 関数により検索し、見つかった位置の一つ前に < があるかという点と、その後の文字列で > があるかという点を確認します。
<> で囲っていないリンクが見つかったら、警告を表示しますが、その際に [はい] を選択すると送信をキャンセルするようにします。
これは、何かダイアログが出ても読まずに [はい] をクリックするような習慣がついている場合に、警告が無意味にならないようにするためです。
まとめると以下のようなマクロになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     ' メール以外はチェックしない
     If TypeName(Item) <> "MailItem" Then
         Exit Sub
     End If
     ' テキスト形式のメールのみチェック
     If Item.BodyFormat <> olFormatPlain Then
         Exit Sub
     End If
     ' http, https, file で始まる URL をチェック
     If FindBareURL(Item.Body, "http") Or _
        FindBareURL(Item.Body, "https") Or _
        FindBareURL(Item.Body, "file") Then
         If MsgBox("<> で囲っていない URL があります。メールの編集に戻りますか?", vbYesNo) = vbYes Then
             Cancel = True
         End If
     End If
End Sub
' <> で囲っていない URL の検索
Private Function FindBareURL(strBody As String, strSchema As String)
     Dim iUrl As Integer
     ' 本文のスキャンが完了しない場合は <> で囲っていない URL がある
     FindBareURL = True
     ' URL の文字列を検索
     iUrl = InStr(strBody, strSchema & "://")
     While iUrl > 0
         ' 本文の最初に URL がある
         If iUrl = 1 Then
             Exit Function
         End If
         ' URL の直前に < がない
         If Mid(strBody, iUrl - 1, 1) <> "<" Then
             Exit Function
         End If
         ' URL の終わりの > を検索
         While Mid(strBody, iUrl, 1) <> ">"
             ' > より先に改行がある
             If Mid(strBody, iUrl, 1) = vbLf Then
                 Exit Function
             End If
             iUrl = iUrl + 1
             ' > が見つからずに本文の終わりに到達
             If iUrl > Len(strBody) Then
                 Exit Function
             End If
         Wend
         ' 次の URL を検索
         iUrl = InStr(iUrl + 1, strBody, strSchema & "://")
     Wend
     ' 最後まで問題がなかったら OK
     FindBareURL = False
End Function

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

特定の文字列を件名に含むメールを受信した際にその送信者アドレスと受信日時をExcelファイルまたはCSVファイルに保存するマクロ

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


お世話になってます。

いつもありがとうございます。
  参考させていただいています。

勤怠システムとしてVBAを利用したいと思っているんですが
出発メールの管理を考えております。

教えて頂けると幸いでございます。

やりたいこと
①件名に「出発」という文字が含まれるメールが届いたら、届いた時にエクセルへ反映
②エクセルにはメール送信者アドレスと受信時間だけ反映(A2:アドレス、B2:受信時間、を縦に反映)

これを常時自動で行ってくれるマクロはありませんでしょうか?
※出発という文字が含まれるメールが大量に届き追いきれない状況です。

お知恵をお借りしたく、何卒よろしくお願いいたします。

使用環境
win8.1
  office2010


まず、メールが受信された際に自動的にマクロを実行するには Application オブジェクトの NewMailEx イベントを使用します。
次に、メールの件名に特定の文字列が含まれるかどうかを確認するには InStr 関数で MailItem オブジェクトの Subject プロパティを検索します。
そして、Excel ファイルを開くには GetObject を使用し、取得した Workbook オブジェクトの WorksheetCells で値がない行を検索します。
最後に、MailItem オブジェクトの Sender.Address プロパティで取得できる送信者のアドレスと、ReceivedTime プロパティで取得できる受信日時を Cells に書き込み、Save メソッドで保存します。
まとめると以下のようなマクロになります。
なお、Excel ファイルへの書き込みには多少時間がかかり、大量のメールを一度に受信するとマクロの処理が追い付かずに保存されない場合があるため、CSV ファイルに書き込む記述も追加しました。

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

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Const SAVE_KEYWORD = "出発"
     Dim objItem As Object
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     If objItem.MessageClass = "IPM.Note" And InStr(objItem.Subject, SAVE_KEYWORD) > 0 Then
         SaveDateAndSenderToExcelFile objItem
         ' CSV ファイルに保存する場合は以下の記述を使用
         'SaveDateAndSenderToCSVFile objItem
     End If
End Sub
'
Public Sub SaveDateAndSenderToExcelFile(ByVal objItem As MailItem)
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\depart.xlsx"
     '
     Dim excBook As Object
     Dim excSheet As Object
     Dim iRow As Integer
     ' Excel ファイルを取得
     Set excBook = GetObject(EXCEL_FILE)
     ' 1 つ目のワークシートを取得
     Set excSheet = excBook.Worksheets(1)
     ' あいている行を検索
     iRow = 2
     While excSheet.Cells(iRow, 1) <> ""
         iRow = iRow + 1
     Wend
     ' あいている行に送信者アドレスと受信日時を書き込み
     excSheet.Cells(iRow, 1) = objItem.Sender.Address
     excSheet.Cells(iRow, 2) = objItem.ReceivedTime
     excBook.Save
End Sub
'
Public Sub SaveDateAndSenderToCSVFile(ByVal objItem As MailItem)
     ' CSV ファイルのファイル名を指定
     Const CSV_FILE = "c:\temp\depart.csv"
     ' CSV ファイルを開く
     Open CSV_FILE For Append As #1
     ' CSV ファイルに送信者アドレスと受信日時を追記
     Print #1, objItem.Sender.Address; ","; objItem.ReceivedTime
     Close #1
End Sub

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

メールの本文の指定された行の文字列をもとに Excel で VLookup を実行し、見つかった値をヘッダーに追記して印刷するマクロ

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


初めまして。Outlook VBA初心者です。

以下のようなことは可能でしょうか。

①メール本文内のn行目のキーワードを取得
②キーワードを検索値として指定のエクセルファイルからVLOOKUPで情報を取得
③VLOOKUPで取得した情報をメールのヘッダーに設定し、印刷

エクセルのVBAは少し経験があるのですが、outlookはまだまだ勉強中でなかなか作業が進まず困っております。こういった操作が可能かどうかだけでもご教示いただければ幸いです。


可能です。
順を追って説明しましょう。

まず、①についてですが、メールの本文を含む一般的なテキストにおける「行」とは CRLF (改行コード) で終わる一連の文字列を指します。
そのため、本文の文字列を CRLF で分割し、分割された文字列の n 番目の文字列が n 行目、ということになります。
VBA では Split という関数を使って文字列を分割できます。

次に、②についてですが、Excel のファイルから VLookup で情報を取得するには、Excel の Application オブジェクトの VLookup を使用します。
(厳密にいうと Application の WorksheetFunction プロパティの VLookup メソッドなのですが、WorksheetFunction は省略できるようです。)
ここで、VLookup を使う際には VLookup( Value, “A1:B2”, 2 ) というようにしたくなるのですが、VLookup の 2 番目の引数は範囲指定のオブジェクトを指定する必要があるため、Worksheet オブジェクトの Range プロパティで取得します。

最後に、③についてですが、メールのヘッダーに設定して印刷をするには、メールのユーザー定義プロパティとして取得した情報を追加する必要があります。
ユーザー定義プロパティの追加は MailItemUserProperties プロパティの Add メソッドを使用し、取得した UserProperty オブジェクトの Value プロパティに値を設定します。
なお、同じメールに 2 回実行すると、Add メソッドが失敗するため、Add の前に Find メソッドで既存のプロパティがあるか確認し、存在する場合はそれを再利用するようにしています。

上記の処理をマクロで実装すると以下のようになります。

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

Public Sub PrintWithValueByVLookup()
     ' 読み込む Excel ファイルを指定
     Const EXCEL_FILE = "c:\temp\table.xlsx"
     ' VLookup で検索するシートの番号を指定
     Const VLOOKUP_SHEET = 1
     ' VLookup で検索する範囲を指定
     Const VLOOKUP_RANGE = "A2:B10"
     ' VLookup で値を返す列番号を指定
     Const VLOOKUP_VALUE = 2
     ' メールでキーワードを取得する行数を指定
     Const LOOKUP_LINE = 5
     ' 印刷する際に Excel で取得した値の表題を指定
     Const VALUE_NAME = "ExcelValue"
     '
     Dim objItem As MailItem
     Dim strKey As String
     ' アクティブなウィンドウのアイテムを取得
     If TypeName(ActiveWindow) = "Inspector" Then
         Set objItem = ActiveInspector.CurrentItem
     Else
         Set objItem = ActiveExplorer.Selection(1)
     End If
     ' 指定行からキーワードを取得
     strKey = GetLineByNumber(objItem.Body, LOOKUP_LINE)
     ' 値が取得できたら検索
     If strKey <> "" Then
         Dim excBook As Object
         Dim rgLookup As Object
         Dim varValue As Variant
         ' Excel ファイルを取得
         Set excBook = GetObject(EXCEL_FILE)
         ' VLookup の検索範囲を取得
         Set rgLookup = excBook.Worksheets(VLOOKUP_SHEET).Range(VLOOKUP_RANGE)
         ' VLookup を実行
         varValue = excBook.Application.VLookup(strKey, rgLookup, VLOOKUP_VALUE)
         ' 値が取得できたら処理
         If varValue <> "" And Not varValue Like "エラー*" Then
             Dim usrProp As UserProperty
             ' 取得した値をユーザー定義フィールドに設定
             Set usrProp = objItem.UserProperties.Find(VALUE_NAME)
             If usrProp Is Nothing Then
                 Set usrProp = objItem.UserProperties.Add(VALUE_NAME, olText)
             End If
             usrProp.Value = varValue
             objItem.Save
             ' メールを印刷
             objItem.PrintOut
         Else
             MsgBox "VLookup の検索でエラーが発生しました。"
         End If
     Else
         MsgBox "メッセージにキーワードを見つけられませんでした。"
     End If
End Sub
' 指定された行番号の行を取得
Private Function GetLineByNumber(strBody As String, iLine As Integer)
     Dim arrLines As Variant
     ' 改行コード (CRLF) で本文を分割
     arrLines = Split(strBody, vbCrLf)
     If UBound(arrLines) >= iLine - 1 Then
         ' 指定された行番号の行を返す
         GetLineByNumber = arrLines(iLine - 1)
     Else
         GetLineByNumber = ""
     End If
End Function

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