На работе мы приобрели новый сервер обмена, поэтому мой начальник собирался заставить меня обойти все наши компьютеры и вручную переместить все открытые файлы PST, которые были у людей, в их папку на новом сервере. Я, по понятным причинам, решил, что проще будет это заскриптовать. После небольшого исследования я наткнулся на один такой скрипт, который требовал лишь небольшой настройки (найден здесь http://halfloaded.com/blog/logon-script-move-local-pst-files-to-network-share/), но имел много других вещи, которые мне на самом деле не нужны (проверяет, работает ли он на ноутбуке, влияет только на локальные папки и т. д.), поэтому я каннибализировал основную логику из него в свою собственную версию без большинства этих проверок работоспособности. Проблема, с которой я сталкиваюсь, заключается в том, что у меня есть два, казалось бы, идентичных цикла, которые повторяются разное количество раз, и это вызывает проблемы. Вот что у меня есть
Option Explicit
Const OverwriteExisting = True
' get username, will use later
Dim WshNetwork: Set WshNetwork = wscript.CreateObject("WScript.Network")
Dim user: user = LCase(WshNetwork.UserName)
Set WshNetwork = Nothing
' network path to write pst files to
Dim strNetworkPath : strNetworkPath = "\\server\folder\"
'Fix network path if forgot to include trailing slash...
If Not Right(strNetworkPath,1) = "\" Then strNetworkPath = strNetworkPath & "\" End If
' initiate variables and instantiate objects
Dim objOutlook, objNS, objFolder, objFSO, objFName, objTextFile, pstFiles, pstName, strPath
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile("c:\My\Desktop\pst_script_log.txt " , True)
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
Dim count : count = -1
' Enumerate PST filesand build arrays
objTextFile.Write("Enumerating PST files" & vbCrLf)
For Each objFolder in objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
pstFiles = GetPSTPath(objFolder.StoreID)
pstName = objFolder.Name
count = count + 1
objTextFile.Write(count & " " & pstFiles & vbCrLf)
ReDim Preserve arrNames(count)
arrNames(count) = pstName
ReDim Preserve arrPaths(count)
arrPaths(count) = pstFiles
objOutlook.Session.RemoveStore objFolder
End IF
Next
' closes the outlook session
objOutlook.Session.Logoff
objOutlook.Quit
Set objOutlook = Nothing
Set objNS = Nothing
' quits if no pst files were found
If count < 0 Then
wscript.echo "No PST Files Found."
wscript.Quit
End If
objTextFile.Write("moving them" & vbCrLf)
' moves the found pst files to the new location
Dim pstPath
For Each pstPath In arrPaths
On Error Resume Next
objTextFile.Write(pstPath & vbCrLf)
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
' sleep shouldn't be necessary, but was having issues believed to be related to latency
wscript.sleep 5000
'Re-open outlook
Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
'Re-map Outlook folders
For Each pstPath In arrPaths
objTextFile.Write("Remapping " & pstPath & " to " & strNetworkPath & Mid(pstPath, InStrRev(pstPath, "\") + 1) & vbCrLf)
objNS.AddStore strNetworkPath & Mid(pstPath, InStrRev(pstPath, "\") + 1)
Next
count = -1
For Each objFolder In objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
count = count + 1
objTextFile.Write("Renaming " & GetPSTPath(objFolder.StoreID) & " to " & arrNames(count) & vbCrLf)
objFolder.Name = arrNames(count)
End If
Next
objOutlook.Session.Logoff
objOutlook.Quit
objTextFile.Write("Closing Outlook instance and unmapping obj references...")
Set objFolder = Nothing
Set objTextFile = Nothing
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
Цикл нарушения находится в строках 24 и 81. Конкретная ошибка заключается в том, что счетчик увеличивается больше во втором цикле, чем в первом, однако это связано с тем, что первый цикл не выполняет свои итерации и отсутствует последний файл PST. Люди с похожими проблемами на сайте, где я нашел большую часть этого кода, сказали, что добавление функций в wscript.sleep в определенных местах помогло им, но мне не повезло в их рекомендуемых местах, и у меня сложилось впечатление, что их проблемы не такой как у меня.
Я был бы очень признателен за помощь в том, что не так в моем коде, и я открыт для предложений о способах исправления других проблем, которые я не вижу, и думаю, что есть лучший способ сделать что-то подобное.
EDI: после дополнительного исследования моей проблемы кажется, что, выполняя RemoveStore внутри цикла в строке 24, я меняю значение objNS.Folders (что имеет смысл), и чтобы избежать этого, я должен хранить элементы objFolder, которые я нужно удалить и сделать это в другом цикле. Проблема в том, что я не знаю, как это сделать, я пробовал
[line 35]
ReDim Preserve arrFolders(count)
arrFolders(count) = objFolder
End If
Next
For Each objFolder in arrFolders
objOutlook.Session.RemoveStore objFolder
Next
Однако я получаю ошибки несоответствия типов в отношении RemoveStore, поэтому я думаю, что он не хранит объект так, как ему нужно. Любые идеи?
