他人の予定表を直接開くスクリプト

コメントにて以下のご要望をいただきました。


いつも参照させていただいております。

Outlookの起動オプションを使用して、他人の予定表を直接開く方法を教えてください。

Outlook.exe /select outlook:calendar では自分の予定を開くことはできるのですが、他人の予定表を開く方法がわかりません。

よろしくお願いいたします。


残念ながら、Outlook の起動オプションには他人の予定表を直接開くというものはありません。
おそらくはデスクトップなどにバッチファイルを置いて、それをダブルクリックして他人の予定表を開くというようなものを想定されていると思うのですが、スクリプトにより実現することができます。
下記のようなスクリプトを、例えば OpenOtherFolder.vbs というような名前で保存し、デスクトップにはそのスクリプトへのショートカットを作成します。
その際に、スクリプトのファイル名の後にスペースを空けて開きたいユーザーのメールアドレスを指定します。
例えば、c:\users\admin\desktop\OpenOtherFolder.vbs にスクリプトがあり、test@example.com というアドレスのユーザーの予定表を開きたい場合、ショートカット のリンク先として c:\users\admin\desktop\OpenOtherFolder.vbs test@example.com と指定します。
なお、このスクリプトで開く予定表には参照者以上の権限が必要になります。

' ここをトリプルクリックでスクリプト全体を選択できます。

Const olFolderCalendar = 9
If WScript.Arguments.Count > 0 Then
     Dim strAddress 'As String
     Dim olkApp 'As Outlook.Application
     Dim nsSess 'As Namespace
     Dim recOther 'As Recipient
     Dim fldOther 'As Folder
     ' スクリプトの引数からアドレスを取得
     strAddress = WScript.Arguments.Item(0)
     ' Outlook.Application オブジェクトを取得
     Set olkApp = CreateObject("Outlook.Application")
     Set nsSess = olkApp.Session
     ' アドレスから Recipient オブジェクトを作成
     Set recOther = nsSess.CreateRecipient(strAddress)
     recOther.Resolve
     ' 他のユーザーの予定表を取得し、開く
     Set fldOther = nsSess.GetSharedDefaultFolder(recOther, olFolderCalendar)
     fldOther.Display
End If

広告

連絡先フォルダーのユーザーの予定表を一括で追加するスクリプト

コメントにて以下のご要望をいただきました。


【使用環境】
OSバージョン:Windows7 SP1 & Windows10
  Outlookバージョン:Outlook2013
サーバ:Exchange Online

はじめまして。
いつも参考になる多数の記事ありがとうございます。

現在定期的に当サイト記事「連絡先をエクスポート・インポートするスクリプト」を使用し、社内アドレス帳を一括インポートしています。
  又、そのアドレス帳から予定表グループ機能を使用し、予定表の共有を行っていますが、
  社内アドレス帳の更新した際に、予定表グループ接続が無効になってしまいます。(レ点をつけれない)
  原因は、社内アドレスの中身を一度一括削除した上で、一括インポートしているからです。
  解決策として、「新しい予定表グループで作成」で既定のアドレス帳に予定表グループを作成するスクリプトを作成頂けませんか。


スクリプトで他のユーザーの予定表を追加するには、その予定表に参照者以上の権限が必要となります。
連絡先にあるユーザーの予定表に参照者以上の権限がある前提でスクリプトを作成しました。

なお、連絡先に連絡先グループが存在した場合、そのグループの名前で予定表グループを作成し、メンバーの予定表をそのグループに追加する処理も実装しています。

' ここをトリプルクリックでスクリプト全体を選択できます。

' 予定表グループの名前設定
Const GROUP_NAME = "連絡先"
' Outlook の設定値
Const olFolderContacts = 10
Const olModuleCalendar = 1
Const olFolderCalendar = 9
'
Dim olkApp 'As Application
Dim nsSession 'As NameSpace
Dim navGroup 'As NavigationGroup
Dim fldContacts 'As Folder
Dim objItem 'As Object
' Outlook の呼び出し
Set olkApp = CreateObject("Outlook.Application")
Set nsSession = olkApp.Session
' 既定の連絡先フォルダーを取得
Set fldContacts = nsSession.GetDefaultFolder(olFolderContacts)
' 予定表グループを作成
Set navGroup = GetNavigationGroup(GROUP_NAME)
' 連絡先フォルダーのすべてのアイテムについて処理
For Each objItem In fldContacts.Items
     If TypeName(objItem) = "ContactItem" Then
         ' 連絡先アイテムならアイテムのメールアドレスを指定して追加
         AddRecipientToNavigation objItem.Email1Address, navGroup
     ElseIf TypeName(objItem) = "DistListItem" Then
         ' 連絡先グループ アイテムならメンバーを展開して追加
         AddDistListToNavigation objItem
     End If
