Всем Привет! В столбце "А" есть пути к файлам jpg, которые мне необходимо распечатать. На форуме я нашел пару вариантов: первый вариант второй вариант Лично мне очень понравился второй и я попытался его применить для себя:
Код
#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
Sub МакросПечати2()
Dim iCell As Range
On Error Resume Next
For Each iCell In Range("A1:A10").Cells
If iCell.Text <> "" Then
ПутьКФайлу = iCell.Text
If Len(Dir$(ПутьКФайлу)) > 0 Then
Call apiShellExecute(Application.hwnd, "print", ПутьКФайлу, vbNullString, vbNullString, 0)
Else: MsgBox "Файл " & ПутьКФайлу & " не найден", vbCritical
End If
End If
Next
End Sub
но возникли две проблемы: 1 - открывается окно печати и нужно самому нажимать "Печать" (а файлов большое количество) 2 - необходимо снять галку с "Изображение по размеру кадра"
Пытался нажать печать через Application.Wait и Application.OnKey "{ENTER}", но это совсем печально как-то. А со вторым даже не представляю как бороться.
Возможно кто-то подскажет как сделать это наиболее правильно?
БМВ, к сожалению не помогает((( может быть я что-то не так делаю?
Код
Sub МакросПечати2()
Dim iCell As Range
On Error Resume Next
For Each iCell In Range("A1:A10").Cells
If iCell.Text <> "" Then
ПутьКФайлу = iCell.Text
If Len(Dir$(ПутьКФайлу)) > 0 Then
Call apiShellExecute(Application.hwnd, "print", ПутьКФайлу, vbNullString, vbNullString, 0)
Shell ("cmd /c mspaint /p <path>")
Else: MsgBox "Файл " & ПутьКФайлу & " не найден", vbCritical
End If
End If
Next
End Sub
Sub МакросПечати2()
Dim iCell As Range
On Error Resume Next
For Each iCell In Range("A1:A10").Cells
If iCell.Text <> "" Then
ПутьКФайлу = iCell.Text
If Len(Dir$(ПутьКФайлу)) > 0 Then
Shell ("cmd /c mspaint /p """ & ПутьКФайлу """")
Else: MsgBox "Файл " & ПутьКФайлу & " не найден", vbCritical
End If
End If
Next
End Sub
еще вариант, копируем во временную папку, печатаем все файлы пачкой
Код
Sub PrintFiles()
Dim sPath As Variant
Dim sh As Object 'new Shell32.Shell
Set sh = CreateObject("shell.application")
With sh.Namespace("shell:Local AppData\Temp")
.NewFolder "jpg"
With .ParseName("jpg\").GetFolder
sh.Namespace("shell:RecycleBinFolder").MoveHere .Items(), &H14
For Each sPath In ActiveSheet.UsedRange.Columns("A").Value
.CopyHere sh.Namespace(0).ParseName(sPath), &H14
Next
.Items().InvokeVerbEx "print"
End With
End With
End Sub