Страницы: 1 2 След.
RSS
Печать pdf файлов по гиперссылке макросом, печать без открытия файлов
 
Добрый день уважаемые знатоки VBA

Есть задача - необходимо при нажатии на кнопку Печать на листе, чтобы макрос отправлял на печать pdf файлы, ссылки на которые размещены в столбце А.
Я написал макрос и все работает и печатает, но макрос открывает каждый файл по отдельности, что очень не удобно, особенно если файлов 20 и более.
Код
Sub SetupBtn()
    ActiveSheet.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select
    PrintHyperlinkedPDFs
 
End Sub


Sub PrintHyperlinkedPDFs()

Dim PDFrng As Range, PDF As Range
Dim AdobeReader As String, pdfLINK As String
                                        'there is an extra space at the end of this string
AdobeReader = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
Set PDFrng = Selection                  'change this to whatever method you want for setting
                                        'the range of PDF link cells to process and print
For Each PDF In PDFrng
    If PDF.Hyperlinks.Count > 0 Then pdfLINK = PDF.Hyperlinks(1).Address
    Shell """" & AdobeReader & """/n /t """ & pdfLINK & """"
Next PDF

Selection.Cells(1).Select
End Sub

Есть ли возможность отправлять файлы на печать не открывая сами файлы в Adobe ?

Спасибо за ответы

P.S. гиперссылки в файле битые, т.к. у каждого на компьютере будет собственный путь.
 
Цитата
pinguindell написал: Есть ли возможность отправлять файлы на печать не открывая сами файлы в Adobe ?
Нет
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
Попробуйте вот так:
Код
Dim objShell
Set objShell = CreateObject("Shell.Application")
objShell.ShellExecute "имя_файла", "", "", "print", 0
WScript.Sleep 1000
 
marchenkoan,спасибо большое! практически то что нужно, но только мне пришлось немного адаптировать Ваш код под свой. Вот, может кому то и пригодиться:

Следующий код повесил на кнопку на листе, чтобы он выделял область ячеек с гиперссылками на файлы:
Код
Sub SetupBtn()
    ActiveSheet.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select
    PrintHyperlinkedPDFs
End Sub
затем сам код, отвечающий за печать файлов pdf по гиперссылкам:
Код
Sub PrintHyperlinkedPDFs()

Dim PDFrng As Range, PDF As Range
Dim AdobeReader As String, pdfLINK As String

Dim objShell
Set objShell = CreateObject("Shell.Application")
                                        
AdobeReader = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
Set PDFrng = Selection                                                                                               
                                        
For Each PDF In PDFrng
    If PDF.Hyperlinks.Count > 0 Then pdfLINK = PDF.Hyperlinks(1).Address
   
objShell.ShellExecute pdfLINK, "", "", "print", 0

Application.Wait Now + TimeValue("00:00:01")

Next PDF

Selection.Cells(1).Select


End Sub

ну и еще один код, который я повесил на событие закрытия книги, он позволяет при закрытии excel файла, закрыть все окна Adobe Reader, которое остались на панели задач.
Код
Sub Kill_All_PDFs()

   On Error Resume Next

    Dim objectWMI As Object
    Dim objectProcess As Object
    Dim objectProcesses As Object

    Set objectWMI = GetObject("winmgmts://.")
    Set objectProcesses = objectWMI.ExecQuery( _
        "SELECT * FROM Win32_Process WHERE Name = 'AcroRd32.exe'") '< Change if you need be


    For Each objectProcess In objectProcesses
        Call objectProcess.Terminate
    Next

    Set objectProcesses = Nothing
    Set objectWMI = Nothing
End Sub
Изменено: pinguindell - 05.08.2016 07:23:36
 
Уважаемые знатоки VBA, в очередной раз прошу Вашей помощи, в чем может быть проблема.

Макрос работает и все хорошо, но почему то печать происходит не по порядку расположения файлов в диапазоне - на печать должны идти файлы в следующей последовательности: Часть 1, Часть 2, Часть 3, Часть 4, а они идут как Часть1, Часть 4, Часть 3, Часть2

Я немного изменил код и теперь он выглядит так:
Код
Sub tt()

ActiveSheet.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select


Dim PDFrng As Range, PDF As Range
Dim AdobeReader As String, pdfLINK As String

Dim objShell
Set objShell = CreateObject("Shell.Application")
                                        'there is an extra space at the end of this string
