WScript.echo "Warning This Script will Use The Default PST Format Supported by The Version of Outlook Your Using. Pre Outlook 2003 Supports A max" &_
" PST Size of 2gig.  Outlook 2003 or Greater Supports PST files over 2gig.  A Registry Change May Be Necessary to Allow Extremely Large PST Files in Unicode To Be Created"

' defined for future use if needed
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

'PST Constants
Const olStoreDefault = 1    ' Supports Default Pst Type for Version of Outlook
Const olStoreUnicode =2     ' Enables Support for Unicode PST Files that can Grow in Excess of 2gig
Const olStoreANSI = 3       ' Enables Ansi Support for pre outlook 2003 versions that support pst files of no more then 2gig

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")

'Get user's name
Set objNetwork = WScript.CreateObject("WScript.Network")

strUserName = objNetwork.UserName

'create pst add user name
Dim WshShell : Set WshShell = WScript.CreateObject( "WScript.Shell" )
Dim objFSO : Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

' PST Folder Path
OutlookFolder = "C:\Outlook"

'Create Folder if it Doesn't Exist
If Not objFSO.FolderExists(OutlookFolder) Then
Set oFolder = objFSO.CreateFolder (OutlookFolder)
End If

' Check version of office before creating .Pst
sComputer = "."
iOfficeVer = GetOfficeVer(sComputer)
If iOfficeVer = -1 Then
WScript.Echo "Version of Office installed is unknown, " & "could not connect to the remote computer."

ElseIf iOfficeVer = 0 Then
WScript.Echo "Office is not installed."
Else
WScript.Echo "Version of Office installed: " & iOfficeVer
End If

'Create .Pst file as Username in The Outlook folder

If iOfficeVer = "2007" Then
objNameSpace.AddStoreEx OutlookFolder & "\" & objNameSpace.CurrentUser & ".pst",olStoreDefault

Else
objNameSpace.AddStoreEX OutlookFolder & "\" & objNameSpace.CurrentUser & ".pst",olStoreDefault

End If

strpstFolder = objnamespace.currentuser

strdisplayname = "Exported Mailbox"

'Renames PST File To Unique Display Name
Set pstrename = objNameSpace.Folders.GetLast
pstrename.name = strdisplayname

'Recycle pst mount to get display name to appear if not office 2007
If iOfficeVer <> "2007" Then
objNamespace.RemoveStore pstrename ' Step 1 to refresh folder tree view
objNamespace.AddStore outlookfolder & "\" & strpstfolder & ".pst" ' Step 2 to refresh folder tree view
end if
'Bind to Pst File
Set pstfoldermount = objNameSpace.folders(strdisplayname)
pstroot = pstfoldermount.name
'Set Namspace to Default Mailbox Inbox Folder
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
strFolderName = objInbox.Parent

'Sets Default to Mailbox Root vs Inbox. Must bind to inbox like above first Before Parent Below this is by design
Set objMailbox = objNamespace.Folders(strFolderName)

'set collection for mailbox contents at root
Set colFolders = objMailbox.Folders

For Each objFolder In colFolders

If LCase(objfolder.name) = LCase("Deleted Items") Then
Set objmailboxfolder = objmailbox.folders(objfolder.name)
Set objPstFolder = objNameSpace.folders(pstroot)
Set objPstDeleted = objPstFolder.folders("Deleted Items")
Set copyFolder = objmailboxfolder.CopyTo(objPstdeleted)

Else

Set objmailboxfolder = objmailbox.folders(objfolder.name)
Set objPstFolder = objNameSpace.folders(pstroot)
Set copyFolder = objmailboxfolder.CopyTo(objPstFolder)

End If

Next

' sub Dismount PST

get_DismountPST()

WScript.echo "Outlook/Exchange Mailbox Export To PST File Completed.  PST Has Been Dismounted and is Located in C:\outlook Directory"

'******************* FUNCTIONS and Subs *************************************************************

'*** Sub Dismount PST ******
Sub get_DismountPST()

Set myOlApp = CreateObject("Outlook.Application")
Set myNS = myolapp.GetNamespace("MAPI")
set pstfolder = myns.folders("Exported Mailbox")

myNS.removeStore pstfolder

End sub

'*** Function

Function GetOfficeVer(sNode)
On Error Resume Next
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sNode & "/root/default:StdRegProv")
If Err.Number <> 0 Then
GetOfficeVer = -1
Exit Function  '------->
End If
sValueName = "Path"
sRegPre = "SOFTWARE\Microsoft\Office\"
sRegPost = "\Common\InstallRoot"

If oReg.GetStringValue(HKLM, sRegPre & "12.0" & sRegPost, sValueName, sValue) = 0 Then
GetOfficeVer = 2007
ElseIf oReg.GetStringValue(HKLM, sRegPre & "11.0" & sRegPost, sValueName, sValue) = 0 Then
GetOfficeVer = 2003
ElseIf oReg.GetStringValue(HKLM, sRegPre & "10.0" & sRegPost, sValueName, sValue) = 0 Then
GetOfficeVer = 2002
ElseIf oReg.GetStringValue(HKLM, sRegPre & "9.0" & sRegPost, sValueName, sValue) = 0 Then
GetOfficeVer = 2000
ElseIf oReg.GetStringValue(HKLM, sRegPre & "8.0" & sRegPost, sValueName, sValue) = 0 Then
GetOfficeVer = 97
Else
GetOfficeVer = 0
End If
End Function