Outlookの添付ファイルを解除し、指定のフォルダへまとめて保存するVBA Macro。
元のメールメッセージは、添付ファイルを除いた状態で残す。
- フォルダツリーで選択しているフォルダを対象に、サブフォルダ配下もまとめて処理
- 初回のみ添付ファイルの保存先を指定し、設定を保持(Draftフォルダに下書きメールとして保存)
- 保存した添付ファイルのリストを.csvファイルで作成(日時・送信者・件名・添付ファイル1つ１行)
- 進捗をProgress Barで表示、途中でキャンセル可
- Macroを実行した日付時刻で"YYYYMMDD_HHNNSS_FolderName"フォルダを作成し、毎回そこへ保存
- 同名の添付ファイルが多数あり得るので、ファイル名の頭に"連番-"をつける(連番はMacroの呼出し毎に1から)
- メールアイテムだけを対象に処理し、カレンダー・タスク等は無視
動作/テスト環境
- Microsoft Outlook 2007
2003未検証。2007限定APIだったらごめんなさい。
Module
ThisOutlookSession : 処理本体への呼出部分のみ
SplitAttachment.bas : 処理本体. 再帰的にフォルダを処理するtraverse, 保存先フォルダ設定, 簡易INIファイル的処理
ProgressBox.frm : 進捗表示のProgressBar + CancelButton. Thanks a lot for Steve Bateman!
Install
- ModuleのAttachment.bas, ProgressBox.frmのテキストファイルを作り、以下ソースをCopy&Paste.
- Outlookメニューの[ツール]->[マクロ]->[セキュリティ]で"すべてのマクロに大して警告を表示"以下緩い方に設定.
- OutlookでAlt + F11でVB Editorを表示、ThisOutlookSessionに↓ソースをCopy&Paste.
- Projectツリーで[ファイルのインポート]よりSplitAttachment.bas, ProgressBox.frmをインポート.
- メニューなりボタンなりでThisOutlookSession.splitAttachmentsを呼出し.
たぶんこれで大丈夫。Installer作ろうか。
Source
- ThisOutlookSession
Option Explicit
Public Sub splitAttachments()
SplitAttachment.main
End Sub
- SplitAttachment.bas
Attribute VB_Name = "SplitAttachment"
Option Explicit
Const INI_SECTION_NAME As String = "Split Attachments"
Const INI_ITEM_FOLDER_PATH As String = "SAVE_FOLDER_PATH"
Const CONFIG_SUBJECT As String = "_Macro_Config"
Public flgCancel As Boolean
Private strFolder As String
Private count As Integer
Private fso As Scripting.FileSystemObject
Private ts As Scripting.TextStream
Private configMap As Scripting.Dictionary
Private flgConfigFound As Boolean
Public Sub main()
Dim strFolderName As String
On Error GoTo Cleanup:
count = 0
flgCancel = False
flgConfigFound = True
With GetNamespace("MAPI")
strFolderName = .Application.ActiveExplorer.CurrentFolder.Name
strFolder = getSaveFolderPath()
strFolder = strFolder & "_" & strFolderName
If flgCancel Then
GoTo Cleanup:
End If
If MsgBox(strFolderName & " の添付ファイルを解除しますか？" & vbCrLf & vbCrLf & _
strFolder & " に保存されます" & _
IIf(flgConfigFound, vbCrLf & "※保存先を変更するには[Drafts]の " & CONFIG_SUBJECT & " メッセージを編集してください", ""), _
vbOKCancel + vbQuestion + vbDefaultButton2) = vbOK Then
traverseFolder .Application.ActiveExplorer.CurrentFolder
If count > 0 Then
MsgBox count & "個のファイルを " & strFolder & " に保存しました。" _
& IIf(flgCancel, vbCrLf & "<キャンセルしました>", ""), vbInformation
Shell "explorer " & strFolder, vbNormalFocus
End If
End If
End With
Cleanup:
If Err.Number <> 0 Then
MsgBox Err.Description, vbExclamation
End If
If Not ts Is Nothing Then
ts.Close
End If
Set ts = Nothing
If count = 0 And (Not fso Is Nothing) Then
If fso.FolderExists(strFolder) Then
fso.DeleteFolder strFolder, True
End If
End If
Set fso = Nothing
Set configMap = Nothing
End Sub
Private Sub traverseFolder(folder As Outlook.folder)
Dim i As Integer
Dim itemCount As Integer
Dim msg As MailItem
Dim msgItems As Items
Dim childFolder As Outlook.folder
If flgCancel Then
Exit Sub
End If
On Error GoTo Cleanup:
For Each childFolder In folder.Folders
traverseFolder childFolder
Next
Const COL_ATTCH As String = "添付ファイル"
'Const COL_ATTCH As String = "Attachment"
Set msgItems = folder.Items.Restrict("[" & COL_ATTCH & "] = True")
itemCount = msgItems.count
i = 0
ProgressBox.Show
If itemCount > 0 And (fso Is Nothing) Then
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateFolder strFolder
Set ts = fso.OpenTextFile(strFolder & "\_FileList.csv", ForAppending, True)
End If
'For Each msg In msgItems
' i = i + 1
For i = msgItems.count To 1 Step -1
If TypeName(msgItems(i)) = "MailItem" Then
Set msg = msgItems(i)
ProgressBox.Increment CSng((itemCount - i) / itemCount) * 100, msg.subject
On Error Resume Next
saveAttachment msg, folder
DoEvents
On Error GoTo Cleanup:
End If
Next
Cleanup:
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical
End If
ProgressBox.Hide
Set msgItems = Nothing
End Sub
Private Sub saveAttachment(msg As MailItem, folder As Outlook.folder)
If flgCancel Then
Exit Sub
End If
Dim i As Integer
Dim att As Attachment
With msg
For i = .Attachments.count To 1 Step -1
ts.WriteLine _
"""" & count & _
""",""" & folder.FolderPath & _
""",""" & .ReceivedTime & _
""",""" & .SentOn & _
""",""" & .SenderEmailAddress & _
""",""" & .SenderName & _
""",""" & .subject & _
""",""" & i & _
""",""" & .Attachments(i).DisplayName & _
""""
On Error Resume Next
.Attachments(i).SaveAsFile (strFolder & "\" & count & "-" & .Attachments(i).FileName)
If Err.Number <> 0 Then
MsgBox Err.Description
.Display
Else
.Attachments(i).Delete
.Save
count = count + 1
End If
On Error GoTo 0
Next
End With
End Sub
Private Function getSaveFolderPath() As String
Dim strFolderRoot As String
Dim objFolder As Object
Dim msg As Outlook.MailItem
strFolderRoot = getConfig(INI_SECTION_NAME, INI_ITEM_FOLDER_PATH)
If strFolderRoot = "" Then
Const strTitle = "フォルダを選択してください。"
Const lngRef = &H1
flgConfigFound = False
strFolderRoot = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, strTitle, lngRef, strFolderRoot)
flgCancel = True
If Not objFolder Is Nothing Then
If Not objFolder.ParentFolder Is Nothing Then
strFolderRoot = objFolder.Items.Item.Path
flgCancel = False
'指定したパスをConfigとしてDraftsへ保存
Set msg = Application.CreateItem(olMailItem)
msg.subject = CONFIG_SUBJECT
msg.BodyFormat = olFormatPlain
msg.body = "[" & INI_SECTION_NAME & "]" & _
vbCrLf & INI_ITEM_FOLDER_PATH & " = " & strFolderRoot
msg.Save
End If
End If
Set objFolder = Nothing
End If
getSaveFolderPath = strFolderRoot & "\" & Format(Now(), "YYYYMMDD_HHNNSS")
End Function
'configMapから指定セクションの設定値を取得
Public Function getConfig(sectionName As String, itemName As String) As String
Dim sectionMap As Scripting.Dictionary
getConfig = ""
If configMap Is Nothing Then Call initConfig
If configMap.Exists(sectionName) Then
Set sectionMap = configMap.Item(sectionName)
If sectionMap.Exists(itemName) Then
getConfig = sectionMap.Item(itemName)
End If
End If
End Function
'MailItemを解析しconfigMapを構築
Public Function parseConfig(msg As MailItem) As Scripting.Dictionary
Const ITEM_DELIM As String = "="
Const SECTION_PREFIX As String = "["
Const SECTION_SUFFIX As String = "]"
Dim map As New Scripting.Dictionary
Dim mapSection As Scripting.Dictionary
Dim strLine() As String
Dim strItem() As String
Dim strSectionName As String
Dim l As Integer
strLine = Split(msg.body, vbCrLf)
For l = 0 To UBound(strLine)
strLine(l) = Trim$(strLine(l))
If Len(strLine(l)) = 0 Then GoTo NEXT_LINE:
If Left(strLine(l), 1) = SECTION_PREFIX And Right(strLine(l), 1) = SECTION_SUFFIX Then
If mapSection Is Nothing Then
Set mapSection = New Scripting.Dictionary
strSectionName = Mid(strLine(l), 2, Len(strLine(l)) - 2)
Else
map.Add strSectionName, mapSection
End If
Else
strItem = Split(strLine(l), ITEM_DELIM)
mapSection.Add Trim$(strItem(0)), Trim$(strItem(1))
End If
NEXT_LINE:
Next
map.Add strSectionName, mapSection
Set parseConfig = map
End Function
Public Sub initConfig()
'Drafts/下書きフォルダからMailItemをpick up
Dim msg As Object
Set configMap = New Scripting.Dictionary
For Each msg In GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts).Items
If TypeName(msg) = "MailItem" Then
If msg.subject = CONFIG_SUBJECT Then
Set configMap = parseConfig(msg)
End If
End If
Next
End Sub
- ProgressBar.frm
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ProgressBox
Caption = "UserForm1"
ClientHeight = 3225
ClientLeft = 45
ClientTop = 330
ClientWidth = 4710
OleObjectBlob = "ProgressBox.frx":0000
ShowModal = 0 'False
StartUpPosition = 1 'オーナー フォームの中央
End
Attribute VB_Name = "ProgressBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Implements a progress box with a progress bar and space for user-defined text above the bar
' Uses Microsoft's Forms library (by default available with all office/VBA installations)
' To use in your VBA project:
' 1) Make sure that the "Microsoft Forms" object library is checked in Tools/References
' 2) Insert a blank User Form
' 3) Rename the user form to "ProgressBox"
' 4) Set the user form property "showModal" to false (so you can do other things while the dialog is displayed)
' 5) Show the code for the User Form, and highlight/delete everything
' 6) Insert this file (using insert/file) into the code for the User Form
' 7) Add appropriate code to your VBA routine where you want to show progress:
' * ProgressBox.Show --- shows the progress box. Include this before starting processing.
' * ProgressBox.Increment newPercent (single), NewText (optional string) --- updates the progress bar and optionally changes the text
' * ProgressBox.Hide --- removes the progress bar. Include this at the end of processing.
' 8) Optionally, you can get/set the percentage and the text individually using the "Percent" and "Text" properties, followed by calling ProgressBox.repaint
Private Const DefaultTitle = "Progress"
Private myText As String
Private myPercent As Single
' Text property shows user-defined text above the progress bar
Public Property Let Text(newText As String)
If newText <> myText Then
myText = newText
Me.Controls("UserText").Caption = myText
Call sizeToFit
End If
End Property
Public Property Get Text() As String
Text = myText
End Property
' Percent property alters the progress bar
Public Property Let Percent(newPercent As Single)
If newPercent <> myPercent Then
' limit percent to between 0 and 100
myPercent = Min(Max(newPercent, 0#), 100#)
Call updateProgress
End If
End Property
Public Property Get Percent() As Single
Percent = myPercent
End Property
' Increment method enables the percent and optionally the text to be updated at same time
Public Sub Increment(ByVal newPercent As Single, Optional ByVal newText As String)
Me.Percent = newPercent
If newText <> "" Then Me.Text = newText
Call updateTitle
Me.Repaint
End Sub
Private Sub CancelButton_Click()
splitAttachment.flgCancel = True
End Sub
' Setup the progress dialog - title, control layout/size etc.
Private Sub UserForm_Initialize()
Call setupControls
Call updateTitle
End Sub
' Prevents use of the Close button
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
' Removes any current controls, add the needed controls ...
Private Sub setupControls()
Dim i As Integer
Dim aControl As Label
' remove existing controls
' For i = Me.Controls.count To 1 Step -1
'
' Debug.Print Me.Controls(i).Caption
'
' If Me.Controls(i).Caption <> "Cancel" Then
' Me.Controls(i).Remove
' End If
' Next i
' add user text - don't worry about positioning as "sizeToFit" takes care of this
Set aControl = Me.Controls.Add("Forms.Label.1", "UserText", True)
aControl.Caption = ""
aControl.AutoSize = True
aControl.WordWrap = True
aControl.Font.Size = 8
' add progressFrame - don't worry about positioning as "sizeToFit" takes care of this
Set aControl = Me.Controls.Add("Forms.Label.1", "ProgressFrame", True)
aControl.Caption = ""
aControl.Height = 16
aControl.SpecialEffect = fmSpecialEffectSunken
' add user text - don't worry about positioning as "sizeToFit" takes care of this
Set aControl = Me.Controls.Add("Forms.Label.1", "ProgressBar", True)
aControl.Caption = ""
aControl.Height = 14
aControl.BackStyle = fmBackStyleOpaque
aControl.BackColor = &HFF0000 ' Blue
' position the controls and size the progressBox
Call sizeToFit
End Sub
' Adjusts positioning of controls/size of form depending on size of user text
Private Sub sizeToFit()
' setup width of progress box
Me.Width = 240
' user-supplied text should be topmost, taking up the appropriate size ...
Me.Controls("UserText").Top = 6
Me.Controls("UserText").Left = 6
Me.Controls("UserText").AutoSize = False
Me.Controls("UserText").Font.Size = 8
Me.Controls("UserText").Width = Me.InsideWidth - 12
Me.Controls("UserText").AutoSize = True
' progress frame/bar should be below user text
Me.Controls("ProgressFrame").Top = Int(Me.Controls("UserText").Top + Me.Controls("UserText").Height) + 6
Me.Controls("ProgressFrame").Left = 6
Me.Controls("ProgressFrame").Width = Me.InsideWidth - 12
Me.Controls("ProgressBar").Top = Me.Controls("ProgressFrame").Top + 1
Me.Controls("ProgressBar").Left = Me.Controls("ProgressFrame").Left + 1
Me.Controls("CancelButton").Top = Me.Controls("ProgressFrame").Top + Me.Controls("ProgressFrame").Height + 6
Me.Controls("CancelButton").Width = Me.Controls("ProgressFrame").Width / 3
Me.Controls("CancelButton").Left = Me.Controls("ProgressFrame").Left + Me.Controls("CancelButton").Width
Call updateProgress ' update ProgressBar width
' finally, height of progress box should fit around text and progress bar & allow for title/box frame
Me.Height = Me.Controls("ProgressFrame").Top _
+ Me.Controls("ProgressFrame").Height _
+ Me.Controls("CancelButton").Height _
+ 6 + 6 + (Me.Height - Me.InsideHeight)
End Sub
' updates the caption of the progress box to keep track of progress
Private Sub updateTitle()
If (Int(myPercent) Mod 5) = 0 Then
Me.Caption = DefaultTitle & " - " & Format(Int(myPercent), "0") & "% Complete"
End If
End Sub
' updates the width of the progress bar to match the current percentage
Private Sub updateProgress()
If myPercent = 0 Then
Me.Controls("ProgressBar").Visible = False
Else
Me.Controls("ProgressBar").Visible = True
Me.Controls("ProgressBar").Width = Int((Me.Controls("ProgressFrame").Width - 2) * myPercent / 100)
If myPercent Mod 5 = 0 Then
Me.Repaint
DoEvents
End If
End If
End Sub
' Min and Max functions
Private Function Min(number1 As Single, number2 As Single) As Single
If number1 <>
Min = number1
Else
Min = number2
End If
End Function
Private Function Max(number1 As Single, number2 As Single) As Single
If number1 > number2 Then
Max = number1
Else
Max = number2
End If
End Function
問題・改善点
- ファイル保存時のネーミングがイマイチ？.csvよりも.xlsとかDBに放り込む方が便利か。
- どうせなら添付ファイル全部をフォルダ保存か、Zip圧縮にするか選べる方がいいかも
- 保存先フォルダの設定保持のために下書きメールを使うが？レジストリよりはいい？
- たぶん日本語環境以外では、添付ファイルつきメールを絞り込む段階で落ちる. "[添付ファイル] = True"じゃあねえ。
- インストールが面倒といえば面倒
添付ファイルを解除しても、メールフォルダを圧縮するまでは実際の.ost/.pstのファイルサイズは縮まらない。
まあこれはOutlookの仕様。
参考
- ProgressBar出展元。CancelButton以外はそのまま。感謝。
- 大まかな処理の流れはここから
