PC上の全ユーザのOutlookプロファイルを削除するスクリプト

必要だったので作った。
VBScriptで、かなり手抜きだけど、今後のために残しておく。
ロジックは、HKEY_USERS(HKU)の下に各ユーザのハイブをロードし、 \Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles の下をごっそり削除するという単純なもの。
加えて、ログオン中のユーザのレジストリ（既にHKUにロードされているハイブ）の同エントリも削除する。

関数DeleteRegEntryはMSのKBから拝借。

?

DeleteAllOutlookProfile.vbs

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203

' DeleteAllOutlookProfile.vbs   'Const HKEY_CLASSES_ROOT  = &H80000000 'Const HKEY_CURRENT_USER  = &H80000001 Const HKEY_LOCAL_MACHINE = &H80000002 Const HKU = &H80000003   ' Shell Set shell = WScript.CreateObject("WScript.Shell") Set env = shell.Environment("PROCESS") WScript.Echo "env:" & env("ALLUSERSPROFILE") ALLUSERSPROFILE = env("ALLUSERSPROFILE")   ' Object used to get StdRegProv Namespace Set wmiLocator = CreateObject("WbemScripting.SWbemLocator")   ' Object used to determine local machine name Set wshNetwork = CreateObject("WScript.Network")   ' Registry Provider (StdRegProv) lives in ' root\default namespace. Set wmiNameSpace = wmiLocator.ConnectServer(wshNetwork.ComputerName, "root\default") Set objRegistry = wmiNameSpace.Get("StdRegProv")   ' Get WMI CIMV2 set wmiService = wmiLocator.ConnectServer(wshNetwork.ComputerName, "root\cimv2")   ' File System Object Set fso = CreateObject("Scripting.FileSystemObject")   ' Log File will be created in ALLUSERSPROFILE logFilePath = ALLUSERSPROFILE & "\DeleteOutlookProfile.txt"   ' Init log file Set logFile = fso.OpenTextFile(logFilePath, 2, True) If Err.Number <> 0 Then  WScript.Echo("ログファイル作成失敗。")  WScript.Quit End If   ' ===== ' Write Log ' Args: '  strLog  LogMessage ' ===== Sub WriteLog(strLog)  On Error Resume Next  logFile.Writeline(CStr(Now) & vbTab & strLog)  WScript.Echo CStr(Now) & vbTab & strLog  If Err.Number <> 0 Then   ' Show message and quit if it failed to write log   WScript.Echo("ログファイルの書き込みに失敗しました。")   WScript.Quit  End If  On Error Goto 0 End Sub   ' ===== ' Delete Registry Entry Recursively ' Args: '  sHive    Hive '  sEnumPath   Path ' Return: '  None ' ===== Function DeleteRegEntry(sHive, sEnumPath)  ' Attempt to delete key.  If it fails, start the subkey  ' enumration process.  lRC = objRegistry.DeleteKey(sHive, sEnumPath)    ' The deletion failed, start deleting subkeys.  If (lRC <> 0) Then     ' Subkey Enumerator     On Error Resume Next     lRC = objRegistry.EnumKey(HKU, sEnumPath, sNames)     For Each sKeyName In sNames    If Err.Number <> 0 Then Exit For    lRC = DeleteRegEntry(sHive, sEnumPath & "\" & sKeyName)   Next     On Error Goto 0     ' At this point we should have looped through all subkeys,   ' trying to delete the registry key again.   lRC = objRegistry.DeleteKey(sHive, sEnumPath)    End If    DeleteRegEntry = lRC   End Function   ' ===== ' Delete Outlook Profile Registry Key. ' Args: '  sid  SID '  hive  Hive ' Return: '  None ' =====   Sub DeleteOutlookProfile(sid, hive)  WriteLog "Sid:" & sid  ' Get AccountName from sid  set account = wmiService.Get("WIN32_SID.SID='" & sid & "'")  WriteLog "AccountName:" & account.AccountName    ' Get Outlook Profile subkey  profile = hive & "\Software\Microsoft\Windows NT\CurrentVersion\" & _   "Windows Messaging Subsystem\Profiles"  objRegistry.EnumKey HKU, profile, userSubKeys    ' Loop  if Not IsNull(userSubKeys) then   For Each userSubKey In userSubKeys    WriteLog "Outlookプロファイル " & userSubKey & " を削除します。"    WriteLog "レジストリキー: HKU" & profile & "\" & userSubKey    ' Delete key    result = DeleteRegEntry(HKU, profile & "\" & userSubKey)    If result = 0 Then     WriteLog "削除に成功しました。"    Else     WriteLog "削除に失敗しました。"    End If   Next  Else   WriteLog "Outlookプロファイルが存在しませんでした。"  End If   End Sub   ' ===== ' End Script. ' ===== Sub EndOfScript()  WriteLog "処理終了"  logFile.Close  WScript.Quit End Sub   ' ===== ' Main ' =====   ' Get all userprofiles and delete Outlook profiles   ' Get UserProfiles strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList" objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKeyPath, arrSubkeys   WriteLog "== 全ユーザのレジストリをロードし、Outlookプロファイルを削除します。 =="   ' Loop For Each objSubkey In arrSubkeys  strValueName = "ProfileImagePath"  strSubPath = strKeyPath & "\" & objSubkey  objRegistry.GetExpandedStringValue HKEY_LOCAL_MACHINE, _   strSubPath, strValueName, strValue    ' Do if sid is domain users  If Left(objSubKey, 8) = "S-1-5-21" Then     ' Load Registry Hive   writeLog "reg load HKU\hive_" & objSubKey & " """ & _    strValue & "\NTUSER.dat"""   shell.run "reg load HKU\hive_" & objSubKey & " """ & _    strValue & "\NTUSER.dat""", 0, true     ' Delete Outlook Profile   DeleteOutlookProfile objSubKey, "hive_" & objSubKey     ' Unload Registry Hive   WriteLog "reg unload HKU\hive_" & objSubKey   shell.run "reg unload HKU\hive_" & objSubKey, 0, true   WriteLog "==================================="    End If Next   ' Get logged-in users and delete Outlook profiles   ' Get HKU Subkeys objRegistry.EnumKey HKU, "", subKeys   WriteLog "== ログイン済みユーザのレジストリからOutlookプロファイルを削除します。 =="   ' Loop For Each subKey In subKeys    ' Do if sid is domain users  If Left(subKey, 8) = "S-1-5-21" and _   Right(subKey, 8) <> "_Classes" then     ' Delete Outlook Profile   DeleteOutlookProfile subKey, subKey     WriteLog "==================================="  End If Next   EndOfScript()