Next
' 連絡先グループのメンバーを展開して追加するルーチン
Private Sub AddDistListToNavigation(dlItem)
     On Error Resume Next
     Dim navGroup 'As NavigationGroup
     Dim i 'As Integer
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     ' 連絡先グループの名前で予定表グループを作成
     Set navGroup = GetNavigationGroup(dlItem.DLName)
     ' メンバーを展開して予定表グループに追加
     For i = 1 To dlItem.MemberCount
         Set recOther = dlItem.GetMember(i)
         AddRecipientToNavigation recOther.Address, navGroup
     Next
End Sub
' メールアドレスにより予定表グループに追加するルーチン
Private Sub AddRecipientToNavigation(strAddress, navGroup)
     On Error Resume Next
     Dim recOther 'As Recipient
     Dim fldCalendar 'As Folder
     ' メールアドレスから受信者オブジェクトを生成
     Set recOther = nsSession.CreateRecipient(strAddress)
     ' 名前解決を実行
     recOther.Resolve
     If recOther.Resolved Then
         ' 自分自身は予定表グループに追加しない
         ' Exchange 組織外のアドレスも追加しない
         If recOther.Address = nsSession.CurrentUser.Address _
             Or recOther.AddressEntry.Type <> "EX" Then
             Exit Sub
         End If
         ' 他のユーザーの予定表を取得
         Set fldCalendar = nsSession.GetSharedDefaultFolder(recOther, olFolderCalendar)
         If Not fldCalendar Is Nothing Then
             ' 予定表が取得できたら予定表グループに追加
             navGroup.NavigationFolders.Add fldCalendar
         End If
     End If
End Sub
' 予定表グループを作成・取得するルーチン
Private Function GetNavigationGroup(strGroupName)
     On Error Resume Next
     Dim actExp 'As Explorer
     Dim navModule 'As CalendarModule
     Dim navGroups 'As NavigationGroups
     Dim navGroupT 'As NavigationGroup
     Dim i 'As Integer
     Dim j 'As Integer
     ' 予定表グループを追加するための Explorer オブジェクトを取得
     If olkApp.ActiveExplorer Is Nothing Then
         Dim fldCalendar 'As Folder
         Set fldCalendar = nsSession.GetDefaultFolder(olFolderCalendar)
         Set actExp = fldCalendar.GetExplorer()
     Else
         Set actExp = olkApp.ActiveExplorer
     End If
     ' 予定表モジュールを取得
     Set navModule = actExp.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
     ' 予定表グループのリストを取得
     Set navGroups = navModule.NavigationGroups
     For i = 1 To navGroups.Count
         Set navGroupT = navGroups.Item(i)
         ' 追加しようとしているグループが既に存在していた場合
         If navGroupT.Name = strGroupName Then
             ' 既存の予定表はすべて削除
             With navGroupT.NavigationFolders
                 For j = .Count To 1 Step -1
                     Dim navFolder 'As NavigationFolder
                     Set navFolder = .Item(j)
                     .Remove navFolder
                 Next
             End With
             ' 既存の予定表グループを返す
             Set GetNavigationGroup = navGroupT
             Exit Function
         End If
     Next
     ' 新規に予定表グループを作成して返す
     Set GetNavigationGroup = navGroups.Create(strGroupName)
End Function

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

既定の予定表のみを表示して Outlook を起動するスクリプト

コメントにて以下のご要望をいただきました。


こんにちは。
いつも参考にささていただきありがとうございます。

質問よろしくお願いします。

私は社内で365を利用していて、
  沢山のカレンダーを管理しているのですが、
デスクトップにoutlook のカレンダーをワンクリックで開けるように以下のようなショートカットを作ってい利用しています。

