EDN Admin
Well-known member
Hi everyone,<br/>
<br/>
I have little to no experience in scripting other than creating some batch files for basic tasks. <br/>
<br/>
I am trying to write a vbscript that will create a new PST file and copy the folder structure from the current PST.<br/>
<br/>
Im having trouble recreating the folders in the new PST but I think Im close as I have been able to recreate all subfolders from the Inbox of the original PST, but they are getting created in the root of the new PST rather than a new Inbox folder.<br/>
<br/>
Any help would be appreciated, this is what I have so far:<br/>
<pre lang="x-vbnet constants
Const olFolderDeletedItems = 3
Const olFolderOutbox = 4
Const olFolderSentMail = 5
Const olFolderInbox = 6
Const olFolderCalendar = 9
Const olFolderContacts = 10
Const olFolderJournal = 11
Const olFolderNotes = 12
Const olFolderTasks = 13
Const olFolderDrafts = 16
Const olPublicFoldersAllPublicFolders = 18
Const olFolderJunk = 23
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 SettingsApplication DataMicrosoftOutlook" & 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
Bind to Pst File
Set newPST = objNameSpace.folders(pstName)
newPstRoot = newPST.name
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 objPstFolder = objNameSpace.folders(newPstRoot)
Set objPstFolder = objNameSpace.folders(pstName)
For Each objFolder In colOldFolders
WScript.echo objFolder.Name
copyFolders objFolder, objPstFolder
Next
clean things up
Set objNameSpace = Nothing
Set objOutlook = Nothing
Copy folder structure
Sub copyFolders(PST, MBox)
On Error Resume Next
For Each Folder in PST.Folders
MBox.Folders.Add(Folder.Name)
WScript.Echo "Folder Added: " & Folder.Name & vbcr & "objFolder: " & PST & vbcr & "MBox: " & Mbox
WScript.Echo Folder.Name & " -> " & MBox.Name
If Err.Number = 0 Then
WScript.Echo Folder.Name & " - " & Err.Description
Count = Count + 1
End If
copyFolders Folder, MBox.Folders(Folder.Name)
Next
End Sub
[/code]
<br/>
<br/>
<br/>
<br/>
<br/>
View the full article
<br/>
I have little to no experience in scripting other than creating some batch files for basic tasks. <br/>
<br/>
I am trying to write a vbscript that will create a new PST file and copy the folder structure from the current PST.<br/>
<br/>
Im having trouble recreating the folders in the new PST but I think Im close as I have been able to recreate all subfolders from the Inbox of the original PST, but they are getting created in the root of the new PST rather than a new Inbox folder.<br/>
<br/>
Any help would be appreciated, this is what I have so far:<br/>
<pre lang="x-vbnet constants
Const olFolderDeletedItems = 3
Const olFolderOutbox = 4
Const olFolderSentMail = 5
Const olFolderInbox = 6
Const olFolderCalendar = 9
Const olFolderContacts = 10
Const olFolderJournal = 11
Const olFolderNotes = 12
Const olFolderTasks = 13
Const olFolderDrafts = 16
Const olPublicFoldersAllPublicFolders = 18
Const olFolderJunk = 23
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 SettingsApplication DataMicrosoftOutlook" & 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
Bind to Pst File
Set newPST = objNameSpace.folders(pstName)
newPstRoot = newPST.name
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 objPstFolder = objNameSpace.folders(newPstRoot)
Set objPstFolder = objNameSpace.folders(pstName)
For Each objFolder In colOldFolders
WScript.echo objFolder.Name
copyFolders objFolder, objPstFolder
Next
clean things up
Set objNameSpace = Nothing
Set objOutlook = Nothing
Copy folder structure
Sub copyFolders(PST, MBox)
On Error Resume Next
For Each Folder in PST.Folders
MBox.Folders.Add(Folder.Name)
WScript.Echo "Folder Added: " & Folder.Name & vbcr & "objFolder: " & PST & vbcr & "MBox: " & Mbox
WScript.Echo Folder.Name & " -> " & MBox.Name
If Err.Number = 0 Then
WScript.Echo Folder.Name & " - " & Err.Description
Count = Count + 1
End If
copyFolders Folder, MBox.Folders(Folder.Name)
Next
End Sub
[/code]
<br/>
<br/>
<br/>
<br/>
<br/>
View the full article
