Отбор файлов по списку и вывод на печать - VB
Формулировка задачи:
Помогите автоматизировать задачу
Есть список фрагментов названий файлов (колонка в Excel), по нему нужно искать файлы в заданном каталоге и выводить на печать найденные.Ссылка (битая) удалена
нашел частичное решение задачи, но ни как не получается переделать.
Решение задачи: «Отбор файлов по списку и вывод на печать»
textual
Листинг программы
Option Explicit
Const inputFolder = "C:\temp\" 'корневая папка
Const logName = "log.txt" 'будет создан или дополнен в inputFolder
Dim folderCount As Long, stbar As Boolean, startTime As Date
Dim frags() As String, fragsCount As Long
Dim miDoc As Object, ff As Integer
Sub Alexanderr()
Dim x As Range, i As Long
'формируем массив со строками для сравнения
Set x = Range("A1").End(xlDown)
If x = "" Then x = Range("A1") 'в списке одно значение
fragsCount = x.Row
ReDim frags(fragsCount)
For i = 1 To fragsCount
frags(i) = "*" & Cells(i, 1) & "*"
Next
Set miDoc = CreateObject("modi.document")
ff = FreeFile
Open inputFolder & logName For Append As ff
startTime = Time
folderCount = 0
stbar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Print #ff, "******* начало печати файлов " & Date & " " & Time
' запускает процесс с исходной папки
processFolder inputFolder
Print #ff, "******* конец печати файлов " & Date & " " & Time & _
", папок " & folderCount & ", время " & Format(Time - startTime, "hh:mm:ss")
Close #ff
Application.DisplayStatusBar = stbar
Application.StatusBar = False
Debug.Print folderCount & Format(Time - startTime, ", hh:mm:ss")
End Sub
Private Sub processFolder(fName As String)
Dim fso As Object, file As Object, fileName As String, i As Long
folderCount = folderCount + 1
Application.StatusBar = folderCount & " " & fName
Set fso = CreateObject("scripting.filesystemobject")
Set fso = fso.getfolder(fName)
' Для каждого файла в папке ...
For Each file In fso.Files
fileName = file.Name
For i = 1 To fragsCount
' Если значение ячейки содержится в имени файла, то в файл-лог выводится путь к файлу,
' файл распечатывается
If fileName Like frags(i) Then
Print #ff, file.Path,
On Error Resume Next
miDoc.Create file.Path
If Err Then
Err.Clear
Print #ff, "ERROR"
Else
Print #ff, "OK"
miDoc.PrintOut
End If
Exit For
End If
Next
Next
' Для каждой подпапки в папке просто вызывается эта же подпрограмма!
For Each file In fso.subfolders
processFolder file.Path
Next
End Sub