Need some help creating folders in Outlook 2007 PST using vbscript

Hi everyone,

I have little to no experience in scripting other than creating some batch files for basic tasks. 

I am trying to write a vbscript that will create a new PST file and copy the folder structure from the current PST.

I'm having trouble recreating the folders in the new PST but I think I'm 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.

Any help would be appreciated, this is what I have so far:
 

   ' filename: make_pst.vbs   '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 Settings\Application Data\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   
 
 '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 

Was able to get it working after all.  Here is the code in case someone finds it useful:
 
' 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


' 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