Страницы: 1
RSS
Макрос автоматической печати jpg
 
Есть файл jpg, а на листе гиперссылка на этот файл. Подскажите пожалуйста кто знает макрос с привязкой к кнопке на запуск печати данного файла без лишних телодвижений.
 
вот такой макрос получится:

Код
Private Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                                         ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
                                         ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub МакросПечати()
    On Error Resume Next
    ' допустим, ссылка в ячейке A1 находится
    Filename$ = Range("a1").Hyperlinks(1).Address
    If Filename$ = "" Then MsgBox "Нет ссылки в ячейке", vbCritical: Exit Sub

    ' если ссылка относительная - надо еще путь к папке дописать.
    ' это уже сами доделаете в коде

    ' вызов команды печати файла
    Call apiShellExecute(Application.hwnd, "print", Filename$, vbNullString, vbNullString, 0)
End Sub
 
http://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=8&TID=10144
Код
With Worksheets.Add   
       Set Картинка = .Pictures.Insert(ПутьКФайлу)   
       With .PageSetup   
           .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = 1   
           .Orientation = IIf(Картинка.Height >= Картинка.Width, xlPortrait, xlLandscape)   
       End With   
       .PrintPreview   
       ' если такой вариант устроит, замените .PrintPreview на .PrintOut   
   End With   
End Sub   
 
Игорь, в ячейке А1 c:\Users\User\Downloads\1111.jpg выдает сообщение "Нет ссылки в ячейке". Что делаю не то?
 
Цитата
Dobepman написал:
"Нет ссылки в ячейке". Что делаю не то?
Не внимательно читаете сообщение об ошибке. В ячейке А1 у вас нет
Цитата
Dobepman написал:
а на листе гиперссылка на этот файл
 
Подскажите пожалуйста что я делаю не так?
 
замените строку
Код
Filename$ = Range("a1").Hyperlinks(1).Address

на строку
Код
Filename$ = Range("a1").Text
 
Класс. Работает. Спасибо.  
 
Игорь, Как исправить подскажите пожалуйста.
 
Замените строку
Код
Private Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                                         ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
                                         ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long


на следующий код:
Код
#If VBA7 Then
    Private Declare PtrSafe Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
            ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
            ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                                          ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
                                          ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If
 
Спасибо. Подскажите пожалуйста как добавить сообщение которое будет появляется когда не существует папка.
 
Например
Код
    '...
    If Filename$ = "" Then MsgBox "Нет ссылки в ячейке", vbCritical: Exit Sub
    'Когда нет папки
    If Dir(Left(Filename$, InStrRev(Filename$, "\", -1, 1) - 1), vbDirectory) = "" Then MsgBox "Нет папки", vbCritical: Exit Sub
    '...
 
ocet p,работает, спасибо за помощь
 
Подскажите пожалуйста как печатать два и более файла с помощью этого кода
Код
Private Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                                         ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
                                         ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Sub МакросПечати()
    On Error Resume Next
    ' допустим, ссылка в ячейке A1 находится
    Filename$ = Range("a1").Hyperlinks(1).Address
    If Filename$ = "" Then MsgBox "Нет ссылки в ячейке", vbCritical: Exit Sub
 
    ' если ссылка относительная - надо еще путь к папке дописать.
    ' это уже сами доделаете в коде
 
    ' вызов команды печати файла
    Call apiShellExecute(Application.hwnd, "print", Filename$, vbNullString, vbNullString, 0)
End Sub
 
Цитата
как печатать два и более файла с помощью этого кода
никак
макрос не обладает телепатическими способностями, и потому не может знать, какие файлы надо печатать (где брать эти файлы)
 
Цитата
Игорь написал: макрос не обладает телепатическими способностями
Попробую я угадать
Код
Sub МакросПечати()
Dim iCell As Range
On Error Resume Next
'допустим, ссылки в диапазоне A1:A10
For Each iCell In Range("A1:A10").Cells
    If iCell.Hyperlinks.Count > 0 Then
        Filename$ = iCell.Hyperlinks(1).Address
        
        'если ссылка относительная - надо еще путь к папке дописать.
        'это уже сами доделаете в коде

        'вызов команды печати файла
        Call apiShellExecute(Application.Hwnd, "print", Filename$, vbNullString, vbNullString, 0)
    End If
Next
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Спасибо. Работает. Но не так как планировалось. Как будто усер находится в директории выделяет два файла jpg и отправляет на печать. В результате одно окно печати на два файла. Такова цель. Это удобно при двусторонней печати. А макрос открывает на каждый файл отдельное окно печати.  
 
Цитата
Dobepman написал: Как будто усер находится в директории выделяет два файла jpg и отправляет на печать.
Тогда Вам Excel не нужен
Выделить файлы в папке - ПКМ - Печать
Изменено: Sanja - 19.07.2019 09:29:11
Согласие есть продукт при полном непротивлении сторон
 
Sanja, макросом быстрее и удобнее. Макросы призваны облегчить нашу рутиную работу.

Не ужели нет способа?
Страницы: 1
Наверх