thanks I have it set to use default pst format I thought by by using the olStoreDefault constant. Here is an updated version that does work with outlook 2003. It has an issue with changing the display name and tends to not chang it in the folder listing. Even though if you right click the created pst and choose properties it will say the new display name. If you close outlook and re open it the correct display name will appear. To get around it I had to dismount and remount if the version was 2003. I also had some success strarting the script with outlook closed and use an outlook /cleanviews command but that didn't seem like the best approach. this one works with outlook open and has been tested on 2003 and 2007 versions.
code starts here:
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