Jesiel, tentei mas n consegui, onde eu deveria alterar nesse codigo para alterar a pasta de
armazenamento para "X:\OUTLOOK\". Grato
'************************************************************************
'DESCRIPTION: Move only archive PSTs to network and reconfigure outlook
'WRITTEN BY: Daniel M. Jones
'DATE: October 28, 2009
'COMMENT: Adopted from move-pst-to-networks by Mark Chamberlain
'************************************************************************
'************************************************************************
' VARIABLE DEFINITION
'************************************************************************
set objFSO = CreateObject("Scripting.FileSystemObject")
set objNetwork = WScript.CreateObject("WScript.Network")
set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
strUser = lcase(objNetwork.UserName)
strNetworkPath = "c:\temp\archive\" '"\\server\" & strUser & "\OutlookPST\"
'************************************************************************
' FUNCTIONS
'************************************************************************
function getStore(strHexID)
for i = 1 to len(strHexID) step 2
strSubString = mid(strHexID, i, 2)
if (strSubString <> "00") then
strPath = strPath & chrw("&H" & strSubString)
end if
next
if (inStr(strPath, ":\")) then getStore = mid(strPath, inStr(strPath,":\") - 1)
if (inStr(strPath, "\\")) then getStore = mid(strPath, inStr(strPath,"\\") - 1)
end function
'************************************************************************
' BEGIN
'************************************************************************
set dicPaths = CreateObject("Scripting.Dictionary")
set dicExcludedPaths = CreateObject("Scripting.Dictionary")
set objOutlook = CreateObject("Outlook.Application")
set objNS = objOutlook.GetNamespace("MAPI")
'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)
if (objStore.Name = "Archive Folders") then
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
next
else
dicExcludedPaths.Add strStoreFile, strPath
end if
next
'Exclude non-archive PST paths
for each strKey in dicExcludedPaths.Keys
if (dicPaths.Exists(strKey)) then
dicPaths.Remove(strKey)
end if
next
'kill outlook
objOutlook.Session.Logoff
objOutlook.Quit
set colProcesses = objWMI.ExecQuery("Select * from Win32_Process where Name='OUTLOOK.EXE'")
for each objProcess in colProcesses
objProcess.Terminate()
next
wscript.sleep 2000
'Copy PST to network and add to new store
set objOutlook = CreateObject("Outlook.Application")
set objNS = objOutlook.GetNamespace("MAPI")
for each strKey in dicPaths.Keys
strPath = dicPaths(strKey)
objFSO.CopyFile strPath, strNetworkPath
strFileName = mid(strPath, inStrRev(strPath, "\") + 1)
objNS.AddStore strNetworkPath & strFileName
next
objOutlook.Session.Logoff
objOutlook.Quit
msgbox "done"
