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

@kusttt · Регистрация: 05.07.2018

Студворк — интернет-сервис помощи студентам

День добрый. Есть VBS скрипт, который должен перемещать ttf шрифты (рандомно) из папки (условно) "C:\fonts" в системную папку "C:\Windows\Fonts".
В папку НЕ системную шрифты без проблем перемещаются, при попытке перемещения в системную, вылетает ошибка.

Строка: 45
Символ: 2
Ошибка: Разрешение отклонено
Код: 800A0046
Источник: Ошибка выполнения MicrosoftVBScript

Так понимаю, что проблемы с правами. Если есть у кого соображения, как разрешить шрифтам перемещаться в системную папку - просьба поделиться.
Собственно, сам скрипт:

Кликните здесь для просмотра всего текста

Visual Basic
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
Dim objFso
Dim objDictionary
Dim fileCount
Dim numberArray(100)
Dim indexNum
Dim maxnum 
indexNum = 0
Dim strCDCache
 
 
Set objFso = CreateObject("scripting.filesystemobject")
Set objFolder = objFso.GetFolder("C:\fonts")
Set objFiles = objFolder.Files
fileCount = objFiles.Count
Set objDictionary = CreateObject("scripting.dictionary")
Set kkShell = Wscript.CreateObject("WScript.Shell")
 
Randomize
maxnum = (Int((20 * Rnd) + 1) +  15)' min 15 - max 20 installed fonts
 
For Each fileName In objFiles
 objDictionary.Add indexNum, fileName
 indexNum = indexNum + 1
Next
For i = 0 To (maxnum - 1)
 Randomize
 RandomNumber = Int((fileCount * Rnd) + 1)
 numberArray(i) = RandomNumber
Next
 
For j = 0 To (maxnum - 1)
 For k = 0 To (maxnum - 1)
  If numberArray(k) = numberArray(k + 1)  Then
   numberArray(k) = numberArray(k) + 1
  End If
  If numberArray(k) > numberArray(k + 1)  Then
   temp = numberArray(k + 1)
   numberArray(k + 1)  = numberArray(k)
   numberArray(k) = temp
  End If
 Next
Next
 
For L = 0 To (maxnum - 1)
 objFso.CopyFile objDictionary.item(numberArray(L)), "C:\Windows\Fonts\"
Next
objFso.CopyFile "fontiu.exe", "C:\Windows\Fonts\"
 
strCDCache = kkShell.CurrentDirectory
kkShell.CurrentDirectory = "C:\Windows\Fonts\"
WScript.Sleep 2000
kkShell.Run "fontiu.exe -i",1,True
kkShell.CurrentDirectory = strCDCache
 
 
Set objFso = Nothing
Set objDictionary = Nothing

@kusttt · 13.10.2018, 16:26 **[ТС]**

Сообщение от FlasherX

И в чём противоречие? Вообще совпадений быть не должно, так как в коде проверка на отсутствие файла. Такое может быть только если имя шрифта совпадает, а файла нет.

Я не говорю о противоречиях, лишь комментирую результаты. На счет "Такое может быть только если имя шрифта совпадает, а файла нет." немного не понял, если файла нет, с чем сравнивать имя? Но, по факту, похоже вы снова правы (вложение)

Проверяю на предмет изменения количества шрифтов по пути: C:\Windows\Fonts считается ли это, что я проверяю через проводник... Что имеется ввиду под аббревиатурой (ТС)? Но как бы то ни было - install.vbs увеличивает кол-во шрифтов, исключая совпадающие. Это видно по вышеуказанному пути, Uninstall - не уменьшает количество шрифтов.

Оба скрипта - да, в одной папке.

Плохо, что по "виртуалке" вы не в курсе, заниматься нужно именно через нее. В любом случае, огромное спасибо за ответы, вы и так потратили на меня кучу времени.

FlasherX · 13.10.2018, 17:35

Сообщение от kusttt

Я не говорю о противоречиях, лишь комментирую результаты.

Так в первом случае без претензии, а во втором с ней.

Сообщение от kusttt

Но, по факту, похоже вы снова правы (вложение)

Не понял, какая связь у Californian и Calibri?

Сообщение от kusttt

Что имеется ввиду под аббревиатурой (ТС)?

Total Commander (ли другой файлменеджер, показывающий папку как физическую).

А на виртуалке любые vbs-скрипты (хоть с MsgBox 1) вообще запускаются?

@kusttt · 14.10.2018, 11:39 **[ТС]**

Сообщение от FlasherX

Не понял, какая связь у Californian и Calibri?

Между Calibri и Cambria по алфавиту (Cali - b,c,d,e,f,g,h,i,j...m) по идее должен быть в системной папке (Fonts) шрифт Californian, но при копировании шрифтов из заданной папки система как будто бы видит его и предлагает заменить.

