Outlook 2013 のプロファイルに含まれる PST の情報を Unicode/ANSI の種別も含めて取得するスクリプト


以前、プロファイルに含まれる PST の情報を Unicode/ANSI の種別も含めて取得するスクリプトを作成しました。

しかし、Outlook 2013 ではプロファイル情報を保存するレジストリ キーが変更されたため、こちらのスクリプトは Outlook 2013 に対応しないものとなっています。
1 行の修正だけで済むのですが、プログラミングの経験がない方には修正が難しいようなので、Outlook 2013 対応のスクリプトを作成しました。

スクリプトは以下の通りです。
この内容をメモ帳などで拡張子 vbs として保存し、そのファイルをダブルクリックして実行すると、既定の MAPI プロファイルの PST の情報を C:\pstpath.txt に保存します。

' ここをトリプルクリックでスクリプト全体を選択できます。
    Const HKEY_CURRENT_USER = &H80000001
    Const MAPI_PROFILE_KEY = "Software\Microsoft\Office\15.0\Outlook\Profiles"
    Const OUTLOOK_KEY = "Software\Microsoft\Office\15.0\Outlook"
    Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
    Const PR_STORE_PROVIDERS = "01023d00"
    Const PR_PST_PATH = "001f6700"
    Const LOG_FILE = "C:\pstpath.txt"
    Const adTypeBinary = 1
    Const PSTVER_POSITION = 11
    Const PSTVER_UNICODE = 23
    Dim stdRegProv
    Dim strDefaultProfile
    Dim strProfileKey
    Dim strServicesKey
    Dim arrStoreUIDs
    Dim objFS
    Dim stmText
    Dim iCount
    Dim i,j
    Dim strServiceKey
    Dim strPSTPath
    Dim arrData
    Dim iVer
'
    Set stdRegProv = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    stdRegProv.GetStringValue HKEY_CURRENT_USER, OUTLOOK_KEY, "DefaultProfile", strDefaultProfile
    strProfileKey = MAPI_PROFILE_KEY & "\" & strDefaultProfile & "\"
    strServicesKey = strProfileKey & MAPI_SERVICES_KEY
    stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, PR_STORE_PROVIDERS, arrStoreUIDs
'
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set stmText = objFS.CreateTextFile(LOG_FILE,True)
'
    iCount = (UBound(arrStoreUIDs)+1)/16
    For i=0 To iCount-1
        strServiceKey = ""
        For j=0 To 15
            strServiceKey = strServiceKey & Right("0" & Hex(arrStoreUIDs(i*16+j)), 2)
        Next
        stdRegProv.GetBinaryValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, PR_PST_PATH, arrData
        If Not IsNull(arrData) Then
            strPstPath = BinToUnicode(arrData)
            iVer = GetPSTVersion( strPstPath )
            If iVer = 0 Then
                stmText.WriteLine vbTab & strPstPath & vbTab & "Unknown"
            ElseIf iVer = PSTVER_UNICODE Then
                stmText.WriteLine vbTab & strPstPath & vbTab & "Unicode"
            Else
                stmText.WriteLine vbTab & strPstPath & vbTab & "ANSI"
            End If
        End If
    Next
    stmText.Close
'
    Set stdRegProv = Nothing
    Set stmText = Nothing
    Set objFS = Nothing
'
    Function BinToUnicode( arrData )
        Dim strUnicode
        Dim i
        strUnicode = ""
        For i = 0 To UBound(arrData) Step 2
            strUnicode = strUnicode & ChrW( arrData(i) + arrData(i+1) * &h100 )
        Next
        BinToUnicode = Replace( strUnicode, Chr(0), "" )
    End Function
'
    Function GetPSTVersion( strPstPath )
        On Error Resume Next
        Dim stmPST
        Dim abyData
        Set stmPST = CreateObject("ADODB.Stream")
        stmPST.Open
        stmPST.Type = adTypeBinary
        stmPst.LoadFromFile strPstPath
        abyData = stmPst.Read(PSTVER_POSITION)
        stmPst.Close
        If Err.Number <> 0 Then
            GetPSTVersion = 0
        Else
            GetPSTVersion = AscB(MidB(abyData, PSTVER_POSITION, 1))
        End If
    End Function

広告

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中