テキスト ファイルに記載された深い階層のフォルダーを一度に作成するマクロ

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


お世話になっております。以前に “https://outlooklab.wordpress.com/2016/10/22/深い階層のフォルダーを一度に作成するマクロ/” で質問させていただきました。

前回質問させていただいた内容を応用し、フォルダー A のサブフォルダーとして作成したサブフォルダー B に対し、サブフォルダー B の配下にサブフォルダー B1 とか B2 など、並列した複数のサブフォルダーを一括作成したいと考えています。
また、同様に、フォルダー A のサブフォルダーとしてサブフォルダー C を作成し、さらに、サブフォルダー C の配下にサブフォルダー C1 とか C2 を作成したいと考えています。

何卒よろしくお願いします。


複数のフォルダーを一括作成ということとなると、そのフォルダーをまとめて指定する必要があります。
今回はテキストファイルに以下のように記述しておき、現在選択しているフォルダーの下にサブフォルダーを作成するマクロにしてみました。

A\B\B1
A\B\B2
A\C\C1
A\C\C2

テキストファイルのファイル名はマクロ冒頭の FOLDER_PATH_FILE で指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub CreateDeepSubFolderInFile()
     On Error Resume Next
     Const FOLDER_PATH_FILE = "c:\temp\folderpath.txt"
     Dim fldRoot As Folder
     Dim fldSub As Folder
     Dim strPath As String
     Dim astrFolders As Variant
     Dim strSub As Variant
     '
     Open FOLDER_PATH_FILE For Input As #1
     While Not EOF(1)
         Line Input #1, strPath
         If strPath <> "" Then
             astrFolders = Split(strPath, "\")
             Set fldRoot = ActiveExplorer.CurrentFolder
             For Each strSub In astrFolders
                 Set fldSub = Nothing
                 Set fldSub = fldRoot.Folders(strSub)
                 If fldSub Is Nothing Then
                     Set fldSub = fldRoot.Folders.Add(strSub)
                 End If
                 Set fldRoot = fldSub
             Next
         End If
     Wend
     Close #1
End Sub

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

広告

メールに含まれる URL のファイルをマイ ドキュメントに保存するマクロ

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


いつもご教授いただき、ありがとうございます。

紙面上の内容をイントラ にアップするための作業を
outlook VBAで対処できるか教えてください。

具体的な作業としては、
①スキャナー(URL送信)で紙面上の内容を取り込む 
②メールを開いて、本中のURLを開き、PDFをマイドキュに保存
しています。

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


上記の 1 についてはスキャナーから自動的に URL が記載されたメールが送信されてくるということでしょうか?
となると、VBA で実装するのは 2 だけになりますね。
メール本文から URL を取得するには MailItem オブジェクトの Body プロパティを使用します。
このプロパティについて InStr 関数により URL の先頭となる http:// という文字列を検索し、URL の終わりとなるような文字までを取得します。
こうして取得した URL をダウンロードしてファイルに保存するには、Windows の URLDownloadFileA という API が使用できます。
マクロとして現在表示中のメールの URL をダウンロードする DownloadFileInBody と表示中のフォルダー内のすべてのメールの URL を一括ダウンロードする DownloadFileInCurrentFolder を作ってみました。

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

'   URL のファイルをダウンロードする API
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
     "URLDownloadToFileA" ( _
     ByVal pCaller As Long, _
     ByVal szURL As String, _
     ByVal szFileName As String, _
     ByVal dwReserved As Long, _
     ByVal lpfnCB As Long) As Long
'   表示中のメールの URL をダウンロードするプロシージャ
Public Sub DownloadFileInBody()
     Dim objMail As mailItem
     ' 表示しているウィンドウによりメールを判断
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set objMail = ActiveInspector.CurrentItem
     Else
         Set objMail = ActiveExplorer.Selection(1)
     End If
     ' 表示しているメールのダウンロード
     DownloadFileInBodyCore objMail
End Sub
'   表示中のフォルダー内のメールの URL を一括ダウンロード
Public Sub DownloadFileInCurrentFolder()
     Dim fldCurrent As Folder
     Dim objMail As mailItem
     ' 表示中のフォルダーを取得
     Set fldCurrent = ActiveExplorer.CurrentFolder
     ' フォルダー内のメールすべてについて処理
     For Each objMail In fldCurrent.Items
         ' 一つのメールのダウンロード
         DownloadFileInBodyCore objMail
     Next
End Sub
'   メール内の URL を取得してダウンロードするプロシージャ
Private Sub DownloadFileInBodyCore(ByVal objMail As mailItem)
     Dim strBody As String
     Dim iStart As Integer
     Dim iEnd As Integer
     Dim strUrl As String
     Dim strFile As String
     Dim wshShell As Variant
     Dim strMyDoc As String
     ' 本文を取得
     strBody = objMail.Body
     ' URL の検索
     iStart = InStr(strBody, "http" & "://")
     ' URL が見つかったら
     If iStart > 0 Then
         ' URL の終わりを検索
         For iEnd = iStart To Len(strBody)
             Select Case Mid(strBody, iEnd, 1)
                 ' スペース、タブ、改行 " > を URL の終端とする
                 Case " ", vbTab, vbCr, """", ">"
                     Exit For
             End Select
         Next
         ' 本文から URL を取得
         strUrl = Mid(strBody, iStart, iEnd - iStart)
         ' URL からファイル名を取得
         strFile = Mid(strUrl, InStrRev(strUrl, "/") + 1)
         ' ファイル名に ? が含まれていたら _ に置換
         strFile = Replace(strFile, "?", "_")
         ' マイ ドキュメント フォルダーを取得
         Set wshShell = CreateObject("WScript.Shell")
         strMyDoc = wshShell.SpecialFolders("MyDocuments")
         ' URL のファイルをダウンロード
         URLDownloadToFile 0, strUrl, strMyDoc & "\" & strFile, 0, 0
     End If
End Sub

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

差出人の名前を変更して送信するマクロ

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


いつも頼りにさせていただいています。

Outlook2010ですが、海外の人向けにメールを送る際に、差出人の名前を英語に変更したい(日本に送る際は日本語で)とおもい、ItemSendで変更しようと思ったのですが読み取り専用ばかりで、良いプロパティが見つかりません。

アドバイス頂けると助かります。


差出人を変更したい場合、MailItem オブジェクトの SentOnBehalfOfName プロパティで変更が可能です。
ただし、このプロパティの名前からすると差出人の名前だけ変更するようなイメージになるのですが、実際には名前だけを指定するとその名前でアドレス帳を検索し、名前解決されたユーザーとして送信しようとします。
そのため、自分自身のアドレスで名前だけ変えたい場合は、名前の後に “<SMTP アドレス>” という文字を追加する必要があります。
また、このプロパティで差出人の名前を変えられるのは POP や IMAP といったインターネットのアカウントを使用している場合のみです。
Exchange サーバー環境や Outlook.com では差出人の名前はサーバー上の情報をもとに設定され、クライアント側で指定された名前が無視されるためです。
ItemSend で変更したいとのことだったのですが、どのような基準で日本語と英語を使い分けるのかがちょっと不明だったので、差出人を変更して送信するマクロとしました。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub SendUsingAlternativeName()
     ' 変更後の名前を指定
     Const ALT_NAME = "Test User"
     '
     Dim objMail As MailItem
     ' 表示しているメールを取得
     Set objMail = ActiveInspector.CurrentItem
     ' 差出人を指定
     objMail.SentOnBehalfOfName = ALT_NAME & " <" & _
         Session.CurrentUser.Address & ">"
     ' メールを送信
     objMail.Send
End Sub

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

指定した分類項目のアイテムのアラームを解除するマクロ

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


お世話になっております。

指定の分類項目だけアラーム解除されるマクロを教えていただきたいです。


特定のフォルダー内のアイテムで指定された分類項目のアイテムを検索するには Items オブジェクトの Find メソッドが使用できます。
Find メソッドで条件を指定して検索を実行すると見つかったアイテムが返りますが、次のアイテムを検索するには FindNext を呼び出します。
そして、FindNext が Nothing を返すまで繰り返し呼び出すことで、検索条件に一致するアイテムをすべて取得することが可能です。
アラームの設定は ReminderSet プロパティにより行い、ReminderSet を False とするとアラームが解除できます。
現在表示しているフォルダー内の特定の分類項目を持つアイテムのアラームを解除するマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ClearAlarmForACategory()
     ' 検索する分類項目を指定
     Const CLEAR_CATEGORY = "テスト"
     '
     Dim fldCurrent As Folder
     Dim colItems As Items
     Dim objItem As MailItem
     ' 現在表示中のフォルダーを取得
     Set fldCurrent = ActiveExplorer.CurrentFolder
     ' フォルダーのアイテム一覧を取得
     Set colItems = fldCurrent.Items
     ' 指定された分類項目のアイテムを検索
     Set objItem = colItems.Find("[分類項目]='" & CLEAR_CATEGORY & "'")
     ' アイテムが見つからなくなるまで繰り返す
     While Not objItem Is Nothing
         ' アラームが設定されていたら解除
         If objItem.ReminderSet Then
             objItem.ReminderSet = False
             objItem.Save
         End If
         ' 次のアイテムを検索
         Set objItem = colItems.FindNext
     Wend
End Sub

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

共有メールボックスの受信トレイのメールを Excel ファイルにエクスポートするマクロ

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


共有メールフォルダに受信したメールをエクセルに書き出したい

outlookで個人アドレスの他に2つの共有アドレスを
使用しておりそれぞれのShared Mailboxに受信したメールをいちいち検索しなければいけない業務があります。
  個人の受信フォルダーにあるメールのエクセルへの
書き出しマクロは見かけるのですが共有フォルダのものは見つけられません、
またそれらを参考に自作を試みたもののシステムエラー続きでお手上げです。
  受信時間、送信者、件名、本文(全文は不要)をエクセルに書き出すマクロを教えてください。


共有メールボックスの受信トレイを取得するには NameSpace オブジェクトの GetSharedDefaultFolder メソッドを使用します。
このメソッドで取得した Folder オブジェクトの Items に含まれるすべてのアイテムについて Excel ファイルへ受信日時などをエクスポートすればご要望は満たせるでしょう。

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

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

Public Sub ExportInboxInSharedMailboxToExcel()
     ' 共有メールボックスのメールアドレスを指定
     Const SHARED_MAILBOX = "shared1@example.com"
     ' Excel ファイルのファイル名を指定
     Const EXCEL_FILE = "c:\temp\sharedmail.xlsx"
     ' Excel ファイルに書き出す本文の最大文字数
     Const MAX_BODY_CHARS = 250
     '
     Dim recOther As Recipient
     Dim fldOtherInbox As Folder
     Dim objBook
     Dim objSheet
     Dim objItem 'As MailItem
     Dim r As Integer
     ' 共有メールボックスの受信トレイを開く
     Set recOther = Session.CreateRecipient(SHARED_MAILBOX)
     Set fldOtherInbox = Session.GetSharedDefaultFolder(recOther, olFolderInbox)
     ' Excel ファイルを開く
     Set objBook = GetObject(EXCEL_FILE)
     objBook.windows(1).Activate
     Set objSheet = objBook.sheets(1)
     ' 1 行目はタイトルとして使用し、2 行目からデータ
     r = 2
     ' データがない行まで移動
     While objSheet.Cells(r, 1) <> ""
         r = r + 1
     Wend
     ' 共有メールボックスの受信トレイのすべてのアイテムについて処理
     For Each objItem In fldOtherInbox.Items
         ' メールの情報を Excel ファイルに追記
         With objSheet
             .Cells(r, 1) = objItem.ReceivedTime
             ' 差出人の名前にアドレスが含まれない場合のみアドレスを追加
             If InStr(objItem.SenderName, objItem.SenderEmailAddress) = 0 Then
                 .Cells(r, 2) = objItem.SenderName & _
                     " <" & objItem.SenderEmailAddress & ">"
             Else
                 .Cells(r, 2) = objItem.SenderName
             End If
             .Cells(r, 3) = objItem.Subject
             .Cells(r, 4) = Left(objItem.Body, MAX_BODY_CHARS)
         End With
         r = r + 1
     Next
     ' Excel ファイルを閉じる
     objBook.Close True
End Sub

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

メール送信時に配布グループを展開してアドレスを確認し、社外のアドレスへの送信で警告を表示するマクロ

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


はじめまして。
初心者ゆえ色々と参考にさせて頂き助かっております。
単純な質問で申し訳ありません。
Exchange環境でOutlook2016でメール送信時にメーリングリスト(グローバル配布先グループ)の
メンバーのSMTPアドレスを展開してメッセージ表示させるようにしたいのですが、
どうすれば良いのでしょうか。
グローバルの配布先グループに社外アドレスが含まれているものもあり、警告を出したいと
考えています。
ご教授のほど、宜しくお願い致します。


Exchange の配布グループについては Recipient オブジェクトの AddressEntry プロパティの GetExchangeDistributionList メソッドで ExchangeDistributionList オブジェクトとして取得可能です。
また、グループのメンバーは  ExchangeDistributionList オブジェクトの GetExchangeDistributionListMembers メソッドで AddressEntries として取得可能です。
これらのオブジェクトを使用してメンバーを展開することができます。
また、以前 Outlook の連絡先グループを展開するマクロについても「連絡先グループのメンバーを展開してメールアドレスを取得するマクロ」として作成していましたので、こちらの機能も追加しました。

マクロは以下の通りです。

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

'
Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
Const REC_DELIMITER = "; " ' 複数受信者を表示する際の区切り文字
'
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Dim objRec As Recipient
     Dim strSMTPAddr As String
     Dim strOut As String
     Dim iRet As Integer
     ' 組織外の受信者が存在するかどうかの確認
     bExternal = False
     strOut = ""
     For Each objRec In Item.Recipients
         ' 受信者の種類で判断
         Select Case objRec.AddressEntry.AddressEntryUserType
             Case olExchangeDistributionListAddressEntry
                 ' Exchange の配布グループの展開
                 ExpandExDistList objRec.AddressEntry, strOut
             Case olOutlookDistributionListAddressEntry
                 ' Outlook の連絡先グループの展開
                 ExpandOlContactGroup objRec, strOut
             Case Else
                 ' グループではない受信者
                 strSMTPAddr = GetSMTPAddr(objRec.AddressEntry)
                 If Not strSMTPAddr Like MY_DOMAIN Then
                     strOut = strOut & strSMTPAddr & REC_DELIMITER
                 End If
         End Select
     Next
     ' 組織外の受信者が含まれていた場合の処理
     If strOut <> "" Then
         iRet = MsgBox("あて先に組織外のドメインのメールアドレスが含まれています。送信しますか?" & _
             vbCrLf & "外部ドメイン宛: " & strOut, vbYesNo, "送信確認")
         Select Case iRet
             Case vbYes
                 ' 送信日時を 1 分後に設定
                 Item.DeferredDeliveryTime = DateAdd("n", 1, Now)
                 Cancel = False ' 念のため
             Case vbNo
                 Cancel = True
         End Select
     End If
End Sub
' SMTP アドレス取得関数
Private Function GetSMTPAddr(objAddrEntry As AddressEntry)
     Const PR_ORIGINAL_DISPLAY_NAME = "http:" & "//schemas.microsoft.com/mapi/proptag/0x3a13001e"
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
     Dim strSMTPAddr As String
     If objAddrEntry.Type = "SMTP" Then
         strSMTPAddr = objAddrEntry.Address
     Else ' Exchange 対応
         If objAddrEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
             strSMTPAddr = objAddrEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
         Else
             strSMTPAddr = objAddrEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
         End If
     End If
     GetSMTPAddr = strSMTPAddr
End Function
' Exchange 配布グループを展開するサブ プロシージャ
Private Sub ExpandExDistList(objExchDL As AddressEntry, ByRef strOut As String, Optional ByVal strExpanded As String = "")
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
     Dim objExDistList As ExchangeDistributionList
     Dim colMembers As AddressEntries
     Dim objMember As AddressEntry
     Dim strSMTPAddr As String
     '
     If InStr(strExpanded, objExchDL.ID & ";") > 0 Then
         Exit Sub    ' 展開済みのグループは展開しない
     End If
     strExpanded = strExpanded & objExchDL.ID & ";"
     ' Exchange 配布グループ オブジェクトを取得
     Set objExDistList = objExchDL.GetExchangeDistributionList
     ' 配布グループのメンバーを取得
     Set colMembers = objExDistList.GetExchangeDistributionListMembers
     ' メンバーごとに処理
     For Each objMember In colMembers
         If objMember.AddressEntryUserType = olExchangeDistributionListAddressEntry Then
             ' メンバーが配布グループなら再帰して展開
             ExpandExDistList objMember, strOut, strExpanded
         Else
             ' メンバーの SMTP アドレスを取得
             strSMTPAddr = GetSMTPAddr(objMember)
             ' メンバーのアドレスが社外なら社外リストに追加
             If Not strSMTPAddr Like MY_DOMAIN Then
                 strOut = strOut & strSMTPAddr & REC_DELIMITER
             End If
         End If
     Next
End Sub
' Outlook の連絡先グループを展開するサブ プロシージャ
Private Sub ExpandOlContactGroup(objRec As Recipient, ByRef strOut As String, Optional ByVal strExpanded As String = "")
     Dim strCbLo As String
     Dim strCbHi As String
     Dim iCb As Integer
     Dim strEntryID As String
     Dim distList As DistListItem
     Dim objMember As Recipient
     Dim strSMTPAddr As String
     Dim i
     '
     If strExpanded = "" Then ' 展開済みのグループがない = トップのグループ
         ' 65 文字目からの 4 文字がエントリー ID の長さ
         strCbLo = Mid(objRec.AddressEntry.ID, 65, 2)
         strCbHi = Mid(objRec.AddressEntry.ID, 67, 2)
         iCb = Val("&H" & strCbHi & strCbLo)
         ' 73 文字目からがアイテムのエントリー ID
         strEntryID = Mid(objRec.AddressEntry.ID, 73, iCb * 2)
         Set distList = Session.GetItemFromID(strEntryID)
     Else ' 入れ子になっているグループの場合は 43 文字目からがアイテムのエントリー ID
         strEntryID = Mid(objRec.AddressEntry.ID, 43)
     End If
     '
     If InStr(strExpanded, strEntryID) > 0 Then
         Exit Sub      ' 展開済みのグループは展開しない
     End If
     strExpanded = strExpanded & strEntryID & ";"
     ' 連絡先グループ オブジェクトを取得
     Set distList = Session.GetItemFromID(strEntryID)
     ' メンバーごとに処理
     For i = 1 To distList.MemberCount
         Set objMember = distList.GetMember(i)
         If objMember.Address = "Unknown" Then
          ' メンバーが配布グループなら再帰して展開
             ExpandOlContactGroup objMember, strOut, strExpanded
         Else
             ' メンバーの SMTP アドレスを取得
             strSMTPAddr = GetSMTPAddr(objMember.AddressEntry)
             ' メンバーのアドレスが社外なら社外リストに追加
             If Not objMember.Address Like MY_DOMAIN Then
                 strOut = strOut & objMember.Address & REC_DELIMITER
             End If
         End If
     Next
End Sub

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

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

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