Outlook pstファイルをダブルクリックで開く!

Outlook pstファイルは、個人用フォルダです。自分は仕事のプロジェクト毎に分割し、プロジェクトのフォルダ内に保存しています。
Outlookを使っている方で、メールや予定表など、バックアップはしているものの、何ギガというpstになっている方が多い気がします。これはバックアップの時間もかかりますし、一度Outlookを立ち上げると更新日が変更なり、自動バックアップの対象になります。
細分化がお勧めです。
細分化した後のpstファイルを開くVBSとOutlookのVBAを紹介します。現在、Outlook2003が対象です。Outlook2013でも動きますので、2003以降のバージョンでは動作すると思います。
[流れ]

対象のpstファイルをVBSでTempフォルダにReadPst.txtというファイル名で書き込む
Outlookが起動しているか確認し、起動していないなら起動させる
Outlookは起動時に、指定した件名の予定が開かれた時に、Sub Procedureを実行するようにイベントハンドラを設定する
指定した件名を持つ予定を表示させる -> Outlookのイベント発生
OutlookはTempフォルダのReadPst.txtの内容を読み込み、対象pstを選択するこの時、新しいOutlookのWindowが開きますが、自動で閉じます
OutlookはAddStoreでpstファイルを追加しますパスワードがある場合、ファイル名を選択するダイアログにファイル名を入力して止まります
パスワードがある場合、リターンを押してパスワードを入力します

ThisOutlookSessionに下記のVBAを貼り付けます。

Option Explicit

Dim WithEvents Inspect As Inspectors
Dim WithEvents openCalendarItem As AppointmentItem

Private Sub Application_Startup()
    'イベントハンドラ用の処理
    Set Inspect = Outlook.Inspectors
End Sub

Private Sub Inspect_NewInspector(ByVal Inspector As Inspector)
    '予定表のみ対応とする
    On Error Resume Next
        Set openCalendarItem = Inspector.CurrentItem
    On Error GoTo 0
End Sub

Private Sub openCalendarItem_Open(Cancel As Boolean)
    '「This is for open pst.」という件名の予定が必要です
    '件名は好きな件名に変更しても可能です
    If openCalendarItem.Subject = "This is for open pst." Then
        Call Pst.Read
        Cancel = True
        Application.ActiveExplorer.Close
        Application.Explorers.Item(1).Activate
    End If
End Sub

次に、標準モジュールPstに下記のVBAを追加します。

Option Explicit

Public Sub Read()
    Dim fn As Single
    Dim FileName As String
    
    If Dir$(LstFileName) <> "" Then
        fn = FreeFile
        Open LstFileName For Input As #fn
            Line Input #fn, FileName
        Close #fn
        Call Add(FileName)
    End If
End Sub

Private Sub Add(ByVal pstFileName As String)
    Dim olNs As Outlook.NameSpace
    Set olNs = Application.GetNamespace("MAPI")
    On Error Resume Next
        'パスワードがあるとAddStore出来ない
        olNs.AddStore pstFileName
        If Err <> 0 Then
            Call OpenDialogShow(pstFileName)
        End If
    On Error GoTo 0
    'Kill LstFileName
End Sub

Private Sub OpenDialogShow(ByVal pstFileName As String)
    Dim i As Integer
    'ここに自動でパスワードを入力させ、自動で開くプログラムがあります
    '自分の環境ではOutlook2003はOKですが、2013で不具合が出ていますので
    '非公開とします

    SendKeys "%FOF" & ChangeString(pstFileName)

End Sub

Private Function LstFileName() As String
    LstFileName = Environ("temp") & "\ReadPst.txt"
End Function

Public Function ChangeString(ByVal szValue As String) As String
    ChangeString = szValue
    ChangeString = Replace(ChangeString, "+", "{+}")
    ChangeString = Replace(ChangeString, "^", "{^}")
    ChangeString = Replace(ChangeString, "%", "{%}")
    ChangeString = Replace(ChangeString, "~", "{~}")
    ChangeString = Replace(ChangeString, "(", "{(}")
    ChangeString = Replace(ChangeString, ")", "{)}")
End Function

続いて、VBSとバッチファイルです。
OpenPst.VBS

Option Explicit

' VT484用変数 --- 自分のタブレットです
Const OutlookVersion = 2013

Call Main

