Here's how you manipulate PST location in the registry (complete script)
In the process of consolidating serveral file servers into a single dfs
location, and turning off the old ones, we need to move the PST file
mapping in everyone's registry to point to the new location. Lots of
problems with this, not the least of which is that microsoft says
poo-poo on using PST files on the network. So, ok we're over that now,
and we don't want it to take a half an hour to open outlook because
we've moved PSTs, and we certainly don't want all the help desk calls
that come with users having to browse to them on their own.
Here's a script that solves the task at hand. I had to write some byte
array manipulation routines... search and replace -- ignoring case! --
and it handles both UNICODE (outlook 2003) and ANSI (before outlook
2003) formatted registry keys.
I'm not reccomending that anyone put PSTs on the network, but if it's
already a part of your culture, and the VBA/Outlook and MAPI api's have
failed you, here's a paltry VBScript to the rescue.
Every test I have run in on this has worked, and it hasn't broken
anything for me. All that being said, if you break stuff with it, it's
not my fault. I'm merely lighting the path for you all.
It first updates the drive mappings, then updates the registry. That
way, if someone has a PST on G:\somefolder\mybox.pst, where G: happens
to be one of the old dfs roots or shares, it's remapped first, thusly
killing all birds with one stone.
have fun.
'---------------------------------------------
' Script: DFSPrep.vbs
' Author: Dave Dolan
' Created: Sept 26, 2005
' Modified: Sept 29, 2005
'---------------------------------------------
' Remap any outstanding old-dfs drive mappings
'
' Enumerate all outlook profiles and replace
' legacy locations with those pointing to the
' new DFS root
' Thanks Kevin for breaking my first 12 versions
' of this script. I think it's pretty solid now
'----------------------------------------------
' DISCLAIMER: NO WARRANTY. Use it, if you break stuff, it's your fault.
'
' ANOTHER DISCLAIMER: Microsoft says "don't use PSTs over a network."
' I'm sure none of you do that either right?
'
' LAST DISCLAIMER: I hate pst files. You should too. This will
' help you live with them though.
'---------------------------------------------
ON ERROR RESUME NEXT 'this is for the drive mappings, which sometimes
'produce meaningless errors that halt the program
' when trying to disconnect the drives, so we'll
' skip those
'---------------------------------------------
' Constants
'---------------------------------------------
CONST BINDATA = 0
CONST UPPERCASE = 1
CONST LOWERCASE = 2
Const HKEY_CURRENT_USER = &H80000001
set TargetValues = CreateObject("Scripting.Dictionary")
With TargetValues
.Add "01020fff", "*"
.Add "001f6700", "*"
End With
Const BASE_KEY = "Software\Microsoft\Windows NT\CurrentVersion\" &_
"Windows Messaging Subsystem\Profiles"
'---------------------------------------------
set fso = createobject("scripting.filesystemobject")
set oNetwork = createobject("WScript.Network")
Dim bytesOut
'---------------------------------------------
' Setup the dictionary object for filtered strings
' Filters apply to both drive mappings and UNC
' paths to PST files
'---------------------------------------------
set oReplacements = CreateObject("Scripting.Dictionary")
with oReplacements
'correct the USERS mappings
' part of the old map replacement part of the new map
'-----------------------------------------------------------
.Add "\\olddfs\main\users", "\\domain.com\dfs\users"
.Add "\\olddfs2\data\users", "\\domain.com\dfs\users"
.Add "\\olddfs3\apps\users", "\\domain.com\dfs\users"
'correct the PROJECTS mappings
.Add "\\olddfs\main\projects", "\\domain.com\dfs\projects"
.Add "\\olddfs2\data\projects", "\\domain.com\dfs\projects"
.Add "\\olddfs3\apps\projects", "\\domain.com\dfs\projects"
'this one is mainly for plain jane drive mappings to the old roots
.Add "\\olddfs\main", "\\domain.com\dfs"
.Add "\\olddfs2\data", "\\domain.com\dfs"
end with
'---------------------------------------------
strComputer = "."
'first FIX THE DRIVE MAPPINGS
sanitizeNetworkDrives
'---------------------------------------------
' connect to the registry
'---------------------------------------------
Set objReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
'---------------------------------------------
' Enumerate the first level of keys, indicating
' the profiles
'---------------------------------------------
objReg.EnumKey HKEY_CURRENT_USER, BASE_KEY, arrSubKeys
for each subkey in arrSubKeys
subKeyPath = BASE_KEY & "\" & subkey
'---------------------------------------------
' enumerate the subkeys of each profile
' exposing the items
'---------------------------------------------
objReg.EnumKey HKEY_CURRENT_USER, subKeyPath, arrTinyKeys
for each tinyKey in arrTinyKeys
tinyKeyPath = subKeyPath & "\" & tinyKey
'---------------------------------------------
' see if our value exists
for each targetVal in TargetValues.Keys
returnVal = 0
returnVal = objReg.GetBinaryValue(HKEY_CURRENT_USER, tinyKeyPath,
_
targetVal,theVals)
if returnVal = 0 then
'outlook 2002- use ansi, 2003 uses unicode
'so we have to check for both, cause you never know
bytesBack = filterAndFix( theVals , "unicode" )
bytesBack = filterAndFix( bytesBack , "ansi" )
'write the filtered string back
returnV = objReg.SetBinaryValue (HKEY_CURRENT_USER, tinyKeyPath,
_
targetVal, bytesBack)
end if
next 'targetval
next 'tinyKey
next 'subkey
Wscript.quit(0)
'---------------------------------------------
function filterAndFix( bytesSrc, modeS )
'---------------------------------------------
' do the replacement of strings based on the
' dictionary object
'---------------------------------------------
replacedSomething = false
for each key in oReplacements.Keys
if replacedSomething = false then
strPat = key
strRepl = oReplacements.Item(key)
if strPat <> "" and strRepl <> "" then
bytesPat = null
bytesRepl = null
bytesPat = Ascii2Bytes(strPat, modeS)
bytesRepl = Ascii2Bytes(strRepl, modeS)
if BytesMatchNoCase (bytesSrc, bytesPat) > -1 then
tempBytes = BytesReplaceIgnoreCase ( tempBytes, bytesPat,
bytesRepl)
replacedSomething = true
else
tempBytes = bytesSrc
end if
end if
end if
next
filterAndFix = tempBytes
'---------------------------------------------
end Function
'---------------------------------------------
sub printBytes( byts )
'---------------------------------------------
' for debugging, display the alpha portions of the
' byte arrays, and fill the rest with dots.
strOut = "{"
for x = 0 to ubound(byts)
if alphaClass (byts(x)) = BINDATA then
charToAdd = "."
else
charToAdd = chr(byts(x))
end if
strOut = strOut & charToAdd
next
'strOut = strOut & byts(ubound(byts)) &
strOut = strOut & "}"
Wscript.Echo strOut
end sub
'---------------------------------------------
function Ascii2Bytes( aStr, mode )
'---------------------------------------------
' convert our hex string to a byte array
'---------------------------------------------
l = len (aStr)
dim bytesOut()
'build either an ANSI array
if mode = "ansi" then
redim bytesOut(l - 1)
for n = 0 to Ubound(bytesOut)
c = mid(aStr, n + 1 , 1)
bytesOut(n) = asc(c)
next
else
'or a UNICODE array
redim bytesOut((2 * l) - 1)
for n = 0 to l - 1
c = mid(aStr, n + 1 , 1)
bytesOut(( 2 * n)) = asc(c)
bytesOut((2 * n) + 1) = 0
next
end if
Ascii2Bytes = bytesOut
'---------------------------------------------
end function
'---------------------------------------------
Function BytesReplaceIgnoreCase ( src, pat, repl )
'---------------------------------------------
' Here's the heavy lifter of the script
' we match ascii as bytes, case insensitive,
' and replace the pattern
' And I never realized how much I take strings
' for granted!
'---------------------------------------------
'if no match, we don't modify and return the src
BytesReplaceIgnoreCase = src
Dim BytesBackOut()
'where do we start replacing?
subAnchor = BytesMatchNoCase( src, pat )
if subAnchor > -1 then
'ok how long are our arrays?
srcLen = Ubound(src) + 1
patLen = Ubound(pat) + 1
replLen = Ubound(repl) + 1
'since we're replacing, where to we start after the pattern?
srcPickup = srcLen - (srcLen - (subAnchor + patLen))
'how big is our output array?
newLen = (srcLen - patLen) + replLen - 1
ReDim BytesBackOut(newLen)
ticker = 0
'start at the beginning, copy until one before our match
for i = 0 to subAnchor - 1
BytesBackOut(ticker) = src(i)
ticker = ticker + 1
next
'copy our replacement
for i = 0 to replLen - 1
BytesBackOut(ticker) = repl(i)
ticker = ticker + 1
next
'pickup at srcPickup and finish the copy
for i = srcPickup to srcLen - 1
BytesBackOut(ticker) = src(i)
ticker = ticker + 1
next
'send it on home we're done
BytesReplaceIgnoreCase = BytesBackOut
end if
End Function
'---------------------------------------------
Function BytesMatchNoCase( srcBytes, patBytes )
'---------------------------------------------
' "Sub-string" match of ASCII bytes
' return the byte position of the
' first match (ONE MATCH ONLY, first one)
'---------------------------------------------
' I would do this recursively, but there
' is no way to do a "right" function
' on byte arrays, and I don't want to pass
' a whole pile of counters layer to layer
' so we're doing this the
' iterative old fashioned hard way
'---------------------------------------------
BytesMatchNoCase = -1
i = 0
done = false
while (i <= UBound(srcBytes) and done = false)
c = srcBytes(i)
'compare the first character and
' decide if we check the whole string
if BytesEqual(c, patBytes(0)) then
'here we go, we have a first char match
srcAnchor = i
patAnchor = 0
matchLength = Ubound(patBytes) + 1
clean = true
sentinal = 0
'loop through the length of the rest of the pattern, but stop if
we
' reach the end of the source string
while (clean = true AND sentinal < matchLength AND srcAnchor <=
Ubound(srcBytes))
if (BytesEqual(srcBytes(srcAnchor), patBytes(patAnchor))) then
sentinal = sentinal + 1
patAnchor = patAnchor + 1
srcAnchor = srcAnchor + 1
else
clean = false
end if
wend
if (clean = true) then
done = true
BytesMatchNoCase = i
end if
end if
i = i + 1
wend
'---------------------------------------------
End Function
'---------------------------------------------
Function BytesEqual(a, b)
'---------------------------------------------
' compare two bytes for ASCII equality
' ignoring case
'---------------------------------------------
BytesEqual = false
'obviously if they are equal, then true straight up
if a = b then
'hands down, they're physically equal
BytesEqual = true
else
'ok so they're not physically equal, but they may be logically equal
'categorize the bytes as upper, lower, or binary
uC = alphaClass (a)
vC = alphaClass (b)
'check for relative equality
if (uC = UPPERCASE and vC = LOWERCASE) then
if (b - a) = 32 then
BytesEqual = true
end if
end if
if (uC = LOWERCASE and vC = UPPERCASE) then
if (a - b) = 32 then
BytesEqual = true
end if
end if
end if
'---------------------------------------------
End Function
'---------------------------------------------
Function alphaClass (c)
'---------------------------------------------
' Classify a byte as being
' ASCII uppercase, lowercase, or other
'---------------------------------------------
alphaClass = BINDATA
if (c < 123 and c > 96) then
alphaClass = LOWERCASE
end if
if (c < 91 and c > 64) then
alphaClass = UPPERCASE
end if
'---------------------------------------------
End Function
'---------------------------------------------
'---------------------------------------------------------
sub MapDrive(letter, where)
'---------------------------------------------------------
'map a drive presistently
driveLetter = letter
'on error resume next
oNetwork.RemoveNetworkDrive driveLetter, true, true
oNetwork.MapNetworkDrive driveLetter, where, true
'on error goto 0
end sub
'---------------------------------------------------------
sub sanitizeNetworkDrives
'---------------------------------------------------------
'replace the network drive paths to old dfs shares with new ones.
set collDrives = oNetwork.EnumNetworkDrives
for w = 0 to collDrives.Count -1 step 2
driveLett = collDrives.Item(w)
drivePath = collDrives.Item(w + 1)
newPath = sanitizeDrivePath ( drivePath )
MapDrive driveLett, newPath
next
end sub
'---------------------------------------------------------
function sanitizeDrivePath ( dirty )
'---------------------------------------------------------
' fix the paths themselves against our list of replacements
tempString = lcase(dirty)
for each key in oReplacements.Keys
pattStr = key
replaceStr = oReplacements.Item(key)
tempString = replace( tempString, pattStr, replaceStr )
next
sanitizeDrivePath = tempString
'---------------------------------------------------------
end function
'---------------------------------------------------------
date: 29 Sep 2005 12:10:04 -0700
author: aldousd666
