VBS cкрипт изменяет шрифт во всех doc файлы в папке

Задача: Дана директория, в ней находятся doc файлы. Изменить каждый файл, установив для всех одинаковый шрифт и размер.

Решение:


‘Переменные и константы
Public strPath ’Патч текущих диска, папки, подпапки
Public strSeparator ‘Строка-разделитель списка
Public strSpace ‘Строка с заданным количеством пробелов
Public strBuffer ’Строка-накопитель сведений о папках, файлах
Dim strFileName ‘Имя файла отчета
Const strHead = «Выберите диск или папку:»

‘объектные переменные
Dim objShell
Dim objDialogFolder
Dim objDialogFolderItem
Dim objFolder
Dim objFolderItem
Dim objFSO
‘инициализация переменных
strSeparator = String(40, «-»)
strSpace = Space(3)
‘————————————————————–
‘Формируем диалоговое окно «Обзор папок»
Set objShell = CreateObject(«Shell.Application») ‘Объект Shell
Set objDialogFolder = objShell.Namespace(&H11&) ’Name_Space = «Мой компьютер»,
Set objDialogFolderItem = objDialogFolder.Self ‘и устанавливаем по умолчанию в диал.окне
strPath = objDialogFolderItem.Path

‘Выводим диалоговое окно «Обзор папок»
Set objFolder = objShell.BrowseForFolder(0,strHead,0,strPath)

‘Если ничего не выбрано – завершаем скрипт
If objFolder Is Nothing Then
Wscript.Quit
End If

‘Если пользователь выбрал диск или папку:
»получаем патч из диалога
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path

»создаем File System Object
Set objFSO = CreateObject(«Scripting.FileSystemObject»)

»проверяем доступность указанного ресурса
If objFSO.FolderExists(strPath) = False Then
MsgBox «Нет доступа к ресурсу »» & strPath & «»»,_
vbOkOnly + vbCritical, strPath
Wscript.Quit
End If

»вызываем функцию прохода по каталогам и файлам
dhGetListFolderFile(strPath)
‘Уничтожаем объекты
Set objShell = Nothing
Set objDialogFolder = Nothing
Set objDialogFolderItem = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set objFSO = Nothing

‘Сообщаем о выполнении
MsgBox «Все файлы поправлены!»

‘————————————————————–
‘ FUNCTION’S
‘————————————————————–
Function dhGetListFolderFile(strFolderName)
‘Функция прохода по каталогам и файлам
Dim dFolder, dFile, dSubFolder, strExt, objFSO
‘получаем патч каталога
Set objFSO = WScript.CreateObject(«Scripting.FileSystemObject»)
Set dFolder = objFSO.GetFolder(strFolderName)
‘проходим файлы текущего каталога
For Each dFile In dFolder.Files
if (InStr(1,dFile.Type,»Word»)) > 0 then
strBuffer = strFolderName & «\» & dFile.Name
Set objWord = CreateObject(«Word.Application»)
objWord.Visible = False
Set objDoc = objWord.Documents.Open(strBuffer)
Set objSelection = objWord.Selection
objSelection.WholeStory
objSelection.Font.Size = 12
objSelection.Font.Name = «Microsoft Sans Serif»
objSelection.Font.Bold = wdToggle
‘objSelection.Font.Bold = wdToggle
objSelection.Font.Italic = wdToggle
‘objSelection.Font.Italic = wdToggle
objSelection.Font.UnderlineColor = wdColorAutomatic
objSelection.Font.Underline = wdUnderlineNone
objDoc.Save
objWord.Quit
end if
Next
End Function
  • 0
  • 29 октября 2011, 13:15
  • admin

Комментарии (0)

RSS свернуть / развернуть
Только зарегистрированные и авторизованные пользователи могут оставлять комментарии.
Яндекс.Метрика