问题描述:

thanks to Richard Mueller, i got a good code but when i try put an shared mailbox, the new pst will have my personal folders and the shared mailbox folders. How can i limit the folders just to the shared mailbox - without my folders? Thank you.

Sub copypst()

' Creates a new Outlook PST named after the windows username and current year

' Binds the new PST to Outlook and copies the directory structure to the new PST

' filename: make_new_pst.vbs

Const olFolderInbox = 6

'Grab the user name

Set WSHNetwork = CreateObject("WScript.Network")

strUser = WSHNetwork.UserName

'grab user profile

Set oShell = CreateObject("Wscript.Shell")

strUserProfile = oShell.ExpandEnvironmentStrings("%USERPROFILE%")

pstName = strUser & " _" & Year(Now)

strPSTPath = strUserProfile & "\Local Settings\Application Data\Microsoft\Outlook\" & pstName & ".pst"

' win7/vista:

'strPSTPath = strUserProfile & "\AppData\Local\Microsoft\Outlook\" & pstName & ".pst"

'hook into MAPI and create pst

Set objOutlook = CreateObject("Outlook.Application")

Set objNamespace = objOutlook.GetNamespace("MAPI")

objNamespace.AddStoreEx strPSTPath, 2

'Renames PST File To Unique Display Name

Set pstrename = objNamespace.Folders.GetLast

pstrename.name = pstName

'Set Namspace to Default Mailbox Inbox Folder

Set objOldInbox = objNamespace.GetDefaultFolder(olFolderInbox)

strOldFolderName = objOldInbox.Parent

'Sets Default to Mailbox Root vs Inbox. Must bind to inbox like above first Before Parent Below this is by design

Set objOldMailbox = objNamespace.Folders(strOldFolderName)

'set collection for mailbox contents at root

Set colOldFolders = objOldMailbox.Folders

' set destination PST

Set destPst = objNamespace.Folders(pstName)

' loop through each folder in original PST

For Each objFolder In colOldFolders

' only create 'else' folders

Select Case objFolder.name

Case "Calendar"

Case "Contacts"

Case "Deleted Items"

Case "Journal"

Case "Junk E-Mail"

Case "Notes"

Case "Outbox"

Case "RSS Feeds"

Case "Sent Items"

Case "Tasks"

Case Else

copyFolders objFolder, destPst

End Select

Next

'clean things up

Set objNamespace = Nothing

Set objOutlook = Nothing

End Sub

' creates all subfolders recursively

Sub copyFolders(pObjFolder, pDestPst)

Set myNewFolder = pDestPst.Folders.Add(pObjFolder.name)

For Each SubFolder In pObjFolder.Folders

copyFolders SubFolder, pDestPst.Folders(myNewFolder.name)

Next

End Sub

相关阅读:
Top