Hi Everybody,
I've cobbled together this script to move users local PST files to a network drive and then re-add them in Outlook.
The main part of the script comes from written by Andrew Healey & Nate Stevenson. There's also some manipulated extracts from examples.
I've re-worked the bits I need to so that it does what I want, putting the files in the right location and outputting to a log file instead of on-screen messages and all works ok.
The only problem I have is that it will only do this to the first PST it comes across. If there's two, it does the first and then finishes without errors.
I'm very new to VBS (as in today is the first time I've looked at it), but have looked through and can't logically see a reason for it not doing it. I'm sure I'm missing something simple.
Any pointers would be very appreciated!
Here's the code (please excuse the rem'd out bits there while I am working on it):
Many thanks,
Mark.
I've cobbled together this script to move users local PST files to a network drive and then re-add them in Outlook.
The main part of the script comes from written by Andrew Healey & Nate Stevenson. There's also some manipulated extracts from examples.
I've re-worked the bits I need to so that it does what I want, putting the files in the right location and outputting to a log file instead of on-screen messages and all works ok.
The only problem I have is that it will only do this to the first PST it comes across. If there's two, it does the first and then finishes without errors.
I'm very new to VBS (as in today is the first time I've looked at it), but have looked through and can't logically see a reason for it not doing it. I'm sure I'm missing something simple.
Any pointers would be very appreciated!
Here's the code (please excuse the rem'd out bits there while I am working on it):
Code:
'==========================================================================
' VBScript Source File
' LAST EDITED: 26/10/09 by Mark Chamberlain, ICT Services
' NAME: move-pst-to-network
' COMMENT: This script will move PST files mapped in Outlook to the users
' U:\ drive in a folder called OutlookPST
' CHANGES:
'
'==========================================================================
Option Explicit
'Determine if a laptop (remove if you don't care)
'If IsLaptop() = True Then
' wscript.echo "Computer is a laptop or the chassis could not be determined."
' wscript.echo "Exiting."
' wscript.quit
'End If
'Create a logfile at C:\PSTlog.txt and opens it for writing
Dim fso, LogFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set LogFile = fso.CreateTextFile("c:\PSTlog.txt", TRUE)
'Determine if outlook is installed
'If IsOutlookInstalled() = False Then
' wscript.echo "Could not launch Outlook, script stopping."
' LogFile.WriteLine ("Error: Could not launch Outlook, exiting.")
' wscript.quit
' End If
'Get user name
Dim WshNetwork : Set WshNetwork = WScript.CreateObject("WScript.Network")
Dim user : user = lcase(WshNetwork.UserName)
Set WshNetwork = Nothing
Dim strNetworkPath
'=========================================================================
' Configuration Section
strNetworkPath = "U:\OutlookPST\"
' End Configuration Section
'=========================================================================
'Fix network path if forgot to include trailing slash...
If Not Right(strNetworkPath,1) = "\" Then strNetworkPath = strNetworkPath & "\"
'Create folder for PST's on U:\ drive
'
'Checks if U:\OutlookPST exists, if not creates it
'and writes to log file with outcome
' Set variables for folder creation
Dim objFSO2, objFolder2, objShell2, strDirectory2
strDirectory2 = "u:\OutlookPST"
' Create the File System Object
Set objFSO2 = CreateObject("Scripting.FileSystemObject")
' Checks if folder exists, reports back
If objFSO2.FolderExists(strDirectory2) Then
Set objFolder2 = objFSO2.GetFolder(strDirectory2)
' WScript.Echo "OutlookPST folder already created"
Logfile.Writeline("The OutlookPST folder already exists")
Else
Set objFolder2 = objFSO2.CreateFolder(strDirectory2)
' WScript.Echo "Created OutlookPST folder "
Logfile.Writeline("Created the OutlookPST folder")
End If
'Determine if network path is writable
If IsPathWritable(strNetworkPath) = False Then
' wscript.echo "Remote path is not writable, script stopping."
LogFile.WriteLine ("Error: Cannot write to U:\OutlookPST\")
wscript.quit
End If
'Instatiate objects
Dim objOutlook, objNS, objFSO, objFolder
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Sort through all stores in outlook and add all local pst
' paths into an array. Then remove the store from outlook.
Dim pstFiles
Dim count : count = -1
Dim arrPaths()
For Each objFolder In objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
pstFiles = GetPSTPath(objFolder.StoreID)
If IsStoredLocal(pstFiles) = True Then
If objFSO.FileExists(strNetworkPath & Mid(pstFiles,InStrRev(pstFiles,"\") + 1)) = True Then
'wscript.echo "A pst file already exists with the same name." & vbCrLf & _
LogFile.WriteLine("Error: A pst file already exists with the same name") & vbCrLf & _
vbTab & "Source: " & pstPath & vbCrLf & _
vbTab & "Target: " & strNetworkPath & Mid(pstPath,InStrRev(pstPath,"\") + 1)
Else
count = count + 1
ReDim Preserve arrPaths(count)
arrPaths(count) = pstFiles
objOutlook.Session.RemoveStore objFolder
End If
End If
End If
Next
objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
' Writes PST path in log for each entry in array, if any
'If count >= 0 Then
' For Each present In arrPaths
' LogFile.WriteLine(present)
' LogFile.WriteLine("<br/>")
' If no entries found in array, write to log and quit
if count < 0 then
' wscript.echo "No local PST Files Found."
LogFile.WriteLine("No local PST files found to move.")
wscript.quit
End If
'If local PST files were found, move them to the new location
'Echo output if the file already exists
Dim pstPath
For Each pstPath in arrPaths
On Error Resume Next
objFSO.MoveFile pstPath, strNetworkPath
If Err.Number <> 0 Then
wscript.sleep 5000
objFSO.MoveFile pstPath, strNetworkPath
End If
Err.Clear
On Error GoTo 0
Next
Set objFSO = Nothing
'Re-open outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
'Re-map Outlook folders
For Each pstPath in arrPaths
objNS.AddStore strNetworkPath & Mid(pstPath,InStrRev(pstPath,"\") + 1)
LogFile.Writeline("PST re-mapped in Outlook")
Next
objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
'wscript.echo "Done."
LogFile.WriteLine("Script Finished")
LogFile.WriteLine(Date)
LogFile.WriteLine(Time)
wscript.quit
'Closes the open log file, no more to write
LogFile.Close
Private Function GetPSTPath(byVal input)
'Will return the path of all PST files
' Took Function from: [URL unfurl="true"]http://www.vistax64.com/vb-script/[/URL]
Dim i, strSubString, strPath
For i = 1 To Len(input) Step 2
strSubString = Mid(input,i,2)
If Not strSubString = "00" Then
strPath = strPath & ChrW("&H" & strSubString)
End If
Next
Select Case True
Case InStr(strPath,":\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,":\")-1)
Case InStr(strPath,"\\") > 0
GetPSTPath = Mid(strPath,InStr(strPath,"\\"))
End Select
End Function
'Private Function IsLaptop()
' 'Determine if the computer is a mobile machine
' On Error Resume Next
' 'Instantiate objects
' Dim objWMIService, colChassis, objChassis, strChassisType
' Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
' Set colChassis = objWMIService.ExecQuery("Select * from Win32_SystemEnclosure")
'
' 'Check chassis type
' '[URL unfurl="true"]http://msdn.microsoft.com/en-us/library/aa394474%28VS.85%29.aspx[/URL]
' For Each objChassis in colChassis
' For Each strChassisType in objChassis.ChassisTypes
' If (strChassisType >= 8 And strChassisType <=12) Or (strChassisType = 14) Then
' IsLaptop = True
' Exit For
' Else
' IsLaptop = False
' End If
' Next
' Next
' If Err.Number <> 0 Then IsLaptop = False
' On Error GoTo 0
' Set colChassis = Nothing
' Set objWMIService = Nothing
' objChassis = Null
'End Function
'Private Function IsOutlookInstalled()
'Function will return false if unable to launch outlook
' This adds some overhead but it is ultimately the best
' way to truly determine if script will function properly.
' On Error Resume Next
' Set objOutlook = CreateObject("Outlook.Application")
' If Err.Number <> 0 Then
' IsOutlookInstalled = False
' Exit Function
' End If
' On Error GoTo 0
' IsOutlookInstalled = True
' objOutlook.Session.Logoff
' objOutlook.Quit
' Set objOutlook = Nothing
'End Function
Private Function IsPathWritable(byVal strPath)
'Check to make sure the path is writable. If it is not, no
' need to continue processing.
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim min : min = 1
Dim max : max = 1000
Dim rand : rand = Int((max - min + 1) * Rnd + min)
Dim fullFileName : fullFileName = strPath & "temporary-" & rand & ".txt"
Dim objFile : Set objFile = objFSO.CreateTextFile(fullFileName, True)
objFile.WriteLine("Test file creation of " & fullFileName)
objFile.Close
If objFSO.FileExists(fullFileName) Then
IsPathWritable = True
objFSO.DeleteFile(fullFileName)
Else
IsPathWritable = False
End If
If Err.Number <> 0 Then IsPathWritable = False
On Error GoTo 0
Set objFile = Nothing
Set objFSO = Nothing
rand = Null
max = Null
min = Null
fullFileName = Null
End Function
Private Function IsStoredLocal(ByVal fullFileName)
'Check if the PST is stored locally or on a mapped or removable drive
On Error Resume Next
Dim objDisk, objWMIService, colDisks
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colDisks = objWMIService.ExecQuery("SELECT * FROM Win32_LogicalDisk")
For Each objDisk in colDisks
If objDisk.DriveType = 3 Then
If InStr(fullFileName,objDisk.DeviceID) > 0 Then
IsStoredLocal = True
Exit For
Else
IsStoredLocal = False
End If
End If
Next
If Err.Number <> 0 Then IsLocalDrive = False
On Error GoTo 0
End FunctionMany thanks,
Mark.