Sub Main()
	'コマンドライン取得
	Dim aryArg
	Dim FileName
	Dim i
	Set aryArg = WScript.Arguments
	'ファイル名に空白が入る場合がある
	FileName = aryArg(0)
	For i = 1 To aryArg.Count - 1
		FileName = FileName & " " & aryArg(i)
	Next
	
	If FileName = "" Then
	Else
		Dim adoObj
		Set adoObj = CreateObject("ADODB.Stream")
		With adoObj
			.Charset = "Shift_JIS"
			.Open
			.WriteText FileName
			'1:ファイル有り時上書きしない、2:上書きする
			.SaveToFile TempFolderPath() & "\ReadPst.txt", 2
			.Close
		End With
		Set adoObj = Nothing

		'Outlookを起動確認
		Call OutlookRunCheck
		
		Dim objOutlook
		Dim objNameSpace
		Dim objFolder
		Dim objItem

		Set objOutlook = CreateObject("Outlook.Application")
		Set objNameSpace = objOutlook.GetNamespace("MAPI")
		Set objFolder = objNameSpace.GetDefaultFolder(9)

		On Error Resume Next
			objFolder.Display
			If Err > 0 Then
				Msgbox "Outlook.exeが重複起動しているかもしれません"
			End If
		On Error GoTo 0
	
		Set objItem = objFolder.Items.Find("[Subject] = 'This is for open pst.'")
		objItem.Display
	End If
End Sub

Function OutlookRunCheck()
	'WMIにて使用する各種オブジェクトを定義・生成する。
	Dim oClassSet
	Dim oClass
	Dim oLocator
	Dim oService
	Dim sMesStr

	'ローカルコンピュータに接続する。
	Set oLocator = CreateObject("WbemScripting.SWbemLocator")
	Set oService = oLocator.ConnectServer

	'クエリー条件をWQLにて指定する。
	Set oClassSet = oService.ExecQuery("Select * From Win32_Process Where Description=""outlook.exe""")
	If oClassSet.Count = 0 Then
		'Outlookを起動する
		Dim obj
		Set obj = CreateObject("WScript.Shell")
		obj.Run OutlookExe
		Set obj = Nothing
	End If

	 '使用した各種オブジェクトを後片付けする。
	Set oClassSet = Nothing
	Set oClass = Nothing
	Set oService = Nothing
	Set oLocator = Nothing
End Function

Function TempFolderPath()
	Dim objWshShell

	Set objWshShell = CreateObject("WScript.Shell")
	If Err.Number = 0 Then
		TempFolderPath = objWshShell.ExpandEnvironmentStrings("%TEMP%")
	End If
	Set objWshShell = Nothing
End Function

Function PcName()
	Dim objWshShell

	Set objWshShell = CreateObject("WScript.Shell")
	If Err.Number = 0 Then
		PcName = objWshShell.ExpandEnvironmentStrings("%PCNAME%")
	End If
	Set objWshShell = Nothing
End Function

Function OutlookExe()
	'自分の環境では、仕事PC 自宅PC タブレットがあり、環境変数PCNAMEでPCを認識できるようにしています
	'対象PCのOutlook.exeの場所を指定してください 表記はOutlook2003用です

	OutlookExe = """C:\Program Files (x86)\Microsoft Office\OFFICE11\OUTLOOK.EXE"""

	'以下は複数のPCを使用している方の為のVBAです
	'If PcName = "PC1" Or PcName = "PC2" Then
	'	OutlookExe = """C:\Program Files (x86)\Microsoft Office\OFFICE11\OUTLOOK.EXE"""
	'ElseIf PcName = "Tablet" Then
	'	If OutlookVersion = 2003 Then
	'		OutlookExe = """C:\Program Files\Microsoft Office\OFFICE11\OUTLOOK.EXE"""
	'	ElseIf OutlookVersion = 2013 Then
	'		OutlookExe = """C:\Program Files\Microsoft Office 15\root\office15\OUTLOOK.EXE"""
	'	End If
	'End If
End Function

次にバッチファイルです。
OpenPst.bat

C:\(OpenPst.vbsのフォルダ)\OpenPst.vbs %1 %2 %3 %4 %5 %6 %7 %8 %9

pstファイルをOpenPst.batに関連付けて、Explorerでpstファイルを起動すると、Outlookに読み込めます。