AdobeReader = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
Set PDFrng = Selection                  'change this to whatever method you want for setting
                                        
                                        
                                        'the range of PDF link cells to process and print
For Each PDF In PDFrng
If PDF.Hyperlinks.Count > 0 Then pdfLINK = PDF.Hyperlinks(1).Address
   
objShell.ShellExecute pdfLINK, "", "", "print", 0

Application.Wait Now + TimeValue("00:00:01")


Next PDF


End Sub

В чем может быть проблема ?.
Изменено: pinguindell - 25.08.2016 12:09:05
 
Уважаемые форумчане, помогите пожалуйста с решением, мучаюсь не одну неделю ...
 
а жёстко задать счётчик не пробовали?
Код
Set sh = Activesheet
For i = 1 To Selection.Cells.Count
и в sh.Cells(i,1) - обращайтесь к гиперссылке... были примеры на форуме... и здесь: Как получить адрес гиперссылки из ячейки
p.s. ссылок в файле нет, тестить на принтере в любом случае не хочу... просто версия
Изменено: JeyCi - 04.09.2016 08:28:33
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
JeyCi,спасибо за совет. Попробовал сделать так как Вы сказали, получилось следующее (код ниже), но почему то код выдает ошибку Object required
Гиперссылки в файл добавил, нужно просто из архива извлечь папку Temp на локальный диск С
Код
Sub tt()

Dim PDFrng As Range, PDF As Range
Dim AdobeReader As String, pdfLINK As String

Dim objShell
Set objShell = CreateObject("Shell.Application")
Set sh = ActiveSheet

AdobeReader = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"


ActiveSheet.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Select
For i = 1 To Selection.Cells.Count

pdfLINK = Get_Hyperlink_Address(i)
 
objShell.ShellExecute pdfLINK, "", "", "print", 0

Application.Wait Now + TimeValue("00:00:01")


Next i

End Sub
 
Цитата
pinguindell написал:
Попробовал сделать так
Так да не так. Что Вы скармливаете функции? Значения счетчика, i. А ей надобен: ByVal rCell As Range. Ячейка то бишь. Вот она и матерится, подай ей объект анонсированный в оглавлении. Типа: pdfLINK = Get_Hyperlink_Address(Cells(i)). И еще. Что по вашему у Вас делает строка:
Код
AdobeReader = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
, да и вообще всЯ эта переменная?
Я сам - дурнее всякого примера! ...
 
Уважаемые форумчане, спасибо за Ваши советы, переписал код следующим образом, и счетчик поставил и удалил не нужное, но печать все равно идет не последовательно.
Код
Sub tt()


Dim objShell
Set objShell = CreateObject("Shell.Application")
Set sh = ActiveSheet

Set sh = ActiveSheet
For i = 1 To 5

objShell.ShellExecute sh.Cells(i, 1), "", "", "print", 0

Next i

Application.Wait Now + TimeValue("00:00:01")

End Sub

В чем теперь может быть проблема ?
 
В коде сообщения #1 в конце используйте такой вариант
Код
    If PDF.Hyperlinks.Count > 0 Then
      pdfLINK = PDF.Hyperlinks(1).Address
      Shell """" & AdobeReader & """ /p /h """ & pdfLINK & """"
    End If
 
Но, по сути, это то же самое, что делает ShellExecute, то есть проблема с очередностью останется.
Здесь есть противоречие: чтобы очередность соблюдалась, нужно дожидаться снятия занятости принтера, а это, насколько я понимаю, не удобно.
 
ZVI,попробовал использовать Ваш вариант, но почему то на печать отправляется только первый документ в списке.
В принципе проблем с печатью нет, проблема теперь в том, что макрос печатет документы не по порядку, а в разной последовательности
 
Цитата
pinguindell написал:
макрос печатет документы не по порядку, а в разной последовательности
А это критично?  
 
Юрий М, доброго дня! Слежу за темой…и в моём случае это было бы критично, т.к., например, по таблице печати может быть составлен реестр документов. В таком случае ,естественно, хотелось бы отправить на печать и потом просто положить в папку с реестром ,зная, что там всё в том же порядке.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Смысл понятен, но, как мне кажется, главная задача - именно вывод на печать - решена )) В крайнем случае не составит большого труда разложить листы в нужной последовательности ))
Припоминается, что в своё время в одном из макросов открывал циклом поочерёдно несколько файлов и тоже не мог добиться правильной очередности их открытия :-)
Уже не помню точно, но, кажется, цикл "выбирал" их в папке, исходя из сортировки по дате редактирования. Может и здесь такая же история? )
 
