Need help with the Do Until Loop

[Guido1508]

thread329-1575977

In the thread329-1575977 M4rkC mentioned that he had solve this with a do until Loop.
At the For Each objFolder In objNS.Folders position

Due to some time presure it would be appreciated if I got some help

The script is very usefull in our situation, where we needs to move all local PST to the network.
This is so we have them on one location so that they can be imported in the archiving tool directly.

Thanks in Advance

'==========================================================================
' VBScript Source File
' NAME: move-pst-to-network
' AUTHOR: Andrew J Healey & Nate Stevenson
' WEB:

http://halfloaded.com/

' DATE : 2010.14.2009
' COMMENT: This script will move any mapped PST files that are located on
' local disks to a network share.
' PROCESS: 1) determine if laptop; 2) determine if outlook installed
' 3) determine local drives; 4) check for local pst's; 5) move pst's
' to network; 6) remap pst files
'==========================================================================

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

'Determine if outlook is installed
If IsOutlookInstalled() = False Then
wscript.echo "Could not launch Outlook."
wscript.echo "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 = "\\servername\homes\" & user & "\"
' End Configuration Section
'=========================================================================
'Fix network path if forgot to include trailing slash...
If Not Right(strNetworkPath,1) = "\" Then strNetworkPath = strNetworkPath & "\"

'Determine if network path is writable
If IsPathWritable(strNetworkPath) = False Then
wscript.echo "Remote path is not writable."
wscript.echo "Exiting."
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 & _
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

if count < 0 then
wscript.echo "No local PST Files Found."
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)
Next

objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
wscript.echo "Done."
wscript.quit

Private Function GetPSTPath(byVal input)
'Will return the path of all PST files
' Took Function from:

http://www.vistax64.com/vb-script/

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
'

http://msdn.microsoft.com/en-us/library/aa394474(VS.85).aspx

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 Function

 

[PHV]

Did you try this script from Geates ?

http://www.cilverphox.com/vbscripts/movePST.txt

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Guido1508]

The script from Geates has the following issue.
It searches for the NS in this case "Archive Folders" and the project i'm now working on is a global one, so the language will be changing and to edit the script for each langauge isn't prefererd.

That why I want to use the script posted.

It works fine, but doesn't move all local pst.

 

[Geates]

As far as I know, you have to retrieve Outlook PSTs through the Outlook "stores". Each store has it's own name and can have multiple PSTs.

I suppose you could search the PC for .pst files, but that is neither timely or resourceful.

When you say languages, I assume you mean verbal languages like French or Italian. If so, there may not be a way around editing the script for each language.

Although, perhaps the .EntryID property is synonymous with "Archive Folders".

intID = [green]'whatever the Archive Folders store ID is[/green]
if (objStore.EntryID = intID) then
   'Get the PSTs
end if

Or, you could simply try removing the objStore.Name condition all together

'Get all PSTs from all Outlook stores.
for each objStore in objNS.Folders
    strStore = getStore(objStore.StoreID)
    strStorePath = left(strStore, inStrRev(strStore, "\"))
    strStoreFile = mid(strStore, inStrRev(strStore, "\") + 1)
    [red][s]if (objStore.Name = "Archive Folders") then[/s][/red]
        set objFiles = objFSO.GetFolder(strStorePath).Files
        for each objFile in objFiles
            if (lcase(right(objFile.Name, 4) = ".pst")) then
                dicPaths.Add objFile.Name, objFile.Path
                if (objFile.Name = strStoreFile) then
                    objOutlook.Session.RemoveStore objStore
                end if
            end if
        next
    [red][s]else[/s][/red]
        [red][s]dicExcludedPaths.Add strStoreFile, strPath[/s][/red]
    [red][s]end if[/s][/red]
next

Just a thought. (Sorry it doesn't pertain to the script you posted)

-Geates

"I hope I can feel and see the change - stop the bleed inside a feel again. Cut the chain of lies you've been feeding my veins; I've got nothing to say to you!"
-Infected Mushroom