Тема: VBS: Скрипт автоматической печати "всяких" документов из папки
Добрый день!
Прошу сразу не пинать, на основании данных с форума "склеил" скрипт по автоматической обработке файлов из заранее определенной папки. Код приведен ниже. Все печатает, все чистит, но возникают ошибки вовремя выполнения:
1. Когда в папке появляются несколько файлов одного типа, печать происходит 2 раза.
2. По ходу выполнения скрипта, если в папке появляется только 1 тип файлов, вылетаем ошибка при попытке удалить файлы.
собственно код:
strDir = "c:\TecT" ' каталог, за которым следим
strComputer = "." ' имя компьютера; "." означает текущий компьютер
'==============================================================================
strDirSlash = Replace(strDir, "\", "\\\\")
strNamespace = "Root\CIMV2"
' Подключаемся к пространству имен
Set objService = GetObject("WinMgmts:\\" & strComputer & "\" & strNamespace)
Set objSink = WScript.CreateObject("WbemScripting.SWbemSink", "Sink_")
objService.ExecNotificationQueryAsync objSink, _
"SELECT * FROM __InstanceCreationEvent WITHIN 5 WHERE " &_
"Targetinstance ISA 'CIM_DirectoryContainsFile' and " &_
"TargetInstance.GroupComponent= " &_
"'Win32_Directory.Name=""" & strDirSlash & """'"
' Выводим сообщение о запуске сканера
Wscript.Echo "Запущен сканер создания файла в папке " & strDir
' Запускаем бесконечный цикл ожидания
While 1
WScript.Sleep 1000
Wend
' Процедура-обработчик события OnObjectReady объекта sWbemSink
Sub Sink_OnObjectReady(oOutParams, oContext)
strResult = Date & " " & Time & vbCrLf &_
"Создан файл: " & oOutParams.TargetInstance.PartComponent
' Wscript.Echo strResult
' Печать всех файлов .doc из папки
'Option Explicit
Const wdDoNotSaveChanges = 0
Const wdPromptToSaveChanges = -2
Const wdSaveChanges = -1
Dim objWord, objExcel, objDoc, objWorkbook, objFS, objFolder, objItem, objFSO
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strDirSlash) 'Папка, из которой производится печать
Set objWord = WScript.CreateObject("Word.Application")
For Each objItem In objFolder.Files
If StrComp(objFS.GetExtensionName(objItem.Name), "doc", vbTextCompare) = 0 Then
With objWord
Set objDoc = .Documents.Open(objItem.Path, False, True, False)
objDoc.PrintOut False
Set objDoc = Nothing
End With
End If
Next
objWord.Quit
Set objWord = Nothing
' Удаление файлов
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFile "C:\TecT\*.doc", 0
' Печать всех файлов .xls из папки
'Option Explicit
Set objExcel = WScript.CreateObject("Excel.Application")
'With objExcel
' .Workbooks.Open(FileName, UpdateLinks, ReadOnly,...)
'
' UpdateLinks is:
' 0 Doesn't update any references
' 1 Updates external references but not remote references
' 2 Updates remote references but not external references
' 3 Updates both remote and external references
'
' or .AskToUpdateLinks = False
' Теоретически возможно появление и других непредусмотренных диалогов
' Возможно, в этом случае стоит поиграться со свойством Application.DisplayAlerts
'Set objWorkbook = .Workbooks.Open("C:\Temp\01.xls", 0, True)
'objWorkbook.PrintOut
'objWorkbook.Saved = True
For Each objItem In objFolder.Files
If StrComp(objFS.GetExtensionName(objItem.Name), "xls", vbTextCompare) = 0 Then
With objExcel
Set objWorkbook = .Workbooks.Open(objItem.Path, 0, True)
objWorkbook.PrintOut
objWorkbook.Saved = True
Set objWorkbook = Nothing
End With
End If
Next
objExcel.Quit
Set objWorkbook = Nothing
'Удаление файлов
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFile "C:\TecT\*.xls", 0
End SubКак все это можно поправить?
, коллега.
( или я "чайник" и не правильно что-то сделал.