Юрий М, а я (так как не силён в VBA):
1. копирую папку со всеми документами в каждый раздел
2. через таблицу соответствий в Excel и Multex от Дмитрия The_Prist переименовываю (в № по порядку) файлы в каждом разделе (это же по сути и будет реестром)
3. объединяю файлы внутри каждого раздела в 1 PDF
4. объединяю разделы ещё в 1 PDF и уже этот "монстр" печатается (минут 40) и всё в строгом порядке по реестру)))) :D
Изменено: Jack Famous - 06.09.2016 15:08:06
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
pinguindell написал:  ZVI ,попробовал использовать Ваш вариант
а что насчёт этого?
Цитата
ZVI написал: чтобы очередность соблюдалась, нужно дожидаться снятия занятости принтера
я тоже думаю, что дело в этом... т.е. в #10 вы циклом запускаете всё поочерёдно по адресам из ячеек в нужной последовательности...
(1) но когда заканчивает печататься первый, то циклом уже запущен 4-й... имхо... не понятно почему вы 15-ю строку расположили в конце макроса, за циклом... если паузу делать внутри цикла, возможно будет соблюдаться нужный порядок... но размер паузы не знаю...
(2) т.к. ещё вариант объяснения - размер файла - пока принтер примет его к печати - это зависит от размера? (чем больше листов, тем дольше принтер сканируе себе в память всё, что ему надо напечатать из этого файла)?.. тогда тот же выход - паузу (возможно побольше) и внутрь цикла, чтобы всё успевало становиться в свою очередь...
как гипотеза... вы можете проверить)) я принтер мучать не буду  
Изменено: JeyCi - 06.09.2016 15:48:33
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
JeyCi права насчет паузы внутри цикла. Подберите таймаут в коде ниже:
Код
Sub Test()

  Const TIMEOUT = 2  '<-- Пауза в секундах после распечатки документа

  Dim i As Long, Sh As Worksheet, t As Single
  Set Sh = ActiveSheet
  With CreateObject("Shell.Application")
    For i = 1 To 5
      ' Печатать
      .ShellExecute Sh.Cells(i, 1).Value, "", "", "print", 0&
      ' Подождать
      t = Timer + TIMEOUT
      While Timer < t
        DoEvents
      Wend
    Next
  End With

End Sub
Изменено: ZVI - 06.09.2016 19:26:11
 
ZVI, спасибо большое. Единственный вопрос - как для Const TIMEOUT = 2  '<-- Пауза в секундах после распечатки документа

присваивать значение из ячейки ? К примеру О2 текущего листа ?
 
pinguindell, замените:
Код
Const TIMEOUT = 2
на:
Код
dim TIMEOUT
TIMEOUT = activesheet.range("О2").value

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
JayBhagavan,

изменил код на предложенный
Код
Dim TIMEOUT
TIMEOUT = ActiveSheet.Range("О1").Value
 
  Dim i As Long, Sh As Worksheet, t As Single
  Set Sh = ActiveSheet
  lastRow = ActiveSheet.Range("I" & Rows.Count).End(xlUp).Row
  
  With CreateObject("Shell.Application")
    For i = 3 To lastRow
      ' Печатать
      .ShellExecute Sh.Cells(i, 9).Value, "", "", "print", 0&
      ' Подождать
      t = Timer + TIMEOUT
      While Timer < t
        DoEvents
      Wend
    Next
  End With
  
  
Selection.Cells(1).Select



ошибка 1004 Run time error 1004 Application defined or object defined error
 
pinguindell, не видя файла и что находится в О1 - ничем не могу помочь.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
JayBhagavan,файл во вложении

папку Темр нужно поместить на диск С
 
Скрытый текст

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
У JayBhagavan в сообщении #25 правильно все написано.
Для порядка еще бы не помешало в начале записать: Dim lastRow as Long
 
Уважаемые форумчание, спасибо огромное каждому из Вас. Думаю тема актуальная и поможет многим значительно автоматизировать, ускорить и упростить работу.
 
Уважаемые модераторы!
Мне кажется, что лучше продолжить эту тему, но если сочтете более полезным открытие новой - сделаем так.

