VBA マクロにおける Application オブジェクト

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


いつも大変に参考にさせて頂いております。
Outlookからメールを作成し、その際ファイルを選択するダイアログボックスを表示させ、選択したファイルをメールに添付させるマクロを考えております。
同様のマクロはExcelから作成できていたのですが、そのマクロをOutlook側で使用しようとしたところ、ファイルを選択するところで使用している以下のコードでエラーとなってしまいました。
OpenFileName = Application.GetOpenFilename(“Microsoft Excelブック,*.xlsx”)

捕捉しますと処理の流れは
①メール作成
②Application.GetOpenFilenameでファイル選択
③メールに添付
というのが大まかな流れです。

OutlookのマクロではApplication.GetOpenFilenameが利用できないのかなと勝手に推測しているのですが、代替コードなどありましたらご教示頂けますと幸いです。
宜しくお願い致します。


VBA で Application オブジェクトはそのマクロを実行しているプログラムを意味します。

そのため、Excel 上でマクロを実行しているときの Application は Excel ですが、Outlook 上では Application は Outlook となり、Outlook の Application オブジェクトには GetOpenFilename というメソッドがないためエラーになります。

Outlook で Excel の Application の機能を呼び出したいときには、以下のようにします。


Set appExcel = CreateObject("Excel.Application")
OpenFileName = appExcel.GetOpenFilename("Microsoft Excel ブック,*.xlsx")

広告

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

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


お世話になっております。以前に “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

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

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

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

Office 2016

Outlook 2016 の修正

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

Word 2016 の修正

Word 2016 のセキュリティ更新プログラムについて: 2018 年 10 月 10 日
1 件の Outlook に関するセキュリティ以外の修正が行われています。

Office 2016 の修正

2018 年 10 月 2日更新プログラム Office 2016 (KB4461442)
こちらは 10/2 にリリースされたものですが、1 件の Outlook に関する不具合の修正が行われています。

Office 2013

Outlook 2013 の修正

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

Office 2010

Outlook 2010 の修正

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

共有メールボックスの受信トレイのメールを 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

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