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

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

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

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


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

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

連絡先フォルダーのユーザーの予定表を一括で追加するスクリプト

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


【使用環境】
OSバージョン:Windows7 SP1 & Windows10
  Outlookバージョン:Outlook2013
サーバ:Exchange Online

はじめまして。
いつも参考になる多数の記事ありがとうございます。

現在定期的に当サイト記事「連絡先をエクスポート・インポートするスクリプト」を使用し、社内アドレス帳を一括インポートしています。
  又、そのアドレス帳から予定表グループ機能を使用し、予定表の共有を行っていますが、
  社内アドレス帳の更新した際に、予定表グループ接続が無効になってしまいます。(レ点をつけれない)
  原因は、社内アドレスの中身を一度一括削除した上で、一括インポートしているからです。
  解決策として、「新しい予定表グループで作成」で既定のアドレス帳に予定表グループを作成するスクリプトを作成頂けませんか。


スクリプトで他のユーザーの予定表を追加するには、その予定表に参照者以上の権限が必要となります。
連絡先にあるユーザーの予定表に参照者以上の権限がある前提でスクリプトを作成しました。

なお、連絡先に連絡先グループが存在した場合、そのグループの名前で予定表グループを作成し、メンバーの予定表をそのグループに追加する処理も実装しています。

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

' 予定表グループの名前設定
Const GROUP_NAME = "連絡先"
' Outlook の設定値
Const olFolderContacts = 10
Const olModuleCalendar = 1
Const olFolderCalendar = 9
'
Dim olkApp 'As Application
Dim nsSession 'As NameSpace
Dim navGroup 'As NavigationGroup
Dim fldContacts 'As Folder
Dim objItem 'As Object
' Outlook の呼び出し
Set olkApp = CreateObject("Outlook.Application")
Set nsSession = olkApp.Session
' 既定の連絡先フォルダーを取得
Set fldContacts = nsSession.GetDefaultFolder(olFolderContacts)
' 予定表グループを作成
Set navGroup = GetNavigationGroup(GROUP_NAME)
' 連絡先フォルダーのすべてのアイテムについて処理
For Each objItem In fldContacts.Items
     If TypeName(objItem) = "ContactItem" Then
         ' 連絡先アイテムならアイテムのメールアドレスを指定して追加
         AddRecipientToNavigation objItem.Email1Address, navGroup
     ElseIf TypeName(objItem) = "DistListItem" Then
         ' 連絡先グループ アイテムならメンバーを展開して追加
         AddDistListToNavigation objItem
     End If
Next
' 連絡先グループのメンバーを展開して追加するルーチン
Private Sub AddDistListToNavigation(dlItem)
     On Error Resume Next
     Dim navGroup 'As NavigationGroup
     Dim i 'As Integer
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     ' 連絡先グループの名前で予定表グループを作成
     Set navGroup = GetNavigationGroup(dlItem.DLName)
     ' メンバーを展開して予定表グループに追加
     For i = 1 To dlItem.MemberCount
         Set recOther = dlItem.GetMember(i)
         AddRecipientToNavigation recOther.Address, navGroup
     Next
End Sub
' メールアドレスにより予定表グループに追加するルーチン
Private Sub AddRecipientToNavigation(strAddress, navGroup)
     On Error Resume Next
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     ' メールアドレスから受信者オブジェクトを生成
     Set recOther = nsSession.CreateRecipient(strAddress)
     ' 名前解決を実行
     recOther.Resolve
     If recOther.Resolved Then
         ' 自分自身は予定表グループに追加しない
         ' Exchange 組織外のアドレスも追加しない
         If recOther.Address = nsSession.CurrentUser.Address _
             Or recOther.AddressEntry.Type <> "EX" Then
             Exit Sub
         End If
         ' 他のユーザーの予定表を取得
         Set fldCalendar = nsSession.GetSharedDefaultFolder(recOther, olFolderCalendar)
         If Not fldCalendar Is Nothing Then
             ' 予定表が取得できたら予定表グループに追加
             navGroup.NavigationFolders.Add fldCalendar
         End If
     End If
End Sub
' 予定表グループを作成・取得するルーチン
Private Function GetNavigationGroup(strGroupName)
     On Error Resume Next
     Dim actExp 'As Explorer
     Dim navModule 'As CalendarModule
     Dim navGroups 'As NavigationGroups
     Dim navGroupT 'As NavigationGroup
     Dim i 'As Integer
     Dim j 'As Integer
     ' 予定表グループを追加するための Explorer オブジェクトを取得
     If olkApp.ActiveExplorer Is Nothing Then
         Dim fldCalendar 'As Folder
         Set fldCalendar = nsSession.GetDefaultFolder(olFolderCalendar)
         Set actExp = fldCalendar.GetExplorer()
     Else
         Set actExp = olkApp.ActiveExplorer
     End If
     ' 予定表モジュールを取得
     Set navModule = actExp.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
     ' 予定表グループのリストを取得
     Set navGroups = navModule.NavigationGroups
     For i = 1 To navGroups.Count
         Set navGroupT = navGroups.Item(i)
         ' 追加しようとしているグループが既に存在していた場合
         If navGroupT.Name = strGroupName Then
             ' 既存の予定表はすべて削除
             With navGroupT.NavigationFolders
                 For j = .Count To 1 Step -1
                     Dim navFolder 'As NavigationFolder
                     Set navFolder = .Item(j)
                     .Remove navFolder
                 Next
             End With
             ' 既存の予定表グループを返す
             Set GetNavigationGroup = navGroupT
             Exit Function
         End If
     Next
     ' 新規に予定表グループを作成して返す
     Set GetNavigationGroup = navGroups.Create(strGroupName)
End Function

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