У меня тоже возникла проблема с порядком вывода на печать. Насколько я понял, очередь печати - не совсем очередь. Реализована она как стек. Из-за этого, задание, попавшее на печать раньше, но во время обработки другого, может быть обработано вообще последним!!!
Как мне привиделся выход: ожидание должно быть не фиксированным, а до тех пор, пока не закончится обработка принтером предыдущего брошенного на печать файла. Для этого нужно научиться отслеживать состояние принтера, либо наличие очереди печати.

Попытавшись сделать это самостоятельно, нашел некий код для 32-разрядной системы. Попытался исправить под 64-рязрядную. То ли криво модернизировал, то ли код вообще неподходящий, но попытка запуска вообще снесла EXCEL. Вот что у меня получилось:
Код
    Option Explicit
    Public Const STNDRD_RIGHTS_RQRD = &HF0000
    Public Const PRNTR_ACCSS_ADMIN = &H4
    Public Const PRNTR_ACCSS_USE = &H8
    Public Const PRNTR_ALL_ACCSS = STNDRD_RIGHTS_RQRD Or PRNTR_ACCSS_ADMIN Or PRNTR_ACCSS_USE
    Public Const PRNTR_CNTRL_PAUSE = 1
    Public Const PRNTR_CNTRL_RESUME = 2
    Public Const PRNTR_CNTRL_PURGE = 3
    Public Const NULL_PTR = 0&
    Public Type PRNTR_DFLTS 'pdf
        DataType As Long
        DevMode As Long
        DsrdAccess As Long
    End Type
    Public Declare PtrSafe Function OpenPrinter1 Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As PRNTR_DFLTS) As LongPtr
    Public Declare PtrSafe Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal Command As Long) As LongPtr
    Public Declare PtrSafe Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As LongPtr
    Public Enum ePrinterControl 'epc
        PrntrCntrlPause = PRNTR_CNTRL_PAUSE
        PrinterControlPurge = PRNTR_CNTRL_PURGE
        PrinterControlResume = PRNTR_CNTRL_RESUME
    End Enum
    Public Function SetPrntrStts(ByVal pstrPrntrName As String, ByVal pepcPrntrCntrl As ePrinterControl) As Boolean
        
        Dim pdfMyDflts As PRNTR_DFLTS
        Dim lngPrntrHandle As Long
        Dim lngReturn As Variant
        Dim blnReturn As Boolean
            
        pdfMyDflts.DsrdAccess = PRNTR_ALL_ACCSS
        lngReturn = OpenPrinter1(pstrPrntrName, lngPrntrHandle, pdfMyDflts)
        blnReturn = lngReturn = 0 Or lngPrntrHandle = 0 '  Не смог открыть принтер если blnReturn=False
        
        If blnReturn Then
            blnReturn = SetPrinter(lngPrntrHandle, NULL_PTR, ByVal NULL_PTR, pepcPrntrCntrl) <> 0  'Выставить статус принтера
        End If
        If blnReturn Then
            If Not lngPrntrHandle = 0 Then
                ClosePrinter lngPrntrHandle
            End If
        End If
        
        SetPrntrStts = blnReturn
        
    End Function

Sub otl()
    MsgBox SetPrntrStts("HP LaserJet 400 M401 PCL 6 (Ne07:)", PRNTR_CNTRL_PAUSE)
End Sub
Мне, конечно, интересно самому доковырять, но вопрос времени сейчас стоит остренько.

Буду благодарен как за комментарии: "Что Ади сделал неправильно", так и за любые подсказки/намеки/готовые решения проблемы отслеживания состояния принтера, позволяющие организовать "зрячее" ожидание запуска в печать следующего файла.
Следствие из третьего закона Чизхолма:
"Даже если ясность изложения исключает неверное толкование, все равно найдется кто-то, кто поймет Вас неправильно."
 
Ну вот, удалось обойтись обходным маневром без огорода API. Хоть и видел я советы, что бояться этого зверья не стоит, но не освоил еще...
В Windows, оказывается, есть папочка, в которой во время печати "рождаются" некие файлики. На моем компе это "C:\Windows\System32\spool\PRINTERS". Эксперимент показал, что при отправке на сетевой принтер с другого компа, в папочке моего компьютера ничего не рождается. Так что, мониторя наличие файлов в этой папочке, можно отслеживать исполнение именно своих заданий на печать. Чтобы пользоваться моей реализацией, до ее запуска нужно поддерживать в ней чистоту (так как проверяется рождение и последующее исчезновение любого файла в этой папке).

