Форум программистов, компьютерный форум, киберфорум
MS Office Excel
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.93/58: Рейтинг темы: голосов - 58, средняя оценка - 4.93
32 / 32 / 3
Регистрация: 22.10.2012
Сообщений: 478
1

Массовая печать файлов

29.10.2014, 17:44. Просмотров 11361. Ответов 10
Метки нет (Все метки)

Добрый день. Вопрос возможно уже поднимался. Но надеюсь мою тему не затрут.
Вопрос следующий.
Как осуществить массовую печать файлов.
Т.е. есть папка в ней много файлов, от 100+
Их все нужно отправить на печать. Windows умеет за раз отправлять не более 15 файлов. Но процесс нужно автоматизировать + проблема в том что файлы создаются как .xls а используются офисы 2010-2013. И на некоторых машинах происходит пересчет формул. И он просит сохранить изменения при выходе.

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

Нашел такой вариант, но он только открывает файлы, на печать не отправляет.

Код
for %%a in (*.xls) do start /wait excel.exe "%%a" /q /n /mFilePrintDefault /mFileExit
0
Лучшие ответы (1)
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
29.10.2014, 17:44
Ответы с готовыми решениями:

Массовая или выборочная печать файлов Excel
Здравствуйте! Скажите пожалуйста, как сделать такую программку, в которую грузится список...

Массовая загрузка файлов
Нельзя ли как загрузить сразу 2 файла одним кодом? var http: TIdHTTP; Stream: TMemoryStream;...

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

Массовая смена расширения файлов
Здравствуйте ув форумчане. Подскажите как можно сменить расширение всех dat файлов в каталоге на...

10
Заблокирован
30.10.2014, 08:31 2
Открытие всех файлов находящихся в папке
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub FreeBooksOpen()
    Dim MyName As String
    Dim MyPath As String
        MyPath = "D:\Drink\"
        MyName = Dir(MyPath & "*.xls")
         Do While MyName <> ""
            Excel.Application.Workbooks.Open MyName
 
            activeworkbook.printout '([From], [To], [Copies], [Preview], [ActivePrinter], [PrintToFile], [Collate], [PrToFileName])'параметры задайте сами
            activeworkbook.close false
            
            MyName = Dir
         Loop
End Sub
0
32 / 32 / 3
Регистрация: 22.10.2012
Сообщений: 478
30.10.2014, 13:01  [ТС] 3
Видимо я чего то недопонимаю.
Вроде все сделал как нужно, запускаю макрос, а ничего не происходит.
Пока без печати, но он даже файлы не открывает. Ошибок тоже нету.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Sub FreeBooksOpen()
    Dim MyName As String
    Dim MyPath As String
    Dim sPath As String ' тут вставил
        MyPath = "C:\Users\boomer\Desktop\1\"
        MyName = Dir(MyPath & "*.xls")
         Do While MyName <> ""
            sPath = MyPath + MyName ' тут вставил
            Excel.Application.Workbooks.Open sPath ' тут изменил
            MyName = Dir
         Loop
End Sub
Пример взят из темы что рекомендовали выше. Изменен только путь до папки с файлами.
Ofice 2013
0
Заблокирован
30.10.2014, 13:16 4
Видимо нет файлов с расширением .xls в указанной папке?

Добавлено через 55 секунд
Попробуйте пошагово [F8] пройтись.
0
32 / 32 / 3
Регистрация: 22.10.2012
Сообщений: 478
30.10.2014, 14:33  [ТС] 5
Вот так вроде работает.
Но файл открывает сам себя. Другие не открывает.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Sub FreeBooksOpen()
    Dim MyName As String
    Dim MyPath As String
    Dim sPath As String
        MyPath = "C:\Users\bommer\Desktop\1\"
        MyName = Dir(MyPath & "*.xls")
         Do While MyName <> ""
            sPath = MyPath + MyName
            Excel.Application.Workbooks.Open sPath
            MyName = Dir(MyPath & "*.xls")
         Loop
End Sub
0
Заблокирован
30.10.2014, 14:37 6
Visual Basic
1
2
3
4
5
         Do While MyName <> ""
            sPath = MyPath + MyName
            if myname<>thisworkbook.name then            Excel.Application.Workbooks.Open sPath
            MyName = Dir '?(MyPath & "*.xls")-убрать!
         Loop
0
32 / 32 / 3
Регистрация: 22.10.2012
Сообщений: 478
30.10.2014, 14:59  [ТС] 7
После открытия файла, код сбрасывается на начало, т.е. не зацикливается.
Мб я нетуда вписал макрос?
Microsoft Excel Objects -> Эта книга

Добавлено через 9 минут
Сделал как ты написал в 6 сообщение. Вроде работает, но не отображается на экране. Щас попробую с печатью сделать.

Добавлено через 5 минут
Вот при таком варианте работает.
но файлы проименованы так name1.xls name2.xls и т.д. и печатает не попорядку
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub FreeBooksOpen()
    Dim MyName As String
    Dim MyPath As String
    Dim sPath As String
        MyPath = "C:\Users\bommer\Desktop\1\"
        MyName = Dir(MyPath & "*.xls")
         Do While MyName <> ""
            sPath = MyPath + MyName
            If MyName <> ThisWorkbook.Name Then
                Excel.Application.Workbooks.Open sPath
                ActiveWorkbook.PrintOut 1, 1, 1, False, "HP LaserJet Professional M1212nf MFP"
                ActiveWorkbook.Close False
            End If
            MyName = Dir
         Loop