“C:\Program Files\Microsoft Office 15\root\office15\outlook.exe” /select outlook:calenders

ただ上記の方法だと、最終利用時に、選んだカレンダーが
  そのまま次回起動時に表示されてしまいます。

毎回リセットされた状態でカレンダーを開く方法などはありますでしょうか?

何卒よろしくお願いします!


Outlook をスクリプトで起動し、既定の予定表を表示することで、ご要望の動作は満たせると思います。
スクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。

Const olFolderCalendar = 9
Dim olkApp
Dim fldCal
Set olkApp = CreateObject("Outlook.Application")
Set fldCal = olkApp.Session.GetDefaultFolder(olFolderCalendar)
fldCal.Display

リアルタイムプレビュー表示と添付ファイルプレビューの設定をファイルにエクスポートするスクリプト

コメントにて以下のご要望をいただきました。


[ファイル>オプション]にあります[Outlookのオプション]の情報ですが、こちらを別ファイル(テキストやCSV)で見ることは可能でしょうか。

利用想定として、Outlook基本設定の[リアルタイムプレビュー表示機能を有効にする]の項目をAさんはON / BさんはOFF、セキュリティセンターの[添付ファイルのプレビューをオフにする]の項目をAさんはOFF / BさんはONとなっていることを別ファイルで見たいと考えております。

Outlook:2010
  Windows:7 Enterprise SP1

よろしくお願いいたします。


ご要望の 2 つの設定はそれぞれ以下のレジストリに格納されています。

[リアルタイム プレビュー表示機能を有効にする]

キー: HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings
名前: EnableLivePreview

[添付ファイルのプレビューをオフにする]

キー: HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences
名前: DisableAttachmentPreviewing

これらのレジストリの値をファイルに保存するようなスクリプトを作成すれば、ご要望は満たせるでしょう。
スクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。

Option Explicit
On Error Resume Next
Const EXPORT_FILE="c:\temp\test.txt"
' Outlook 2010
Const REG_ENABLELIVEPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings\EnableLivePreview"
Const REG_DISABLEATTACHMENTPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences\DisableAttachmentPreviewing"
' Outlook 2013
'Const REG_ENABLELIVEPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings\EnableLivePreview"
'Const REG_DISABLEATTACHMENTPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences\DisableAttachmentPreviewing"
' Outlook 2016
'Const REG_ENABLELIVEPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Common\MailSettings\EnableLivePreview"
'Const REG_DISABLEATTACHMENTPREVIEW = "HKCU\SOFTWARE\Microsoft\Office\14.0\Outlook\Preferences\DisableAttachmentPreviewing"
'
Dim WSHShell
Dim iEnableLivePrev
Dim iDisableAttPrev
'
Set WSHShell = CreateObject("WScript.Shell")
'  [リアルタイム プレビュー表示機能を有効にする] の設定取得
iEnableLivePrev = WSHShell.RegRead(REG_ENABLELIVEPREVIEW)
If Err.Number<> 0 Then
     iEnableLivePrev = 1
     Err.Clear
End If
'  [添付ファイルのプレビューをオフにする] の設定取得
iDisableAttPrev = WSHShell.RegRead(REG_DISABLEATTACHMENTPREVIEW)
If Err.Number<> 0 Then
     iDisableAttPrev = 0
End If
'
Dim objFSO
Dim stmLog
Dim astrOnOff : astrOnOff = Array("OFF", "ON")
'
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set stmLog = objFSO.CreateTextFile(EXPORT_FILE)
stmLog.WriteLine "リアルタイムプレビュー表示機能を有効にする = " & astrOnOff(iEnableLivePrev)
stmLog.WriteLine "添付ファイルのプレビューをオフにする = " & astrOnOff(iDisableAttPrev)
stmLog.Close

ビューをファイルにエクスポート・インポートするスクリプト

コメントにて以下のご要望をいただきました。


