0

在工作中，我们选择了一个新的交换服务器，所以我的老板会让我到我们所有的计算机上，手动将人们拥有的所有打开的 PST 文件移动到他们在新服务器上的文件夹中。出于显而易见的原因，我决定编写脚本会更简单。经过一番研究，我遇到了一个这样的脚本，只需要一点调整（在这里找到http://halfloaded.com/blog/logon-script-move-local-pst-files-to-network-share/) 但还有很多其他我并不真正需要的东西（检查它是否在笔记本电脑上运行，只影响本地文件夹等），所以我将主要逻辑从它中蚕食到我自己的版本中，而没有大部分这些健全性检查。我遇到的问题是我有 2 个看似相同的循环迭代不同的次数，这会导致问题。这就是我所拥有的

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：在对我的问题进行更多研究之后，似乎通过在第 24 行的循环内执行 RemoveStore，我正在更改 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 的类型不匹配错误，因此我认为它没有按需要存储对象。有任何想法吗？

4

2 回答 2

1

FWIW - 不支持连接到网络上的 PST。请参阅http://support.microsoft.com/kb/297019/en-us和http://blogs.technet.com/b/askperf/archive/2007/01/21/network-stored-pst-files-don -t-do-it.aspx

于 2011-11-11T06:56:01.600 回答
0

所以，终于让这个工作正常（或足够接近正确）。正如 Brad 的评论中提到的，您应该在磁盘上搜索 PST 文件以及我在这里拥有的文件。此方法仅影响用户在 Outlook 中打开的 PST 文件，而不影响其计算机上的所有 PST 文件。正如我在编辑中提到的那样，发生的事情是 objOutlook.Session.RemoveStore 正在更改 objNS.Folders 的值，这会破坏我的第一个 For 循环。您需要在枚举循环之外执行此操作，否则它会中断并遗漏一些（以及在重新映射它们时错误标记一些）。此外，在该循环之外，需要将 objFolder 重新定义为 MAPIFolder 对象，否则在尝试删除工作样本时会出现类型不匹配错误：

' Enumerate PST filesand build arrays
objTextFile.Write("Enumerating PST files" & vbCrLf)
For Each objFolder in objNS.Folders
If GetPSTPath(objFolder.StoreID) <> "" Then
    count = count + 1
    pstFiles = GetPSTPath(objFolder.StoreID)
    pstName = objFolder.Name
    pstFolder = objFolder
    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

For Each pstName in arrNames
set objFolder = objNS.Folders.Item(pstName)
objNS.RemoveStore objFolder
Next
set objFolder = Nothing
于 2011-06-21T12:28:31.427 回答