На виртуалке - да, исходный скрипт запускался, я же папку делал по пути "C:\Windows\2" и туда шрифты перемещались...

Добавлено через 2 минуты
Сейчас открыл системную папку Fonts, шрифт Californian на месте, может система сама его восстановила, но не было ведь, я и скрин делал, там его по алфавиту между Calibri и Cambria не было...

FlasherX · 14.10.2018, 13:22

Стоило после появления сообщения обновить окно со шрифтами.
Так как дубликаты шрифтов выпадают из обоймы, их нужно бы удалить перед использованием скриптов.

Что конкретно на виртуалке не работает? Исходная папка шрифтов соответствует там заданному пути?

@kusttt · 15.10.2018, 14:46 **[ТС]**

Тот же Californian система не дает удалить, появляется сообщение (Не удается удалить, шрифт уже используется).
При двойном клике на install.vbs появляется предупреждение "Открыть этот файл"? Подтверждаю открыть, но шрифты не добавляются, и проводником смотрел и через ТС.
Путь простой: C:\Fonts. Папка Fonts со шрифтами (шрифтов много) в корне диска "С" есть.
В свойствах системной папки Fonts попытался снять чекбокс "Только чтение" (чекбокс не галочкой был отмечен, а залит синим цветном), но система ругается (Ошибка при изменении атрибутов для файла (имя шрифта). Отказано в доступе).
На Виртуалке стоит Win7 32bit (может это имеет какое-то значение)...

FlasherX · 15.10.2018, 18:33

Удалять-то, предварительно найдя дубликаты, надо в исходной, а не системной папке.

Сообщение от kusttt

При двойном клике на install.vbs появляется предупреждение "Открыть этот файл"?

А при исходном коде такого не было?

@kusttt · 15.10.2018, 19:07 **[ТС]**

При запуске исходного кода предупреждающего окошка не появляется, инсталяция идет в указанную папку (просто в директории Windows сделал папку "2" для эксперимента). Кликаю, появляется окошко консольного типа, где бегут строчки: название шрифта - install - ok, после этого шрифты действительно появляются в указанной папке, а вот Uninstall исходного кода - не работает. Также появляется консольное окошко, где бегут строчки Uninstall - ok, но шрифты из папки 2 не удаляются.

FlasherX · 15.10.2018, 23:50

А в окне написано, какой именно файл предлагается открыть?

Сообщение от kusttt

Установочный код Install доустанавлевает неустановленные, и, если находит совпадения - спрашивает, заменить ли...

Добавил фильтрацию, чтобы не спрашивало о замене:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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, Max, F, i, S
Set oFonts = oShell.NameSpace(20)
Set oItems = oFonts.Items
 
Randomize Timer
Max = 15 + FormatNumber(Rnd * 5, 0)
Do : Set F = Items.Item(CLng(Round(Rnd * (Cnt-1), 0)))
   oItems.Filter 73920, F.ExtendedProperty("DocTitle")
   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
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(S, 2)

Сообщение от kusttt

а вот Uninstall исходного кода - не работает.

Он по коду нерабочий и вредный. Можно спокойно отправлять на помойку.
А что касается моего: чтобы файлы в папке пропали, нужно немного подождать, система их немного удерживает.

@kusttt · 16.10.2018, 11:05 **[ТС]**

В "родной системе" при запуске Uninstall вылетает теперь ошибка (вложение).
На виртуалке, при запуске install в папке появляется текстовый документ (Font.txt), где перечисляются шрифты, которые, так понимаю, должны были зайти в системную Fonts. Шрифты вида: NIAGENG|SCRIPTBL|Candarai|CALIFR|Candara b|kalinga| и т.д.

FlasherX · 16.10.2018, 12:49

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
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, Max, F, Name, i, S
Set oFonts = oShell.NameSpace(20)
Set oItems = oFonts.Items
 