いつも大変お世話になっております。
可能であればマクロ作成をご検討頂きたいのです。
OS:Windows 7 Professional(64bit)
Outlook2013
【ビューの定義をエクスポート(インポート)するマクロ】
【印刷スタイルの定義をエクスポート(インポート)するマクロ】
ビューの定義や印刷スタイルの定義を社内で統一して利用したい。
私が現在設定しているビューを
PC内(Outlook2013)でコピーする事は出来ますが
別PC(Outlook2013)へビューや印刷スタイルの定義を
エクスポート(インポート)する事は出来ないでしょうか?
標準の機能として、これらの定義のエクスポート(インポート)はないようなので
マクロで作成可能であればお願いしたい次第です。
ビューについては
【現在のビューの設定をサブフォルダにコピーするマクロ】や
2014年2月22日 コメントでの要望を受けての
全てのストアのフォルダー階層にアクセス可能な
【現在のビューをすべてのフォルダーに適用するマクロ】
上記の2つのマクロをどうにかすれば可能なのでしょうか?
ご検討の程、よろしくお願い申し上げます。


まず、印刷スタイルの定義ですが、こちらは以下のファイルに保存されています。(ファイルに拡張子はありません)

    c:\users\ユーザー名\AppData\Roaming\Microsoft\Outlook\OutPrnt

このファイルを単にコピーすれば、他の環境に印刷スタイルの定義をコピーすることができます。

次に、ビューの設定ですが、こちらはご指摘のマクロでやっているように、View オブジェクトの XML プロパティの文字列をエクスポート・インポートすれば、他の環境にビューの定義をコピーすることができます。
ただし、自動書式についてはコピーすることはできません。

現在表示しているフォルダーの現在のビュー設定をファイルにエクスポートするスクリプトは以下のようになります。
複数の PC で実行することを想定したため、スクリプトとして実装しました。
この内容をメモ帳などのテキストエディタに貼り付け、拡張子を .vbs として保存し、ダブルクリックして実行してください。

' ここをトリプルクリックでスクリプト全体を選択できます。
Const VIEW_XML = "C:\temp\current.view" ' エクスポート先のファイル名
Dim olkApp
Dim objFSO
Dim curView
Dim stmXml
Dim strXml
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set curView = olkApp.ActiveExplorer.CurrentFolder.CurrentView
strXml = curView.XML
Set stmXml = objFSO.CreateTextFile(VIEW_XML)
' 1 行目はビューの名前と種類
stmXml.WriteLine curView.Name & vbTab & curView.ViewType
stmXml.Write strXml
stmXml.Close

また、上記のスクリプトでエクスポートしたビュー設定を、現在表示しているフォルダーにインポートするスクリプトは以下のようになります。

