Split Outlook Attachment/Outlookの添付ファイルを解除・一括保存

2009-01-27T23:11:00.004+09:00

Overview

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 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

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

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

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

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

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 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:

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 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 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以外はそのまま。感謝。

http://www.outlookcode.com/codedetail.aspx?id=1077

大まかな処理の流れはここから

http://www.chameleonic.org/incident/120

Google Desktop Linux 64bit + Windows File Server

2009-01-20T20:42:00.005+09:00

Overview

Google DesktopへのいわゆるReverse Proxy。

- RHELへGoogle Desktop Linux 64bitをインストール
- RedHat Enterprise Linux(RHEL) 5.2 64bit から Windows File Serverの共有Folderをcifsでmount
- RHELのGoogle DesktopでWindows共有Folderを検索フォルダに追加、検索結果から参照
Server・Clientとも同じLANセグメントなので、検索結果から直接File Serverを参照する
Client Browserからのファイル参照時のパスは、とりあえずmod_rewrite + cgi scriptで対応

約35,000ファイルのIndexが一晩で完了。

Package

httpd-2.2.3-11.el5_2.4

google-desktop-linux-1.2.0-0088

編集したファイル

- /etc/httpd/conf/httpd.conf

ProxyRequests On

Order deny,allow

Allow from x.y.z.0

- /etc/httpd/conf.d/proxy.conf

ProxyPass /cgi-bin !

ProxyPass / http://localhost:33849/

ProxyPassReverse / http://localhost:33849/

ProxyPreserveHost Off

RewriteEngine On

RewriteRule url=([^&]+) /cgi-bin/showFile.cgi?$1 [R,L,NE]

RewriteEngine On

RewriteRule url=([^&]+) /cgi-bin/openFolder.cgi?$1 [R,L,NE]

- /var/www/cgi-bin/showFile.cgi

#!/usr/bin/perl

use URI::Escape;

my $file = uri_unescape($ENV{QUERY_STRING});

$file =~ s/\\/\//g; # to replace \ by /

$file =~ s/\+/ /g; # to replace + by space

#some operation to build a correct path

$file =~ s/\/mnt\//\/\//g;

print "Location: $file\n\n";

- /var/www/cgi-bin/openFolder.cgi

#!/usr/bin/perl

use URI::Escape;

my $file = uri_unescape($ENV{QUERY_STRING});

$file =~ s/\\/\//g; # to replace \ by /

$file =~ s/\+/ /g; # to replace + by space

#some operation to build a correct path

$file =~ s/\/mnt\//\/\//g;

$file = "$file/../";

print "Content-type: text/html\n\n";

print "Some tags to redirect\n";

print "$file\n";

問題点

IE以外のBrowserからはHTTP 302 Found
パスに"～"・空白等を含む場合、リンククリックで開けない
検索結果のフォルダが開けない
"フォルダを開く"リンクの処理にはイマイチ
キャッシュの表示画面から最新表示をするときのパスに未対応
キャッシュの複数世代を未確認

とりあえずIEからは検索・ファイル参照ができている。

参考

Providing access to the Google Desktop search service from remote machines

http://groups.google.com/group/Google-Desktop-Linux

Google search from a remote machine

http://www.oreillynet.com/pub/a/network/2004/10/14/google_desktop.html

Download Kaleidscope

http://dnka.com/

asynchronics

Split Outlook Attachment/Outlookの添付ファイルを解除・一括保存

Google Desktop Linux 64bit + Windows File Server