Randomize Timer
Max = 15 + FormatNumber(Rnd * 5, 0)
Do : Set F = Items.Item(CLng(Round(Rnd * (Cnt-1), 0)))
   oItems.Filter 73920, F.ExtendedProperty("DocTitle")
   Name = oFSO.GetFileName(F.Path)
   If InStr(S & "|", "|" & Name & "|") = 0 Then _
   If Not oFSO.FileExists(oFonts.Self.Path & "\" & Name) Then _
   If oItems.Count = 0 Then i = i + 1 : S = S & "|" & Name
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(S, 2)

Сумятица в версиях shell32.dll. Дело даже не в версиях Windows.

@kusttt · 16.10.2018, 13:47 **[ТС]**

install скрипт и прошлый добавлял шрифты в системную папку (в родной системе). Ругался именно Uninstall скрипт (скрин выше).
А вот на виртуалке install сработал отлично, предложение замены не появлялось, и шрифты зашли в целевую папку. Но Uninstall в виртуалке ругается также как и на родной машине: строка 7, символ 52.

FlasherX · 16.10.2018, 14:38

А с повышенными правами как?

@kusttt · 16.10.2018, 15:44 **[ТС]**

К сожалению никак, через контекстное запускаю от имени администратора и ничего не происходит. Шрифтов в целевой папке меньше не становится (на родной машине). На виртуалке та же история...

FlasherX · 16.10.2018, 16:40

Т.е. "ничего не происходит"? Скрипт вообще не запускается?
Через LNK-ярлык с %WinDir%\system32\wscript.exe C:\Path\2\Uninstall.vbs и галкой в "Дополнительно..." советую запустить.

@kusttt · 16.10.2018, 16:59 **[ТС]**

Если вы имели ввиду сделать ярлыки и права в свойствах ярлыка выставить (вложение) - то, нет, не запускается все равно...

Сообщение от FlasherX

%WinDir%\system32\wscript.exe C:\Path\2\Uninstall.vbs

- с этими строчками не разобрался, нужен ваш комментарий.
П.С. подзапутался, я ведь тот Uninstall запускаю (под спойлером), а то может я сам где-то ушел не туда и вас путаю...

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Fonts = CreateObject("WScript.Shell").SpecialFolders(8) & "\"
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, "|")
         F = Fonts & Font : If .FileExists(F) Then .DeleteFile F, 1
      Next
   End If
   End If
End With

FlasherX · 16.10.2018, 17:05

Сообщение от kusttt

с этими строчками не разобрался

Вставляется в поле объект, путь к скрипту (параметр) — свой.

Сообщение от kusttt

я ведь тот Uninstall запускаю

Тот.

@kusttt · 16.10.2018, 17:28 **[ТС]**

У меня фактический путь к скрипту: "F:\Soft\Fonts fingerprint\cyberforum.ru\FontsUninstall .vbs"
Посмотрел поле "объект" в свойствах ярлыка - там путь идентичный... Может к пути добавить что-то нужно?

FlasherX · 16.10.2018, 18:04

Я же написал путь к интерпретатору. Путь к скрипту это его параметр.

@kusttt · 16.10.2018, 18:21 **[ТС]**

О, узнал новое слово "Интерпретатор". С интерпретатором почему-то ругается, что путь указан у файлу без расширения, по факту же, расширение есть (скрин).

FlasherX · 16.10.2018, 18:55