' ここをトリプルクリックでスクリプト全体を選択できます。
On Error Resume Next
Const VIEW_XML = "C:\temp\current.view" ' インポート先のファイル名
Dim olkApp
Dim objFSO
Dim stmXml
Dim strLine
Dim arrLine
Dim colViews
Dim curView
Set olkApp = CreateObject("Outlook.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set stmXml = objFSO.OpenTextFile(VIEW_XML, 1)
' 1 行目はビューの名前と種類
strLine = stmXml.ReadLine
arrLine = Split(strLine, vbTab)
Set colViews = olkApp.ActiveExplorer.CurrentFolder.Views
Set curView = colViews.Add(arrLine(0), arrLine(1), 0)
If Err.Number = 5 Then ' 同名のビューが存在した場合のエラー処理
    For Each curView In colViews
        ' 同名のビューを検索
        If curView.Name = arrLine(0) Then
            Exit For
        End If
    Next
End If
curView.XML = stmXml.ReadAll
curView.Save
curView.Apply
stmXml.Close

Windows 転送ツールで転送後に Outlook 2016 で連絡先がアドレス帳に表示されない現象について

以前、Windows 転送ツールで転送後に Outlook で連絡先がアドレス帳に表示されない現象について回避するスクリプトを作成し、Outlook 2013 に対応するスクリプトも作成しました。

今回、Outlook 2016 に対応するものもご要望いただいたため、2016 用も作成しました。

スクリプトは以下の通りです。
この内容をメモ帳などで拡張子 vbs として保存し、そのファイルをダブルクリックして実行すると、既定の MAPI プロファイルの Outlook アドレス帳の設定を初期化し、連絡先フォルダが追加できるようになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Option Explicit
'
Const HKEY_CURRENT_USER = &H80000001
Const OUTLOOK_KEY = "Software\Microsoft\Office\16.0\Outlook"
Const MAPI_PROFILE_KEY = "Software\Microsoft\Office\16.0\Outlook\Profiles"
Const MAPI_SERVICES_KEY = "9207f3e0a3b11019908b08002b2a56c2"
Const PR_AB_PROVIDERS = "01023d01"
'
Dim stdRegProv
Dim strDefaultProfile
Dim strProfileKey
Dim strServicesKey
Dim arrServiceUIDs
Dim iCount
Dim i,j
Dim strServiceKey
Dim arrData
'
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_AB_PROVIDERS, arrServiceUIDs
iCount = (UBound(arrServiceUIDs)+1)/16
For i=0 To iCount-1
strServiceKey = ""
For j=0 To 15
strServiceKey = strServiceKey & Right("0" & Hex(arrServiceUIDs(i*16+j)), 2)
Next
If stdRegProv.GetBinaryValue(HKEY_CURRENT_USER, strProfileKey & strServiceKey, "11026626", arrData ) = 0 Then
Dim aDelProps
aDelProps = Array( "101e6622", "101e6623", "101e6624", "101f6627", "101f6628", "101f6629", "11026620", "11026626" )
For j=0 To UBound(aDelProps)
stdRegProv.DeleteValue HKEY_CURRENT_USER, strProfileKey & strServiceKey, aDelProps(j)
Next
Exit For
End If
Next
'
Set stdRegProv = Nothing

テキスト ファイルと RTF ファイルからメモ アイテムを生成するスクリプト

コメントにて以下のご要望をいただきました。


お世話になります
rtf形式or単なるテキスト形式で記録されているファイルをOUTLOOKのメモ(note)に登録したいのですがどうすればよいでしょうか。
できることなら、rtf/txtファイルをアイコンにドラッグ&ドロップする形で登録したいです。
なお、MS Office (WORD,OUTLOOK)は2013です

よろしくご教示ください


ファイルのドラッグアンドドロップで何らかの処理をさせたい場合、マクロではなく VBScript を使います。
VBScript のファイル (.vbs) に別のファイルをドラッグアンドドロップすると、そのファイル名がスクリプトの引数として引き渡されるので、スクリプト内で処理ができるのです。
ご要望の動作を行うスクリプトは以下のようになります。
この内容をメモ帳などにコピーし、拡張子を .vbs として保存すると、.vbs ファイルへのドラッグアンドドロップでメモ アイテムが生成されます。

' ここをトリプルクリックでマクロ全体を選択できます。
Option Explicit
Dim strFile
Dim strExt
If WScript.Arguments.Count > 0 Then
    ' スクリプトにドラッグアンドドロップされたファイルの名前を取得
    strFile = WScript.Arguments.Item(0)
    strExt = LCase(Right(strFile,4))
    If strExt = ".txt" Then
        CreateFromTxt strFile
    ElseIf strExt = ".rtf" Then
        CreateFromRtf strFile
    End If
End If
' テキスト ファイルの取り込み
Sub CreateFromTxt(strFile)
    Const ForReading = 1
    Dim objFSO
    Dim stmFile
    Dim strBody
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set stmFile = objFSO.OpenTextFile(strFile, ForReading)
    CreateMemo strFile, stmFile.ReadAll
    stmFile.Close
End Sub
' RTF ファイルの取り込み
Sub CreateFromRtf(strFile)
    Const wdDoNotSaveChanges = 0
    Const wdOriginalDocumentFormat = 1
    Dim appWord
    Dim docRtf
    Set appWord = CreateObject("Word.Application")
    appWord.Visible = True
    Set docRtf = appWord.Documents.Open(strFile)
    CreateMemo strFile, docRtf.Content.Text
    docRtf.Close wdDoNotSaveChanges, wdOriginalDocumentFormat, false
    appWord.Quit
End Sub
' メモ アイテムの作成
Sub CreateMemo(strFile, strBody)
    Const olNoteItem = 5
    Dim appOlk
    Dim objMemo
    Set appOlk = CreateObject("Outlook.Application")
    Set objMemo = appOlk.CreateItem(olNoteItem)
    objMemo.Body = strFile & vbCrLf & strBody
    objMemo.Display
    Set appOlk = Nothing
End Sub