メールの本文で選択されたキーワードを指定したコードページでエンコードして 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

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

Outlook 2016/Office 2013 の累積的な修正プログラム 2018 年 9 月分がリリース

9/4 に Outlook 2016 および Office 2013 の累積的な修正プログラムがリリースされました。

以下は各製品のそれぞれの KB へのリンクです。

Office 2016

Outlook 2016 の修正

2018 年 9 月 4日更新プログラム Outlook 2016 (KB4092462)
4 件の不具合修正が行われています。

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

2018 年 9 月 4日更新プログラム Office 2016 (KB4032237)
1 件の Outlook に関する不具合の修正が行われています。

Office 2013

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

2018 年 9 月 4日更新プログラム Office 2013 (KB4092469)
1 件の Outlook に関する不具合の修正が行われています。

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

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


いつも大変お世話になっております。
  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

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

他人の予定表を直接開くスクリプト

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


いつも参照させていただいております。

Outlookの起動オプションを使用して、他人の予定表を直接開く方法を教えてください。

Outlook.exe /select outlook:calendar では自分の予定を開くことはできるのですが、他人の予定表を開く方法がわかりません。

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


残念ながら、Outlook の起動オプションには他人の予定表を直接開くというものはありません。
おそらくはデスクトップなどにバッチファイルを置いて、それをダブルクリックして他人の予定表を開くというようなものを想定されていると思うのですが、スクリプトにより実現することができます。
下記のようなスクリプトを、例えば OpenOtherFolder.vbs というような名前で保存し、デスクトップにはそのスクリプトへのショートカットを作成します。
その際に、スクリプトのファイル名の後にスペースを空けて開きたいユーザーのメールアドレスを指定します。
例えば、c:\users\admin\desktop\OpenOtherFolder.vbs にスクリプトがあり、test@example.com というアドレスのユーザーの予定表を開きたい場合、ショートカット のリンク先として c:\users\admin\desktop\OpenOtherFolder.vbs test@example.com と指定します。
なお、このスクリプトで開く予定表には参照者以上の権限が必要になります。

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

Const olFolderCalendar = 9
If WScript.Arguments.Count > 0 Then
     Dim strAddress 'As String
     Dim olkApp 'As Outlook.Application
     Dim nsSess 'As Namespace
     Dim recOther 'As Recipient
     Dim fldOther 'As Folder
     ' スクリプトの引数からアドレスを取得
     strAddress = WScript.Arguments.Item(0)
     ' Outlook.Application オブジェクトを取得
     Set olkApp = CreateObject("Outlook.Application")
     Set nsSess = olkApp.Session
     ' アドレスから Recipient オブジェクトを作成
     Set recOther = nsSess.CreateRecipient(strAddress)
     recOther.Resolve
     ' 他のユーザーの予定表を取得し、開く
     Set fldOther = nsSess.GetSharedDefaultFolder(recOther, olFolderCalendar)
     fldOther.Display
End If