VBScript Outlook 2013 Later の履歴（ジャーナル JournalImtem）にファイルを登録する

'Made by QiiQ Form QITA
'For Language Japanese
'For Especially Outlook 2013 Later 
Const StoreName = "" ’<!!Input Your Mail Address
Const olFolderJounal = 11
Const olJournalItem = 4

Const olSave = 0
Const olDiscard = 1
Const JpnOlJounrnalTypeNameOfEmail = "電子メールメッセージ"
Const JpnOlJounrnalTypeNameOfDocument = "ドキュメント"
Dim oApp: Set oApp = CreateObject("Outlook.Application")
Dim NS: Set NS = oApp.GetNamespace("MAPI")
Dim oJfol
Dim objArgs, I, strFile, strFolder
Dim objFile, objFolder, objPath, strScr
Dim strBase, strExt, strParent, strPath, strZip, RetVal
Dim objShell: Set objShell = CreateObject("WScript.Shell")
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim myJItm 'As Outlook.JournalItem
Dim myMItm 'As Outlook.MailItem
Dim blnExist 'As Boolean
Dim oRoot, olStore
Set olStore = oApp.Session.Stores.Item(StoreName)
Set oRoot = oApp.Session.Stores.Item(StoreName).GetRootFolder
Set oJfol = oRoot.Folders.Item(14)
Set objArgs = Wscript.Arguments
'For I = 0 To objArgs.Count - 1
I=0
Set objFile = FSO.GetFile(CStr(objArgs(I)))
strParent = FSO.GetParentFolderName(objFile)
Set objPath = FSO.GetFolder(strParent)
strBase = FSO.GetBaseName(CStr(objArgs(I)))
strExt = FSO.GetExtensionName(CStr(objArgs(I)))
strPath = strParent & "\"
blnExist = False
For Each jitm In oJfol.Items
If jitm.Subject = objFile.Path Then blnExist = True: Wscript.Quit
Next
If blnExist = False Then
msgbox objfile.path
Set myJItm = oApp.CreateItem(4)
'Set myJItm = oJfol.Items.Add
With myJItm
.Display
.Subject = "<" & "file:///" & replace(objFile.Path,"\","/",1,-1) & ">"
.Body = "CurrentFilePath:= " & strParent & vbCrLf & _
"FolderLink:= " & " <" & "file:///" & replace(strParent,"\","/",1,-1) & "> " & vbCrLf & _
"FileName:= " & objFile.Name & vbCrLf & _
"CreationTime:= " & Cdate(FSO.GetFile(CStr(objArgs(I))).DateCreated) & vbCrLf & _
"LastWriteTime:= " & Cdate(FSO.GetFile(CStr(objArgs(I))).DateLastModified)
If Left(LCase(strExt), 3) = "doc" Or Left(LCase(strExt), 3) = "htm" Then .Type = "Microsoft Word"

If LCase(strExt) = "csv" Or Left(Lcase(strExt),3) = "xls" = True Then .Type = "Microsoft Excel"

If VbLike(LCase(strExt), "ppt*") = True Then .Type = "Microsoft Powerpoint"

If LCase(strExt) = "mdb" Or LCase(strExt) = "accdb" Then .Type = "Microsoft Office Access"
If LCase(strExt) = "pdf" Then .Type = "Adobe Acrobat"
If LCase(strExt) = "msg" Then
Set myMItm= myJtm
.Type = JpnOlJounrnalTypeNameOfEmail
.Body = myJItm.Body & VbCrLf & Left(myMItm.Body, 1000)
.ContactNames = myMItm.SenderName
End If
If LCase(strExt) = "vbs" Then .Type = "VBScript"
If LCase(strExt) = "txt" Or LCase(strExt) = "log" Then .Type = "Text"
If LCase(strExt) = "pub" Then .Type = JpnOlJounrnalTypeNameOfDocument
.StartTimer
.Categories = .Categories
.Save
.Close 1
Wscript.Sleep 1000
End With
Else
End If
' Next
Set objShell = Nothing
Set FSO = Nothing
Set NS = Nothing
Set oApp = Nothing
Wscript.Quit

Function VbLike(sTest, sPattern)
Dim objRE, sAdd1, sAdd_1, xAdd, UAdd, AAdd
Set objRE = CreateObject("VBScript.RegExp")
'escape character add
'spattern = Replace(sPattern, "\", "\\", 1, -1)
'spattern = Replace(sPattern, "*", "\*", 1, -1) 'wildcard escape
'spattern = Replace(sPattern, "?", "\?", 1, -1) 'wildcard escape
'sPattern = Replace(sPattern, ".", "\.", 1, -1) 'wildcard escape
sPattern = Replace(sPattern, "+", "\+", 1, -1)
sPattern = Replace(sPattern, "|", "\|", 1, -1)
sPattern = Replace(sPattern, ")", "\)", 1, -1)
sPattern = Replace(sPattern, "(", "\(", 1, -1)
sPattern = Replace(sPattern, "[", "\[", 1, -1)
sPattern = Replace(sPattern, "]", "\]", 1, -1)
sPattern = Replace(sPattern, Chr(13), "\r", 1, -1)
sPattern = Replace(sPattern, Chr(10), "\n", 1, -1)
sPattern = Replace(sPattern, vbTab, "\t", 1, -1)
sPattern = Replace(sPattern, " ", "\s", 1, -1)
sPattern = Replace(sPattern, "　", "\s", 1, -1)
'Add character
sAdd1 = "\w" '[a-zA-Z_0-9]
sAdd_1 = "\W" '[^a-zA-Z_0-9]
xAdd = "\50" '( 50 is 8 digit ASCII
UAdd = "\u00A3" '( 00A3 is 16 digit UNICODE
AAdd = "[A-z]"
objRE.Pattern = "^.*" & sPattern & ".*$"
If objRE.test(sTest) = True Then
VbLike = True
Else
VbLike = False
End If
Set objRE = Nothing
End Function

履歴機能は生きている

Outlook 2013 で死んだように扱われていますが、自動的に登録しなくなっただけで生きています。
そこで、VB Scriptを利用してファイルを登録します。
前回の仕事の元はこちらになります。

ファイルには制限があります

Office の主要なファイルとPDFです。