End Sub
Добавлено через 6 минут
т.е. печатает так name1.xls name10.xls и т.д. потом name2.xls name20.xls и т.д.
0
Заблокирован
30.10.2014, 15:07 8
Лучший ответ Сообщение было отмечено Don1172005 как решение

Решение

Цитата Сообщение от Don1172005 Посмотреть сообщение
файлы проименованы так name1.xls name2.xls и т.д. и печатает не попорядку
А как? Name1, потом Name10 ?

Добавлено через 2 минуты
Называйте файлы по принципу Name001, Name002, Name003, ... , Name999,
иначе будете извращаться с сортировкой.

Добавлено через 4 минуты
Ещё вариант -
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub FreeBooksOpen()
    Dim MyName As String
    Dim MyPath As String
    Dim sPath As String
    dim i as long
    for i=1to 999
      if dir("C:\Users\bommer\Desktop\1\Name" & i & ".xls")>""then
                Excel.Application.Workbooks.Open "C:\Users\bommer\Desktop\1\Name" & i & ".xls"
                ActiveWorkbook.PrintOut 1, 1, 1, False, "HP LaserJet Professional M1212nf MFP"
                ActiveWorkbook.Close False
      else
        exit for
      endif
    next i
End Sub
1
32 / 32 / 3
Регистрация: 22.10.2012
Сообщений: 478
30.10.2014, 15:19  [ТС] 9
Круть, работает спасибо большое Про перебор не подумал что то.
0
32 / 32 / 3
Регистрация: 22.10.2012
Сообщений: 478
05.11.2014, 23:56  [ТС] 10
Возвращаясь к моим баранам. Все работает прекрасно, но теперь людей не устраивает скорость печати.
Если на принтер xerox 5330 он печатает нормально. Т.к. из очереди печати все идет сразу в память принтера и все ок.
То с xerox 3325 и других менее глобальных принтеров. Печать происходит по 1 странице раз в 30 сек.
И тут у меня родилась идея, слить все книги в один лист и пустить на печать цельным куском. Тогда на печать должно уходить цельным файлом и нормально печататься. Но возникли свои проблемы.
Взять например скрипт. Нашел в интернете. Он работает но не сохраняет форматирование. Т.е. он копирует данные, цвета, но объединения и размеры ячеек он некопирует
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
58
59
60
61
62
63
Sub FiziK()
 
Dim strStartDir As String
Dim strSaveDir As String
Dim blInsertNames As Boolean
 
strStartDir = ThisWorkbook.Path  'папка, с которой начать обзор файлов
strSaveDir = ThisWorkbook.Path & "\result" 'папка, в которую будет предложено сохранить результат
blInsertNames = True  'вставлять строку заголовка (книга, лист) перед содержимым листа
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
 
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
 
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            shSrc.UsedRange.Copy
            clTarget.PasteSpecial xlPasteAll 'Это уже вписал я, т.к. без этого просто данные вставлял.
        End If
    Next
    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
 
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
    GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub
Добавлено через 7 минут
ну и желательно что бы каждый лист добавлялся по области печати. Как то так. Пока сижу сам читаю описание всяких функций, но не особо въежаю

Добавлено через 2 часа 50 минут
Ну ни в какую не копирует он форматирование таблицы

Добавлено через 21 минуту
Сделал вот так, 2 вставки данных. В целом вроде все ок, но не копирует высоту строки только ширину столбца
Кликните здесь для просмотра всего текста

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
58
59
60
61
62
63
64
65
Sub FiziK()
 
Dim strStartDir As String
Dim strSaveDir As String
Dim blInsertNames As Boolean
 
strStartDir = ThisWorkbook.Path  'папка, с которой начать обзор файлов
strSaveDir = ThisWorkbook.Path & "\result" 'папка, в которую будет предложено сохранить результат
blInsertNames = False  'вставлять строку заголовка (книга, лист) перед содержимым листа
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
 
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
 
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("B2").Offset(shTarget.Range("B2").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            shSrc.UsedRange.Copy 'clTarget
            
            clTarget.PasteSpecial xlPasteColumnWidths
            clTarget.PasteSpecial xlPasteAllUsingSourceTheme
        End If
    Next
    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
 
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
    GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub
0
32 / 32 / 3
Регистрация: 22.10.2012
Сообщений: 478
07.11.2014, 09:36  [ТС] 11
Ну объединять книги в 1 без ломания форматирования так и не получлиось.
Зато настроил нормально печать. Дело оказалось в драйвере PS, поставил PCL и все пошло в разы быстрее.
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
07.11.2014, 09:36

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь.

Автоматизация снятия пароля в Word (массовая операция для множества файлов)
Уважаемые форумчане! Существует такая задача. Имеется порядка 7000 файлов word с расширение .doc...

Массовая доля О2 в смеси оксида цинка и сульфата цинка составляет 28,35%. Чему равна массовая доля
вроде бы задача и простая, но она меня заводит в тупик. массовая доля кислорода в смеси оксида...

Печать PDF файлов
Добрый день! Подскажите, каким образом можно распечатать PDF файл? Использую этот код в Windows: ...

Печать Excel файлов
Здравствуйте. Может кто-нибудь сталкивался с потребностью отправки файла на печать? Я генерирую...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
11
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2020, vBulletin Solutions, Inc.