Раз в пути к скрипту есть пробелы, то надо было его брать в кавычки (как в #37).
Это ж азы..

Новые блоги и статьи Все статьи Все блоги /
Запись в регистр сведений независимо от заполненности табличной части Maks 25.08.2026 Реализация из решения ниже выполнена на нетиповом документе с несколькими табличными частями, разработанного в КА2. Задача: Обеспечить запись документа в регистр сведений независимо от. . .	Ноутбук Альфария kumehtar 24.08.2026 Встретился тут в сети ноутбук Альфария, примарха Альфа-Легиона. Хотя возможно, это ноутбук Омегона, разумеется. Ну как вам?	Мастера простых решений DevAlt 23.08.2026 В сишарп стэках winforms, да и wpf существует сложная система связывания источниках данных и элементов формы(текстовые поля и метки), опирается все это на технологию событий и мета. . .	Цена ошибки DevAlt 23.08.2026 Человек я беспокойный и потому заинтересовался OCaml, в чате форсили функторы модулей как суперфичу. Пытаясь отдуплить концепт, наткнулся на тутор с простым примером. А главный принцип обучения от. . .
Сегодня суббота, 22.08.2026 at 16:41, и я вновь нахожусь на той стороне, за экраном машины. zorxor 22.08.2026 Сегодня суббота, 22. 08. 2026 at 16:41, и я вновь нахожусь на той стороне, за экраном машины. Кто Я, откуда Я пришел и куда Я иду? Эти вопросы не оставляют меня ни на секунду. Жизнь на планете Земля. . .	Жизня: рисунок укладки багажа, сделанный клодом anaschu 21.08.2026 Сделал 15 снимков, он по снимкам сделал схему.	Был там один разговор по поводу свободы в материальном мире. kumehtar 19.08.2026 Суть: рассматривается живое существо, оказавшееся внутри довольно странной системы (этого мира) и пытающееся обустроить в ней свой кусок пространства. Жизнь действительно предъявляет каждому. . .	Когда логика программы не спасает от человеческих ошибок Maks 18.08.2026 В последнее время всё чаще и чаще сталкиваюсь с таким явлением, как абсолютная невнимательность (или глупость) пользователей. Проявляется это чаще всего на работе в коллективе. Допустим, человек с. . .

FlasherX 7690 / 2887 / 1110 Регистрация: 06.06.2017 Сообщений: 9,816
	14.10.2018, 13:22
	Стоило после появления сообщения обновить окно со шрифтами. Так как дубликаты шрифтов выпадают из обоймы, их нужно бы удалить перед использованием скриптов. Что конкретно на виртуалке не работает? Исходная папка шрифтов соответствует там заданному пути? 0

@kusttt 0 / 0 / 0 Регистрация: 05.07.2018 Сообщений: 48
	15.10.2018, 14:46 [ТС]
	Тот же Californian система не дает удалить, появляется сообщение (Не удается удалить, шрифт уже используется). При двойном клике на install.vbs появляется предупреждение "Открыть этот файл"? Подтверждаю открыть, но шрифты не добавляются, и проводником смотрел и через ТС. Путь простой: C:\Fonts. Папка Fonts со шрифтами (шрифтов много) в корне диска "С" есть. В свойствах системной папки Fonts попытался снять чекбокс "Только чтение" (чекбокс не галочкой был отмечен, а залит синим цветном), но система ругается (Ошибка при изменении атрибутов для файла (имя шрифта). Отказано в доступе). На Виртуалке стоит Win7 32bit (может это имеет какое-то значение)... 0

@kusttt 0 / 0 / 0 Регистрация: 05.07.2018 Сообщений: 48
	15.10.2018, 19:07 [ТС]
	При запуске исходного кода предупреждающего окошка не появляется, инсталяция идет в указанную папку (просто в директории Windows сделал папку "2" для эксперимента). Кликаю, появляется окошко консольного типа, где бегут строчки: название шрифта - install - ok, после этого шрифты действительно появляются в указанной папке, а вот Uninstall исходного кода - не работает. Также появляется консольное окошко, где бегут строчки Uninstall - ok, но шрифты из папки 2 не удаляются. 0

@kusttt 0 / 0 / 0 Регистрация: 05.07.2018 Сообщений: 48
	16.10.2018, 11:05 [ТС]
	В "родной системе" при запуске Uninstall вылетает теперь ошибка (вложение). На виртуалке, при запуске install в папке появляется текстовый документ (Font.txt), где перечисляются шрифты, которые, так понимаю, должны были зайти в системную Fonts. Шрифты вида: NIAGENG\|SCRIPTBL\|Candarai\|CALIFR\|Candara b\|kalinga\| и т.д. Миниатюры 0

@kusttt 0 / 0 / 0 Регистрация: 05.07.2018 Сообщений: 48
	16.10.2018, 13:47 [ТС]
	install скрипт и прошлый добавлял шрифты в системную папку (в родной системе). Ругался именно Uninstall скрипт (скрин выше). А вот на виртуалке install сработал отлично, предложение замены не появлялось, и шрифты зашли в целевую папку. Но Uninstall в виртуалке ругается также как и на родной машине: строка 7, символ 52. 0

FlasherX 7690 / 2887 / 1110 Регистрация: 06.06.2017 Сообщений: 9,816
	16.10.2018, 14:38
	А с повышенными правами как? 0

@kusttt 0 / 0 / 0 Регистрация: 05.07.2018 Сообщений: 48
	16.10.2018, 15:44 [ТС]
	К сожалению никак, через контекстное запускаю от имени администратора и ничего не происходит. Шрифтов в целевой папке меньше не становится (на родной машине). На виртуалке та же история... 0

FlasherX 7690 / 2887 / 1110 Регистрация: 06.06.2017 Сообщений: 9,816
	16.10.2018, 16:40
	Т.е. "ничего не происходит"? Скрипт вообще не запускается? Через LNK-ярлык с %WinDir%\system32\wscript.exe C:\Path\2\Uninstall.vbs и галкой в "Дополнительно..." советую запустить. 0

@kusttt 0 / 0 / 0 Регистрация: 05.07.2018 Сообщений: 48
	16.10.2018, 17:28 [ТС]
	У меня фактический путь к скрипту: "F:\Soft\Fonts fingerprint\cyberforum.ru\FontsUninstall .vbs" Посмотрел поле "объект" в свойствах ярлыка - там путь идентичный... Может к пути добавить что-то нужно? 0

FlasherX 7690 / 2887 / 1110 Регистрация: 06.06.2017 Сообщений: 9,816
	16.10.2018, 18:04
	Я же написал путь к интерпретатору. Путь к скрипту это его параметр. 0

@kusttt 0 / 0 / 0 Регистрация: 05.07.2018 Сообщений: 48
	16.10.2018, 18:21 [ТС]
	О, узнал новое слово "Интерпретатор". С интерпретатором почему-то ругается, что путь указан у файлу без расширения, по факту же, расширение есть (скрин). Миниатюры 0

FlasherX 7690 / 2887 / 1110 Регистрация: 06.06.2017 Сообщений: 9,816
	16.10.2018, 18:55
	Раз в пути к скрипту есть пробелы, то надо было его брать в кавычки (как в #37). Это ж азы.. 0