添付ファイルをディスクに保存し、そのファイルへのリンクをメッセージ本文に書き込むマクロ


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


pstファイルの容量制限もあり、添付ファイルを受けた場合、そのファイルをMy Documentsの関連フォルダーにコピーをし、メールの添付ファイルを削除するマクロを使っています。

この場合、ファイルを削除したことを記録として残すために【添付ファイル削除済み】という分類をつけています。
しかし、どのファイルを削除したかの記録ができず、時間がたつとコピーしたファイルが解らなくなります。
以前、コピーをしたファイルとリンクをつけるマクロがありますが、セキュリティアップデートしたら、添付ファイルが見えなくなってしまいました。

そこで、
①ファイル名を分類として記載し 【abc.xlsx 移動済み】というようにする。
②メール本文に 【abc.xlsx 移動済み】といれる。
を考えております。
②の方法が可能であれば教えてください。


こちらは、以前作成した添付ファイルをディスクに保存し、そのファイルへのリンクをメッセージの添付ファイルと置き換えるマクロに少し手を加えれば可能です。

マクロは以下の通りです。SaveAndDeleteAttachments を実行すると、アクティブなウィンドウで開いているアイテム、またはアイテム一覧で選択しているアイテムの添付ファイルをディスクに移動し、そのパスを本文の先頭に追記します。また、同時に分類項目も設定します。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub SaveAndDeleteAttachments()
    On Error Resume Next
    ' アクティブなウィンドウにより対象アイテムを変更
    If TypeName(ActiveWindow) = "Inspector" Then
        SaveAndDeleteAttachmentsInternal ActiveInspector.CurrentItem
    Else
        Dim objItem As MailItem
        For Each objItem In ActiveExplorer.Selection
            SaveAndDeleteAttachmentsInternal objItem
        Next
    End If
End Sub
'
Private Sub SaveAndDeleteAttachmentsInternal(objItem As MailItem)
    Const SAVE_DIR = "C:\ATTACHMENTS\"
    Dim objFSO
    Dim objAttach As Attachment
    Dim cAttach As Integer
    Dim strFileName As String
    Dim strExt As String
    Dim strBase As String
    Dim i As Integer
    Dim c As Integer
    Dim iIns As Integer
    Dim strLink As String
    '
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    With objItem
        ' 添付ファイルの挿入位置を決定
        If .BodyFormat = olFormatHTML Then
            iIns = InStr(1, objItem.HTMLBody, "<body", vbTextCompare)
            iIns = InStr(iIns, objItem.HTMLBody, ">", vbTextCompare)
        Else
            iIns = 0
        End If
        ' 添付ファイルの数だけ繰り返す
        cAttach = objItem.Attachments.Count
        For i = 1 To cAttach
            Set objAttach = .Attachments(i)
            strFileName = SAVE_DIR & objAttach.FileName
            strExt = Mid(strFileName, InStrRev(strFileName, "."))
            strBase = Left(strFileName, Len(strFileName) - Len(strExt))
            c = 1
            ' 同名のファイルが存在する場合は (1)、(2) をつける
            While objFSO.FileExists(strFileName)
                strFileName = strBase & "(" & c & ")" & strExt
                c = c + 1
            Wend
            ' 添付ファイルを保存
            objAttach.SaveAsFile strFileName
            ' 添付ファイルの情報を書き込み
            If .BodyFormat = olFormatHTML Then
                strLink = "【<a href=""file://" & strFileName & """>" & objAttach.FileName & "</a>移動済み】<br />"
                .HTMLBody = Left(.HTMLBody, iIns) & strLink & Mid(.HTMLBody, iIns + 1)
            Else
                strLink = "【" & objAttach.FileName & " <file://" & strFileName & ">移動済み】" & vbCrLf
                .Body = Left(.Body, iIns) & strLink & Mid(.Body, iIns + 1)
            End If
            .Categories = .Categories & ";" & objAttach.FileName & "移動済み"
            iIns = iIns + Len(strLink)
        Next
        ' 保存済みの添付ファイルを削除
        For i = cAttach To 1 Step -1
            .Attachments(i).Delete
        Next
        .Save
    End With
End Sub

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

広告

添付ファイルをディスクに保存し、そのファイルへのリンクをメッセージ本文に書き込むマクロ」への1件のフィードバック

  1. 本件も対応して頂き、ありがとうございます!!!
    仕事効率がアップします。本当に助かりありがとうございました。
    今後もよろしくお願いします。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中