メールに含まれる 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

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

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google フォト

Google アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中