Как автоматизировать печать xls без ошибок?

Question

[Илья]

Имеется скрипт для автоматической печати:

Option Explicit : Dim objWord, objDoc, wssh, objFS, objShell, objPath, objFolder, objItem

Set wssh = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objPath = objFS.GetFolder("G:\Мой диск\Печать") 'Папка, из которой производится печать

Do
  PrintDelInFolder objPath
  WScript.Sleep 3000
Loop

Sub PrintDelInFolder(objFolder)
    For Each objItem In objFolder.Files
        If StrComp(objFS.GetExtensionName(objItem.Name), "xls", vbTextCompare) = 0 Then
            	With wssh
			WScript.Sleep 1000
                	On Error Resume Next
			dim f
			f = Cstr(objItem.Path+".xls")
			objFS.MoveFile objItem.Path, f
			If err.number=0 then 
				Set objShell = CreateObject("Shell.Application")		
				objShell.ShellExecute f, "vbHide", "", "print", 0
				set objShell = nothing
				err.Clear
				Do
				WScript.Sleep 9000

                                rem
			        objFS.DeleteFile f ,true
                         rem    objFS.movefile f ,("C:\print_arhiv\")

                                rem
            			Loop While objFS.FileExists(f)
				err.Clear
			End If
			On Error Goto 0
		End With
        End If
    Next
End Sub
WScript.Quit 0

На некоторых файлах скрипт после печати вместо того чтобы удалить файл печатает его снова, прибавляя к имени файла .xls, печатает снова, и снова прибавляет .xls, получается файл вида example.xls.xls.xls.xls.xls, а его печать прекращается только с зависанием Exel либо принудительным завершением. Почему такое происходит и как с этим бороться?

Answer 1

[5465]

Проблема возникает из-за того, что скрипт перемещает файлы из папки "G:\Мой диск\Печать" в ту же папку с измененным именем. При этом, если Excel не успевает закрыть файл до следующей попытки печати, то скрипт снова перемещает файл, прибавляя к нему еще одно ".xls".

Решение этой проблемы может быть достигнуто путем создания временной папки, в которую будут перемещаться файлы перед печатью, а затем удаляться. Вот обновленный код, который использует временную папку:

Option Explicit : Dim objWord, objDoc, wssh, objFS, objShell, objPath, objFolder, objItem

Set wssh = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objPath = objFS.GetFolder("G:\Мой диск\Печать") 'Папка, из которой производится печать
Set objTempFolder = objFS.CreateFolder("G:\Мой диск\Temp") 'Временная папка для файлов перед печатью

Do
PrintDelInFolder objPath
WScript.Sleep 3000
Loop

Sub PrintDelInFolder(objFolder)
For Each objItem In objFolder.Files
If StrComp(objFS.GetExtensionName(objItem.Name), "xls", vbTextCompare) = 0 Then
With wssh
WScript.Sleep 1000
On Error Resume Next
dim f
f = Cstr(objTempFolder.Path & "" & objItem.Name)
objFS.MoveFile objItem.Path, f
If err.number=0 then
Set objShell = CreateObject("Shell.Application")
objShell.ShellExecute f, "vbHide", "", "print", 0
set objShell = nothing
err.Clear
Do
WScript.Sleep 9000
objFS.DeleteFile f ,true
Loop While objFS.FileExists(f)
err.Clear
End If
On Error Goto 0
End With
End If
Next
End Sub
WScript.Quit 0

В этом коде создается новая папка "G:\Мой диск\Temp", в которую перемещаются файлы перед печатью. После печати файлы удаляются из этой папки. Попробуйте использовать этот код и проверить, решает ли это вашу проблему.

Comments

[Илья]

Спасибо, при коротком тесте печаталось все как надо) Но уже использую другое решение, привожу его ниже)

[Илья]

Вернулся к вашему решению, с тем что я использовал и указал ниже началась та же проблема. Только немного поправил ваш код, в первой строке добавил переменную objTempFolder, и изменил
Set objTempFolder = objFS.CreateFolder("G:\Мой диск\Temp")
на
Set objTempFolder = objFS.GetFolder("G:\Мой диск\Temp")
так как при последующем запуске скрипт ругался что папка уже существует. Возможно было бы правильнее сделать проверку на наличие такой папки или удалять ее в конце каждого цикла, но на это моих навыков не хватает, еще раз спасибо)

[Илья]

К сожалению и этот вариант не сработал, сегодня показал такой же сбой и напечатал 30+ копий одного файла , обзывав каждый последующий имя.xls+temp, последний выглядел так - temptemptemptemptemptemptemptemptemptemptemptemptemptemptemptemptemptemptempИмяДокумента.xls

Answer 2

[Илья]

В итоге использую VBS скрипт с таким кодом:

Option Explicit
Dim oFSO, oDesk, oSINK, oWMI, FName, Pr
'——— Вводные ———————————————————————————————————
Const iPath = "G:\Мой диск\Печать", Ext = ".xls"
'———————————————————————————————————————————————
Set oFSO  = CreateObject("Scripting.FileSystemObject")
Set oDesk = CreateObject("Shell.Application").NameSpace(0)
Set oSINK = WSH.CreateObject("WbemScripting.SWbemSink", "SINK_")
Set oWMI  = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
oWMI.ExecNotificationQueryAsync oSINK, "SELECT TargetInstance.PartComponent FROM __InstanceCreationEvent" &_
" WITHIN 2 WHERE Targetinstance ISA 'CIM_DirectoryContainsFile' and TargetInstance.GroupComponent="  &_
"'Win32_Directory.Name=""" & Replace(iPath, "\", "\\\\") & """'"
Do: WSH.Sleep 8^10 :Loop
 
Sub SINK_OnObjectReady(oEvent, x)
   FName = Replace(Split(oEvent.TargetInstance.PartComponent, """")(1), "\\", "\")
   If LCase(Right(FName, 4)) = Ext Then
      oDesk.ParseName(FName).InvokeVerb "print"
      For Each Pr in oWMI.ExecQuery("SELECT JobCountSinceLastReset FROM Win32_Printer WHERE Default='True'")
         While Pr.JobCountSinceLastReset: WSH.Sleep 200: Wend
      Next
      oFSO.DeleteFile FName, 1
   End If
End Sub

Единственный минус - один-два раза в день скрипт прекращает работу и приходится его запускать заново.