Outlook の個人用フォルダのサイズをチェックするスクリプト


Outlook の個人用フォルダのサイズがある程度大きくなってくると、Outlook のパフォーマンスに悪影響が発生します。Outlook には古いアイテムの自動整理機能があるため、こちらも使用しているのですが、突発的に大容量のメッセージを受信したような事態には対応ができません。
そのため、定期的にファイル サイズをチェックしているのですが、そのようなチェックを自動化したいと思ったため、スクリプトを作ってみました。

' ここをトリプルクリックでマクロ全体を選択できます。
Option Explicit
Const WARNING_SIZE = 1000000000 ' 警告するサイズを指定します。
Const HKEY_CURRENT_USER = &H80000001
Const MAPI_PROFILE_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
'
Dim objReg
Dim objFSO
Dim strKey
Dim strDefaultProfile
Dim strProfileKey
Dim strServicesKey
Dim abyStoreUIDs
Dim abyAddrBookUIDs
Dim iCount
Dim i,j
Dim strServiceKey
Dim strPSTPath
Dim abyData
Dim objPSTFile
Dim strWarning
'
' レジストリにアクセスするための WMI の StdRegProv オブジェクトを取得します。
Set objReg = GetObject( "winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
' ファイル情報にアクセスするための FileSystemObject オブジェクトを取得します。
Set objFSO = CreateObject("Scripting.FileSystemObject")
' 既定の MAPI プロファイルの名前を取得します。
objReg.GetStringValue HKEY_CURRENT_USER, MAPI_PROFILE_KEY, "DefaultProfile", strDefaultProfile
' プロファイルの名前からキーの文字列を生成します。
strProfileKey = MAPI_PROFILE_KEY & "\" & strDefaultProfile & "\"
strServicesKey = strProfileKey & MAPI_SERVICES_KEY
' メッセージ ストア プロバイダの ID の一覧を取得します。
objReg.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, "01023d00", abyStoreUIDs
' 警告メッセージを初期化します。
strWarning = ""
' メッセージ ストア プロバイダの ID ごとに処理します。
iCount = (UBound(abyStoreUIDs)+1)/16
For i=0 To iCount-1
    strServiceKey = ""
    ' 16 バイトのバイナリ データを文字列に変換します。
    For j=0 To 15
        strServiceKey = strServiceKey & Right("0" & Hex(abyStoreUIDs(i*16+j)), 2)
    Next
    ' Outlook 2002 の個人用フォルダのパスを取得します。
    objReg.GetStringValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, "001e6700", strPSTPath
    If IsNull(strPSTPath) Then
        ' Outlook 2003 の個人用フォルダのパスを取得します。
        objReg.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, "001f6700", abyData
        If Not IsNull(abyData) Then
            ' 取得できた場合にはバイナリデータを文字列に変換します。
            strPSTPath = BinaryToUnicodeString( abyData )
        End If
    End If
    If Not IsNull(strPSTPath) Then
        ' ファイルのサイズをチェックします。
        Set objPSTFile = objFSO.GetFile(strPSTPath)
        If objPSTFile.Size > WARNING_SIZE Then
            strWarning = strWarning & objPSTFile.Name & ": " & objPSTFile.Size & " バイト" & vbCrLf
        End If
    End If
Next
'
If strWarning <> "" Then
    MsgBox "以下の個人用フォルダのサイズが大きくなっています。アイテムを削除または移動した後、今すぐ圧縮を実行してサイズを小さくしてください。" _
        & vbCrLf & strWarning, vbCritical, "PST ファイル サイズ チェック"
End If
'
'    バイナリ データを Unicode 文字列に変換する関数です。
'
Function BinaryToUnicodeString( abyData )
    Dim strUnicode
    Dim i
    strUnicode = ""
    ' 2 バイトごとに Unicode 文字に変換します。
    ' 最初のバイトが下位バイト、次のバイトが上位バイトになります。
    For i = 0 To UBound(abyData) Step 2
        strUnicode = strUnicode & ChrW( abyData(i) + abyData(i+1) * &h100 )
    Next
    ' 文字列の中に NULL がある場合は取り除きます。
    BinaryToUnicodeString = Replace( strUnicode, Chr(0), "" )
End Function

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中