作者loser1 (基辅罗斯进军乌拉山以西)
看板Windows
标题Re: [问题] Win11更新後Outlook都重建索引…
时间Tue Feb 21 13:49:22 2023
※ 引述《kaihon (遇心与诚)》之铭言：
: → kaihon: 请教楼上有别的方式替代吗!? 02/21 13:07
写程式自己抓 title
因为效率问题，我的 mail pst 一般控制在 20GB 以下，当然因为 size 问题我每三个月要切一份，所以用 outlook 的进阶搜寻是找不到的
而且我也放弃这种方式。
通常是因为以搜寻标题为主，如果你的条件不一样要另外写适配条件。
-------------------------------------------------------------------------
olFolderCalendar=9 ' The Calendar folder.
olFolderConflicts=19 ' The Conflicts folder (subfolder of the Sync Issues
folder). Only available for an Exchange account.
olFolderContacts=10 ' The Contacts folder.
olFolderDeletedItems=3 ' The Deleted Items folder.
olFolderDrafts=16 ' The Drafts folder.
olFolderInbox=6 ' The Inbox folder.
olFolderJournal=11 ' The Journal folder.
olFolderJunk=23 ' The Junk E-Mail folder.
olFolderLocalFailures=21 ' The Local Failures folder (subfolder of the Sync
Issues folder). Only available for an Exchange account.
olFolderManagedEmail=29 ' The top-level folder in the Managed Folders group.
For more information on Managed Folders, see the Help in Microsoft Outlook.
Only available for an Exchange account.
olFolderNotes=12 ' The Notes folder.
olFolderOutbox=4 ' The Outbox folder.
olFolderSentMail=5 ' The Sent Mail folder.
olFolderServerFailures=22 ' The Server Failures folder (subfolder of the Sync
Issues folder). Only available for an Exchange account.
olFolderSuggestedContacts=30 ' The Suggested Contacts folder.
olFolderSyncIssues=20 ' The Sync Issues folder. Only available for an
Exchange account.
olFolderTasks=13 ' The Tasks folder.
olFolderToDo=28 ' The To Do folder.
olPublicFoldersAllPublicFolders=18 ' The All Public Folders folder in the
Exchange Public Folders store. Only available for an Exchange account.
olFolderRssFeeds=25 'The RSS Feeds folder.
VALID_STORED_EXT=ARRAY("xls" ,"xlsx","doc" ,"docx","ppt"
,"pptx","pdf","zip","7z","rar","tdl","txt","lst","log","iic")
dim MailStoredFormat
MailStoredFormat="winword"
dim objFSO
MainProgram
wScript.Quit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub MainProgram
dim oOutlook
dim dayInner
dim strPattern
Set oShell = CreateObject( "WScript.Shell" )
dayInner=oShell.ExpandEnvironmentStrings("%FindMailInDay%")
'wScript.Echo "dayInner = "&dayInner
strPattern= InputBox ("Please input the query string","Query String","")
dayInner=InputBox("Input Query Date 1-10000","Input Query Days",3)
if not IsNumeric(dayInner) then
wScript dayInner&" is not a number, quit"
wScript.Quit
end if
MailStoredFormat=InputBox("Stored MailStoredFormat","Stored
MailStoredFormat","MSG")
if LCase(MailStoredFormat) = "winword" OR LCase(MailStoredFormat) = "doc"
then
MailStoredFormat = "Winword"
else
MailStoredFormat = "MSG"
end if
Set objFSO = CreateObject("Scripting.FileSystemObject")
set oOutlook = CreateObject("Outlook.Application")
'wScript.Echo "oOutlook.Name = "&oOutlook.Name
'wScript.Echo "oOutlook.DefaultProfileName = "&oOutlook.DefaultProfileName
set oMyNameSpace = oOutlook.GetNameSpace("MAPI")
oMyNameSpace.Logon "",,FALSE,FALSE
set oStores = oOutlook.Session.Stores
dim oParentFolder
set oParentFolder = nothing
For each oStore in oStores
set oRoot = oStore.GetRootFolder
wScript.Echo "root = "&oRoot.Name
wScript.Echo ">"&strPattern&"<"&" "&dayInner
Set oParentFolder = oRoot
BrowseFolder oOutlook,oParentFolder,strPattern,dayInner
Next
'oOutlook.Quit
End Sub
public Sub BrowseFolder(oOutlook,oParentFolder,strPattern,dayInner)
Dim oStores
Dim oStore
Dim oRoot
Dim oFolder
FindAndStoreMail oParentFolder,strPattern,dayInner
For Each oFolder in oParentFolder.Folders
if (oFolder.Name <> "草稿" AND _
oFolder.Name <> "删除的邮件" AND _
oFolder.Name <> "RSS 摘要" AND _
oFolder.Name <> "垃圾邮件" AND _
oFolder.Name <> "连络人" ) then
wScript.Echo oParentFolder.Name &"-->"&oFolder.Name
BrowseFolder oOutlook,oFolder,strPattern,dayInner
end if
Next
End Sub
Sub FindAndStoreMail(myFolders,strPattern,dayInner)
if myFolders is nothing then
Exit Sub
end if
dim LimitDateCode
LimitDateCode = GetDateCode(Date-dayInner)
for each item in myFolders.Items
'wScript.Echo "Subject: "&item.Subject
'wScript.Echo "Attachments count: "&item.Attachments.Count
if TypeName(item) = "MailItem" AND _
(Left(item.Subject,3) <> "回收:" AND _
Left(item.Subject,4) <> "邮件回收" AND _
Left(item.Subject,4) <> "邮件撤回" AND _
Left(item.Subject,3) <> "撤回:") then
set myItem = item
'wScript.Echo myItem.Subject
myDateCode = GetDateCode(myItem.SentOn)
myTimeCode = GetTimeCode(myItem.SentOn)
if myDateCode > (LimitDateCode) then
if MatchStrPatterns(myItem.Subject,strPattern) then
wScript.Echo "MAIL Subject: "&myItem.Subject
wScript.Echo ">"&strPattern&"<"
'Exit sub
dim TargetFolder
TargetFolder = strPattern
SaveMailItemWithSubjectName myItem,TargetFolder
SaveMailItemAttaches myItem,TargetFolder
end if
else
'wScript.Echo "Date Expired "& myDateCode &"<>"&
(LimitDateCode-dayInner)
end if
end if
next
End Sub
Function GetTimeCode(myTime)
dim myHour
dim myMinute
dim myCode
myHour = Hour(myTime)
myMinute = Minute(myTime)
myCode = myHour*100+myMinute
if myCode < 1000 then
myCode = "0"&myCode
end if
GetTimeCode = myCode
End Function
Function GetDateCode(myTime)
dim myYear
dim myMonth
dim myDay
myYear=Year(myTime)
myMonth=Month(myTime)
myDay=Day(myTime)
GetDateCode = myYear * 10000+myMonth*100+myDay
End Function
public Function ForwardMail(oMailItem, MailTo)
dim myItem
if oMailItem is nothing then
exit Function
end if
set myItem = oMailItem.Forward
myItem.To = MailTo
myItem.Send
myItem.Display
End Function
public Function BrowsFolder(oParentFolder,ParentName)
Dim oFolder
if oParentFolder is Nothing then
exit Function
end if
'wScript.Echo oParentFolder.Name
for each oFolder in oParentFolder.Folders
wScript.Echo ParentName&"\"&oFolder.Name
BrowseFolder oFolder,ParentName&"\"&oFolder.Name
next
End Function
public Function GetFolderByPath(oOutlook,RootPath,Folderpath)
Dim oStores
Dim oStore
Dim oRoot
Dim oFolder
FindFolder = 0
FolderArray = split(Folderpath,"\")
set oStores = oOutlook.Session.Stores
dim oParentFolder
set oParentFolder = nothing
For each oStore in oStores
set oRoot = oStore.GetRootFolder
'wScript.Echo "GetFolderByPath(): finding: "&RootPath&"root =
"&oRoot.Name
if LCase(RootPath) = LCase(oRoot.Name) then
'wScript.Echo "oRoot.FolderPath:"&oRoot.FolderPath&""&oRoot.Name&""
Set oParentFolder = oRoot
found = 0
for each FolderName in FolderArray
'wScript.Echo FolderName
for each folder in oParentFolder.Folders
if LCase(folder.Name) = LCAse(FolderName) then
set oFolder = folder
found = 1
exit For
end if
next
if found = 0 then
set GetFolderByPath = Nothing
Exit Function
else
set oParentFolder = oFolder
end if
next
'for each folder in oRoot.folders
' wScript.Echo oRoot.FolderPath&"\"&folder.name
' for each sfolder in folder.folders
' wScript.Echo oRoot.FolderPath&"\"&folder.name&"\"&sfolder.name
' next
'next
end if
Next
if found = 0 then
set GetFolderByPath = Nothing
end if
wScript.Echo "found = "&found
wScript.Echo oParentFolder.Name
set GetFolderByPath = oParentFolder
End Function
Function FilterFileNameRule(myName)
dim inputName
dim outputName
inputName = ""
outputName = myName
while inputName <> outputName
inputName = outputName
outputName=Replace(outputName,"：",":")
outputName = Replace(outputName,":","_")
outputName = Replace(outputName,"\","_")
outputName = Replace(outputName,"/","_")
outputName = Replace(outputName,"""","'")
outputName = Replace(outputName,"*","_")
outputName = Replace(outputName,"?","_")
outputName = Replace(outputName,">","_")
outputName = Replace(outputName,"<","_")
outputName = Replace(outputName,"!"," ")
outputName=Replace(outputName,"答复_","RE_")
outputName=Replace(outputName,"答覆_","RE_")
outputName=Replace(outputName,"回复_","RE_")
outputName=Replace(outputName,"回覆_","RE_")
outputName=Replace(outputName,"回复：","RE_")
outputName=Replace(outputName,"Re_","RE_")
outputName=Replace(outputName,"RE_","RE_ ")
outputName=Replace(outputName,"RE_","RE_")
outputName=Replace(outputName,"RE_ ","RE_ ")
outputName=Replace(outputName,"RE_ RE_ ","RE_ ")
outputName=Replace(outputName,"转寄_ ","FW_ ")
outputName=Replace(outputName,"[Attention!Encrypted_Attachment]","")
outputName = Replace(outputName," "," ")
outputName = Replace(outputName,"__","_")
outputName = Replace(outputName,"_ ","_")
outputName = Replace(outputName," _","_")
outputName = Replace(outputName,"--","-")
outputName = Replace(outputName,"- ","-")
outputName = Replace(outputName," -","-")
outputName = Replace(outputName,"_-","-")
outputName = Replace(outputName,"-_","_")
'wScript.Echo "FilterFileNameRule("&inputName&") =>"&outputName
wend
FilterFileNameRule = outputName
End Function
Sub SaveMailItemAttaches(myItem,TargetFolder)
if myItem is nothing then
Exit Sub
end if
dim folder
dim FolderArray
dim myTargetFolder
myTargetFolder = ""
FolderArray = split(TargetFolder,"\")
for each folder in FolderArray
if myTargetFolder = "" then
myTargetFolder = FilterFileNameRule(folder)
else
myTargetFolder = myTargetFolder&"\"&FilterFileNameRule(folder)
end if
if not objFso.FolderExists(TargetFolder) then
objFso.CreateFolder(myTargetFolder)
end if
next
for each attach in myItem.Attachments
'wScript.Echo "Attach name: "&attach.displayname
'wScript.Echo "Attach filename: "&attach.filename
'wScript.Echo "Attach position: "&attach.position
myFileName = myTargetFolder&"\"&attach.filename
dst_file = objFSO.GetAbsolutePathName(myFileName)
dst_ext = objFSO.GetExtensionName(attach.filename)
'refname = "ProjectReference_"&GetFormatDays(Now)&".xls"
'reffile = objFSO.GetAbsolutePathName(refname)
for each stored_ext in VALID_STORED_EXT
if lcase(dst_ext) = lcase(stored_ext) then
wScript.Echo "Attached file <"&attach.filename&"> stored as:
"&dst_file&"<EXT>"&dst_ext
attach.saveasfile(dst_file)
exit for
end if
next
next
End Sub
Function MatchStrPatterns(myStr,strPattern)
'wScript.Echo myStr&" .cmp."&strPattern
if 0 = InStr(lcase(myStr),lcase(strPattern)) then
MatchStrPatterns = False
Exit Function
end if
MatchStrPatterns = True
End Function
Sub SaveMailItemWithSubjectName (myMailItem,TargetFolder)
olDoc=4 'Microsoft Office Word format (.doc)
olHTML=5 'HTML format (.html)
olICal=8 'iCal format (.ics)
olMHTML=10 'MIME HTML format (.mht)
olMSG=3 'Outlook message format (.msg)
olMSGUnicode=9 'Outlook Unicode message format (.msg)
olRTF=1 'Rich Text format (.rtf)
olTemplate=2 'Microsoft Outlook template (.oft)
olTXT=0 'Text format (.txt)
olVCal=7 'VCal format (.vcs)
olVCard=6 'VCard format (.vcf)
if myMailItem is nothing then
Exit Sub
end if
if TypeName(myMailItem) <> "MailItem" then
Exit Sub
end if
dim myDateCode
dim myTimeCode
dim myFileName
myDateCode = GetDateCode(myMailItem.SentOn)
myTimeCode = GetTimeCode(myMailItem.SentOn)
'wScript.Echo "Subject: "&myMailItem.Subject
'if false then
' wScript.Echo "From: " & myMailItem.Sender
&">"&myMailItem.SenderEmailAddress&"<"
' wScript.Echo "At: "&myDateCode&","&myTimeCode
' strpos = InStrRev(myMailItem.SenderEmailAddress,"/")
' wScript.Echo "strpos = "&strpos
' FromStr =
Right(myMailItem.SenderEmailAddress,len(myMailItem.SenderEmailAddress)-strpos)
' strpos = InStrRev(FromStr,"=")
' FromStr = Right(FromStr,len(FromStr) - strpos)
' wScript.Echo "FromStr =
"&myMailItem.SenderEmailAddress&"->"&FromStr&"<"
'end if
'
FromStr = myMailItem.Sender
strpos = Instr(FromStr," (")
if strpos > 1 then
FromStr = Left(FromStr, strpos-1)
end if
'wScript.Echo "FromStr = "&myMailItem.Sender&"->"&FromStr&"<"
myFileName = myMailItem.Subject
myFileName = FilterFileNameRule(myDateCode&"_"&myTimeCode&" "&FromStr&"
"&myFileName)
dim folder
dim FolderArray
dim myTargetFolder
dim FileExt
dim myStoredType
if LCase(MailStoredFormat) = "winword" OR LCase(MailStoredFormat) = "doc"
then
FileExt = ".doc"
myStoredType = olDoc
else
FileExt = ".msg"
myStoredType = olMSGUnicode
end if
myTargetFolder = ""
FolderArray = split(TargetFolder,"\")
for each folder in FolderArray
if myTargetFolder = "" then
myTargetFolder = FilterFileNameRule(folder)
else
myTargetFolder = myTargetFolder&"\"&FilterFileNameRule(folder)
end if
if not objFso.FolderExists(myTargetFolder) then
objFso.CreateFolder(myTargetFolder)
end if
next
myFileName = myTargetFolder&"\"&myFileName
wScript.Echo "["&myMailItem.Subject&"] ==> "&myFileName
dim target_file
target_file = objFSO.GetAbsolutePathName(myFileName&FileExt)
'wScript.Echo target_file
dim repeatcount
repeatcount = 0
while objFSO.FileExists(target_file)
repeatcount = repeatcount+1
'wScript.Echo target_file&" found, regen."
target_file =
objFSO.GetAbsolutePathName(myFileName&"("&repeatcount&")"&FileExt)
wend
wScript.Echo "myMailItem.SaveAs "&target_file
myMailItem.SaveAs target_file,myStoredType
End Sub
--
※ 发信站: 批踢踢实业坊(ptt.cc), 来自: 60.251.196.233 (台湾)
※ 文章网址: https://webptt.com/cn.aspx?n=bbs/Windows/M.1676958564.A.7D0.html