既定の予定表のみを表示して 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

受信トレイで分類項目が設定されていないメールを未読にするスクリプト

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


初めまして。
こういったお願いをすることはとても恐縮なのですが、お時間があれば教えてください。

Windows7 Outlook2007 Exchange環境です。

指定された一つのフォルダ内にあるすべてのメールを対象とし、「分類項目」が空欄である場合、
そのメールを未読にする、という作業をするマクロを作りたいのですが、どんな内容にすればよいでしょうか?
さらに1時間おきに自動で行うということもしたいです。

対象フォルダは自分の受信トレイです。

どうぞよろしくお願いいたします。


1 時間おきに自動で実行するような処理の場合、マクロではなくスクリプトとして実装し、Windows のタスク スケジューラーで起動するようにします。
例えば、以下のようなコードを拡張子 .vbs として保存し、Windows のタスク スケジューラーで呼び出してください。

' ここをトリプルクリックでスクリプト全体を選択できます。
Const olFolderInbox = 6
Dim olkApp
Dim fldInbox
Dim objItem
'
Set olkApp = CreateObject("Outlook.Application")
Set fldInbox = olkApp.Session.GetDefaultFolder(olFolderInbox)
For Each objItem In fldInbox.Items
    If objItem.Categories = "" And objItem.Unread = False Then
        objItem.Unread = True
        objItem.Save
    End If
Next

Outlook の個人用フォルダのサイズをテキスト ファイルに出力するスクリプト

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


いつもお世話になっております。

こちらの記事で紹介している、「Outlook の個人用フォルダのサイズをチェックするスクリプト 」を利用しようと考えているのですが、Outlookのバージョンが混在しており、しきい値の設定に難儀しております。

   取り敢えず、ユーザー展開する前に手前でPSTの利用状況を把握しておきたく、「MSGBOX」に表示される内容をファイル(TXTやCSV)に出力する事は可能でしょうか?(※MSGBOXの表示は不要です)

当方、VBA等の知識に乏しく、勝手なお願いでは御座いますが、
ご協力頂けると幸甚です。宜しくお願い致します。


PST のファイル パスとサイズをテキスト ファイルに保存するスクリプトを作りました。
Outlook のバージョンが混在しているという状況から、社内の複数の PC で処理するというようなことを想定し、保存ファイル名に %USERNAME% のような環境変数を使用できるようにしてみました。
スクリプトは以下の通りです。

' ここをトリプルクリックでスクリプト全体を選択できます。
Option Explicit
Const REPORT_FILE = "\\server\share\pstreport-%USERNAME%.txt"
Const HKEY_LOCAL_MACHINE = &H80000002
Const CLIENTS_MAIL_OUTLOOK_VER = "SOFTWARE\Clients\Mail\Microsoft Outlook\Envelope\CurVer"
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 objWSH
Dim strCurVer
Dim strKey
Dim strOutlookKey
Dim strProfilesKey
Dim strDefaultProfile
Dim strProfileKey
Dim strServicesKey
Dim abyStoreUIDs
Dim abyAddrBookUIDs
Dim iCount
Dim i,j
Dim strServiceKey
Dim strPSTPath
Dim abyData
Dim objPSTFile
Dim stmReport
'
' レジストリにアクセスするための WMI の StdRegProv オブジェクトを取得します。
Set objReg = GetObject( "winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
' ファイル情報にアクセスするための FileSystemObject オブジェクトを取得します。
Set objFSO = CreateObject("Scripting.FileSystemObject")
' 環境変数を展開するための WshShell オブジェクトを取得します。
Set objWSH = CreateObject("WScript.Shell")
' Outlook のバージョンの確認を行います。
objReg.GetStringValue HKEY_LOCAL_MACHINE, CLIENTS_MAIL_OUTLOOK_VER, "", strCurVer
If Instr(strCurVer, "12") > 0 Or Instr(strCurVer,"14") > 0 Then
    strProfilesKey = MAPI_PROFILE_KEY
    ' 既定の MAPI プロファイルの名前を取得します。
    objReg.GetStringValue HKEY_CURRENT_USER, strProfilesKey, "DefaultProfile", strDefaultProfile
ElseIf Instr(strCurVer, "15") > 0 Or Instr(strCurVer, "16") > 0 Then
    strOutlookKey = "Software\Microsoft\Office\" & Right(strCurVer,2) & ".0\Outlook"
    ' 既定の MAPI プロファイルの名前を取得します。
    objReg.GetStringValue HKEY_CURRENT_USER, strOutlookKey, "DefaultProfile", strDefaultProfile
    strProfilesKey = strOutlookKey & "\Profiles"
End If
' プロファイルの名前からキーの文字列を生成します。
strProfileKey = strProfilesKey & "\" & strDefaultProfile & "\"
strServicesKey = strProfileKey & MAPI_SERVICES_KEY
' メッセージ ストア プロバイダの ID の一覧を取得します。
objReg.GetBinaryValue HKEY_CURRENT_USER, strServicesKey, "01023d00", abyStoreUIDs
' PST のファイルサイズを出力するログ ファイルを作成します。
Set stmReport = objFSO.CreateTextFile(objWSH.ExpandEnvironmentStrings(REPORT_FILE))
' メッセージ ストア プロバイダの 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
        ' PST ファイルのサイズをログ ファイルに出力します。
        If objFSO.FileExists(strPSTPath) Then
            Set objPSTFile = objFSO.GetFile(strPSTPath)
            stmReport.WriteLine objPSTFile.Path & ": " & objPSTFile.Size & " バイト"
        End If
    End If
Next
stmReport.Close
'
'
'    バイナリ データを 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