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


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


PCリプレースのプロジェクトに関わっており、以前の記事にございました
Outlook 個人用フォルダ ファイルのパス名を取得するスクリプト
を使用して情報の取得を考えております。

取得したPSTファイルの形式が「Office 97-2002 形式 (ANSI)」か「Outlook 2003 以降の形式 (Unicode)」かを
確認するレジストリ値はございますでしょうか。

Windows XP / Outlook2003 環境となります。


残念ながら、レジストリには PST が ANSI か Unicode かという情報が保存されていませんが、PST のファイル フォーマットの仕様によると、先頭から 11 バイト目の値が 14 または 15 なら ANSI、23 なら Unicode ということになるようです。
そこで、この値を確認するようスクリプトを更新しました。

スクリプトは以下の通りです。

' ここをトリプルクリックでスクリプト全体を選択できます。
    Const HKEY_CURRENT_USER = &H80000001
    Const MAPI_PROFILE_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
    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, MAPI_PROFILE_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

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

プロファイルに含まれる PST の情報を Unicode/ANSI の種別も含めて取得するスクリプト」への5件のフィードバック

  1. ご指摘のとおりOutlookを起動した状態で実行しておりました。
    訂正して頂いたとのことで有難うございます。
    再度実行したところ新たなエラーがでてしまいました。

    行:45
    文字:17
    エラー:オブジェクトがありません。:’stmLog’
    コード:800A01A8
    ソース:Microsoft VBScript実行時エラー

    たびたび申し訳ございませんが
    ご確認宜しくお願い致します。

      • ありがとうございます。
        エラーはでなくなりpstpath.txtに情報が書き込まれるようになりましたが
        すべて”Unknown”となっておりました。

        私はPSTを複数もっており、ANSI・Unicodeが混在しているのですが
        不明だったということでしょうか・・?

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中