Перемещение файлов в системную папку VBS скриптом

Option Explicit : Dim oShell, Items, oFSO, Cnt
Set oShell = CreateObject("Shell.Application")
Set Items = oShell.NameSpace("C:\fonts").Items
Set oFSO = CreateObject("Scripting.FileSystemObject")
Items.Filter 73920, "*.ttf"
Cnt = Items.Count : If Cnt < 20 Then MsgBox "В папке " &_
Input & " должно быть не менее 20 ttf-файлов!", 4144 : WSH.Quit
Dim oFonts, oItems, oRExp, Max, N, F, i, S, L
Set oFonts = oShell.NameSpace(20)
Set oItems = oFonts.Items
Set oRExp  = New RegExp : oRExp.IgnoreCase = True
oRExp.Pattern = "\s(Black|(Exstra)?(Book|Bold)|Cond(ensed)?|Hairline"&_
"|Heavy|Italic|Light|Medium|Narrow|News|Normal|Oblique|Regular|[DS]" &_
"emi(Bold|Light)|Thin) ?(Regular|Italic)? ?(Bold)? ?(Oblique|Italic)?$"
 
Randomize Timer
Max = 15 + FormatNumber(Rnd * 5, 0)
Do : Set F = Items.Item(CLng(Round(Rnd * (Cnt - 1), 0)))
   N = F.ExtendedProperty("DocTitle")
   If Not oRExp.Test(N) Then N = N & ";" & N & " Regular"
   oItems.Filter 73952, N : F = oFSO.GetFileName(F.Path)
   If InStr(S & "|", "|" & F & "|") = 0 Then _
   If Not oFSO.FileExists(oFonts.Self.Path & "\" & F) Then _
   If oItems.Count = 0 Then i = i + 1 : S = S & "|" & F : L = L & "|" & N
Loop Until i = Max
Items.Filter 73920, Replace(Mid(S, 2), "|", ";")
oFonts.CopyHere Items, 5652
oFSO.CreateTextFile(oFSO.GetParentFolderName(WSH._
ScriptFullName) & "\Fonts.txt", 1).Write Mid(L, 2)

Set oShell = CreateObject("Shell.Application")
Set oItems = oShell.NameSpace(20).Items
With CreateObject("Scripting.FileSystemObject")
   List = .GetParentFolderName(WSH.ScriptFullName) & "\Fonts.txt"
   If .FileExists(List) Then
   If .GetFile(List).Size Then
      For Each Font In Split(.OpenTextFile(List).ReadLine, "|")
         oItems.Filter 73952, Font
         If oItems.Count Then S  = S  & ";" & Font
      Next
      If Len(S) Then
         oItems.Filter 73952, Mid(S, 2)
         If oItems.Count Then oShell.Namespace(10).MoveHere oItems
      End If
   End If
   End If
End With

Option Explicit
Const HKLM = &H80000002
Dim oWSH, oFSO, oReg, NT, Key, Fonts, Names, Name, Value
 
Set oWSH = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oWSH.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion") > "5.1" Then NT = " NT"
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Key = "Software\Microsoft\Windows" & NT & "\CurrentVersion\Fonts"
oReg.EnumValues HKLM, Key, Names
Fonts = oWSH.SpecialFolders(8) & "\"
For Each Name In Names
   oReg.GetStringValue HKLM, Key, Name, Value
   If Not oFSO.FIleExists(Fonts & Value) Then _
   oReg.DeleteValue HKLM, Key, Name
Next
oWSH.Popup Space(23) & "Выполнено!", 2,_
"Снятие регистрации отсутствующих шрифтов      ", 4144

Set oShell = CreateObject("Shell.Application")
Set oItems = oShell.NameSpace(20).Items
Set oWSH = CreateObject("WScript.Shell")
If oWSH.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\" &_
"CurrentVersion\CurrentVersion") > "5.1" Then NT = " NT"
 
With CreateObject("Scripting.FileSystemObject")
   List = .GetParentFolderName(WSH.ScriptFullName) & "\Fonts.txt"
   If .FileExists(List) Then
   If .GetFile(List).Size Then
      On Error Resume Next
      For Each Font In Split(.OpenTextFile(List).ReadLine, "|")
         oItems.Filter 73952, Font
         If oItems.Count Then S  = S  & ";" & Font
         oWSH.RegDelete("HKLM\Software\Microsoft\Windows" &_
         NT & "\CurrentVersion\Fonts\" & Font & " (TrueType)")
      Next
      On Error GoTo 0
      If Len(S) Then
         oItems.Filter 73952, Mid(S, 2)
         If oItems.Count Then oShell.Namespace(10).MoveHere oItems
      End If
   End If
   End If
End With