仕事で新しいExchangeサーバーを選択したので、上司からすべてのコンピューターに移動して、開いているすべてのPSTファイルを新しいサーバーのフォルダーに手動で移動するように指示しました。明らかな理由で、これをスクリプト化する方が簡単だと判断しました。少し調べてみると、少し調整するだけでよいスクリプトが1つ見つかりました（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行目にあります。特定のエラーは、最初のループよりも2番目のループの方がカウントが増えることです。ただし、これは、最初のループの反復が不足していて、最後の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に関してType Mismatchエラーが発生するため、オブジェクトが必要な方法で保存されていないと思います。何か案は？