Option Explicit
Dim o, oShell, nConfirm
Set o = WScript.Application
o.Interactive = True
Set oShell = CreateObject("WScript.Shell")
nConfirm = oShell.Popup("Do you want to remove Windows Update Uninstall Files?", 0, "Remove Windows Update Uninstall Files", 4 + 32)
If nConfirm = 7 Then
    o.Quit 0
End If
Dim oFSO, sWinDir, oFolder, oDictionary, oSubFolder, sFolderName, sFolderPath, sUpdateName, sDeleted
Set oFSO = CreateObject("Scripting.FileSystemObject")
sWinDir = oFSO.GetSpecialFolder(0)
sDeleted = vbNullString
Set oFolder = oFSO.GetFolder(sWinDir)
Set oDictionary = CreateObject("Scripting.Dictionary")
For Each oSubFolder In oFolder.SubFolders
    sFolderName = LCase(oSubFolder.Name)
    sFolderPath = LCase(oSubFolder.Path)
    If Left(sFolderName, 12) = "$ntuninstall" And Mid(sFolderName, 13, 2) = "kb" Or Mid(sFolderName, 13, 2) = "q" Then
        sUpdateName = Mid(sFolderName, 13, Len(sFolderName) - 13)
        oDictionary.Add sUpdateName, sFolderPath
    End If
Next
For Each sUpdateName in oDictionary.Keys
    sDeleted = sDeleted & vbCrLF & sUpdateName
    sFolderPath = oDictionary.Item(sUpdateName)
On Error Resume Next
    oShell.RegDelete "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" & sUpdateName & "\"
On Error Goto 0
    oShell.Run "%ComSpec% /C RD /S /Q " & Chr(34) & sFolderPath & Chr(34), 0, True
Next
If Len(sDeleted) > 0 Then
    MsgBox "The uninstall data for the following updates are now removed:" & vbCrLf & UCase(sDeleted), vbOKOnly + vbInformation, "Files Removed"
    sDeleted = vbNullString
Else
    MsgBox "No Windows Update Folders found for removal", vbOKOnly + vbInformation, "Nothing To Do"
End If
o.Quit 0