Я сделал печать содержимого столбца C. Легко переделать под любое другое расположение данных.
Если файлы указаны без пути, код "приделывает" к содержимому столбца "С" значение из "A1". Если в конце "A1" нет "\", программа добавит его сама.
В коде программы можно выставить константу - лимит времени в секундах, чтобы, в случае его превышения для одного задания, программа прерывалась. Я установил 5 минут (300 секунд). Желающие могут вынести это куда-нибудь на лист со считыванием оттуда.
Код
Sub Печать()
Const vTimeout As Double = 300 ' время в секундах, после которого считаем, что процесс печати не удался и следует прервать программу
Const vPrin As String = "C:\Windows\System32\spool\PRINTERS" '  папка, где очередь печати отслеживается наличием файлов
Dim pApka As String
Dim i As Long, d As Single, t As Single
Dim tMp As Variant
Dim fLg As Boolean

    
  If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub
  If ActiveSheet.Name <> "Печ" Then Exit Sub
  
  pApka = ActiveSheet.Range("A1").Value
  If Right(pApka, 1) <> "\" Then pApka = pApka & "\"
  Columns("D:D").ClearContents
  i = 1
  With CreateObject("Shell.Application")
    Do While Len(Cells(i, 3).Value)
      tMp = Cells(i, 3).Value
      If (Len(Dir(tMp)) = 0) Then Cells(i, 4).Value = "Файл не найден": GoTo NxtCCL
      If (InStr(1, tMp, "\") = 0) Then tMp = pApka & tMp
      ' Ждать очищения очереди печати.
      d = Date
      t = Timer + vTimeout
      Do
        DoEvents
        If (Len(Dir(vPrin & "\*.*")) = 0) Then Exit Do
        If ((Date - d) * 86400 + Timer) > t Then ActiveSheet.Cells(i, 4).Value = "Прерван по истечении заданного времени ожидания": Exit Sub
      Loop
      ' Сменить выделение, чтобы было видно обрабатываемый файл.
      Cells(i, 3).Select
      ' Печатать
      .ShellExecute tMp, "", "", "print", 0&
      ' Подождать окончания печати отправленного задания
      d = Date
      t = Timer + vTimeout
      fLg = False
      Do
        DoEvents
        If Len(Dir(vPrin & "\*.*")) Then fLg = True
        If fLg And (Len(Dir(vPrin & "\*.*")) = 0) Then ActiveSheet.Cells(i, 4).Value = "Принтер принял": Exit Do
        If ((Date - d) * 86400 + Timer) > t Then ActiveSheet.Cells(i, 4).Value = "Прерван по истечении заданного времени ожидания": Exit Sub
      Loop
NxtCCL:
      i = i + 1
    Loop
  End With
 
End Sub

"Заплатка", конечно, но в умелых руках проблему решает...
Следствие из третьего закона Чизхолма:
"Даже если ясность изложения исключает неверное толкование, все равно найдется кто-то, кто поймет Вас неправильно."
 
Цитата
PerfectVam:  ПечатьPDF.xlsm  
Если установлена профессиональная версия Acrobat, и такой тест не вызывает ошибки:
Код
Sub Test()
  With CreateObject("AcroExch.App"): End With
  With CreateObject("AcroExch.AVDoc"): End With
End Sub

или, что в принципе одно и тоже, установлена ссылка: VBE - Tools - Refereces - 'Acrobat' или 'Adobe Acrobat ##.# Type Library'  (XX.X - номер версии) - OK,
то распечатать файлы PDF или их заданные страницы можно, используя метод AVDoc.PrintPagesSilent.
У меня, например, в XP устанавливалась такая ссылка (reference) на библиотеку Acrobat XI Professional: "C:\Program Files\Adobe\Acrobat 11.0\Acrobat\acrobat.tlb"
Принцип распечатки:
Код
Sub PrintPDF()
  Const f = "C:\Temp\Test.PDF"
  With CreateObject("AcroExch.App")
    With CreateObject("AcroExch.AVDoc")
      .Open f, vbNullString
      .PrintPagesSilent 0, .GetPDDoc.GetNumPages - 1, 0, False, True
    End With
    .CloseAllDocs
    .Exit
  End With
End Sub

Приведенный выше код распечатает документ PDF аналогично тому, как это может быть сделано из интерфейса Adobe. А проблема спуллинга и очередности распечатки на сетевом принтере - это действительно отдельная задача.
Изменено: ZVI - 22.08.2017 22:22:17
Страницы: 1 2 След.
Наверх