Sub ConvertImagesToPDF_UltimateEdition()
'==========================================================
' ULTIMATE PDF CONVERTER v2.0
' Теперь с блэкджеком и поддержкой PDF!
' Каждая картинка получает СВОЙ размер страницы.
' PDF-файлы тоже приглашены на вечеринку.
'==========================================================
Dim fd As FileDialog
Dim filesList As New Collection
Dim i As Long
Dim outputPath As String
' ---- Выбор файлов (теперь и PDF!) ----
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Выберите изображения и/или PDF"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Изображения и PDF", "*.jpg;*.jpeg;*.png;*.bmp;*.gif;*.tif;*.tiff;*.pdf"
.Filters.Add "Только изображения", "*.jpg;*.jpeg;*.png;*.bmp;*.gif;*.tif;*.tiff"
.Filters.Add "Только PDF", "*.pdf"
If .Show <> -1 Then Exit Sub
For i = 1 To .SelectedItems.Count
filesList.Add .SelectedItems(i)
Next i
End With
If filesList.Count = 0 Then
MsgBox "Вы не выбрали ни одного файла. Грустно.", vbExclamation
Exit Sub
End If
' ---- Настройки ----
Dim pageSize As String
pageSize = InputBox("Размер страницы:" & vbCrLf & vbCrLf & _
"1 - A4 (210 x 297 мм)" & vbCrLf & _
"2 - A3 (297 x 420 мм)" & vbCrLf & _
"3 - Letter (216 x 279 мм)" & vbCrLf & _
"4 - Подогнать под размер картинки (РЕКОМЕНДУЕТСЯ)" & vbCrLf & _
"5 - Квадрат (210 x 210 мм)", _
"Настройки PDF", "4")
If pageSize = "" Then Exit Sub
Dim orientation As String
If pageSize <> "4" Then
orientation = InputBox("Ориентация страницы:" & vbCrLf & vbCrLf & _
"1 - Книжная (портрет)" & vbCrLf & _
"2 - Альбомная (ландшафт)" & vbCrLf & _
"3 - Авто (по ориентации картинки)", _
"Ориентация", "3")
If orientation = "" Then Exit Sub
Else
orientation = "3"
End If
' ---- Путь сохранения ----
outputPath = Application.GetSaveAsFilename( _
InitialFileName:="Output.pdf", _
FileFilter:="PDF (*.pdf), *.pdf", _
Title:="Сохранить итоговый PDF")
If CStr(outputPath) = "False" Then Exit Sub
If LCase(Right(outputPath, 4)) <> ".pdf" Then outputPath = outputPath & ".pdf"
' ---- Подготовка временной папки ----
Dim tempFolder As String
tempFolder = Environ("TEMP") & "\VBA_PDF_Merge_" & Format(Now, "yyyymmddhhnnss") & "\"
MkDir tempFolder
' ---- Разделяем файлы на картинки и PDF ----
Dim imageFiles As New Collection
Dim pdfFiles As New Collection ' Коллекция: ключ = порядковый номер, значение = путь
Dim fileOrder() As String ' Массив для хранения порядка: "IMG" или "PDF"
Dim fileIndex() As Long ' Индекс в соответствующей коллекции
ReDim fileOrder(1 To filesList.Count)
ReDim fileIndex(1 To filesList.Count)
Dim imgCount As Long, pdfCount As Long
imgCount = 0: pdfCount = 0
For i = 1 To filesList.Count
Dim ext As String
ext = LCase(Right(filesList(i), 4))
If ext = ".pdf" Then
pdfCount = pdfCount + 1
pdfFiles.Add filesList(i)
fileOrder(i) = "PDF"
fileIndex(i) = pdfCount
Else
imgCount = imgCount + 1
imageFiles.Add filesList(i)
fileOrder(i) = "IMG"
fileIndex(i) = imgCount
End If
Next i
' ---- Конвертируем каждую картинку в отдельный PDF через PowerPoint ----
Dim tempPDFs As New Collection ' Все временные PDF в правильном порядке
If imgCount > 0 Then
Dim pptApp As Object, wasOpen As Boolean
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
wasOpen = Not (pptApp Is Nothing)
On Error GoTo 0
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
End If
' Размеры страниц (в пунктах)
Dim pgW As Single, pgH As Single
Select Case pageSize
Case "1": pgW = 595.28: pgH = 841.89 ' A4
Case "2": pgW = 841.89: pgH = 1190.55 ' A3
Case "3": pgW = 612: pgH = 792 ' Letter
Case "4": pgW = 0: pgH = 0 ' Авто
Case "5": pgW = 595.28: pgH = 595.28 ' Квадрат
Case Else: pgW = 595.28: pgH = 841.89
End Select
' === КЛЮЧЕВОЕ ИЗМЕНЕНИЕ: каждая картинка = отдельная презентация = отдельный PDF ===
Dim imgIdx As Long
For imgIdx = 1 To imageFiles.Count
Application.StatusBar = "Конвертация изображения " & imgIdx & "/" & imgCount & "... ☕"
DoEvents
Dim fPath As String
fPath = imageFiles(imgIdx)
If Dir(fPath) = "" Then GoTo SkipImage
' Создаём ОТДЕЛЬНУЮ презентацию для каждой картинки!
' Потому что PowerPoint — диктатор и не даёт слайдам быть разного размера
Dim pptPres As Object
Set pptPres = pptApp.Presentations.Add(WithWindow:=False)
' Сначала добавляем картинку чтобы узнать размер
Dim pptSlide As Object, pptShape As Object
Set pptSlide = pptPres.Slides.Add(1, 12) ' ppLayoutBlank
Set pptShape = pptSlide.Shapes.AddPicture( _
Filename:=fPath, LinkToFile:=False, _
SaveWithDocument:=True, Left:=0, Top:=0)
Dim imgW As Single, imgH As Single
imgW = pptShape.Width
imgH = pptShape.Height
' Определяем размер страницы
Dim curW As Single, curH As Single
If pageSize = "4" Then
curW = imgW
curH = imgH
' Ограничение PowerPoint ~5000 pt
If curW > 5000 Or curH > 5000 Then
Dim maxDim As Single
maxDim = IIf(curW > curH, curW, curH)
Dim scaleRatio As Single
scaleRatio = 5000 / maxDim
curW = curW * scaleRatio
curH = curH * scaleRatio
End If
' Минимальный размер
If curW < 72 Then curW = 72
If curH < 72 Then curH = 72
Else
curW = pgW
curH = pgH
' Авто-ориентация
Dim tmp As Single
If orientation = "3" Then
If (imgW > imgH) And (curW < curH) Then
tmp = curW: curW = curH: curH = tmp
ElseIf (imgH > imgW) And (curH < curW) Then
tmp = curW: curW = curH: curH = tmp
End If
ElseIf orientation = "2" Then
If curW < curH Then
tmp = curW: curW = curH: curH = tmp
End If
End If
End If
' Устанавливаем размер слайда (теперь это не мешает другим!)
pptPres.PageSetup.SlideWidth = curW
pptPres.PageSetup.SlideHeight = curH
' Масштабируем картинку
If pageSize = "4" Then
pptShape.LockAspectRatio = False
pptShape.Width = curW
pptShape.Height = curH
pptShape.Left = 0
pptShape.Top = 0
Else
Dim scX As Single, scY As Single, sc As Single
scX = curW / pptShape.Width
scY = curH / pptShape.Height
sc = IIf(scX < scY, scX, scY)
pptShape.LockAspectRatio = True
pptShape.Width = pptShape.Width * sc
pptShape.Left = (curW - pptShape.Width) / 2
pptShape.Top = (curH - pptShape.Height) / 2
End If
' Сохраняем как отдельный PDF
Dim tempPdfPath As String
tempPdfPath = tempFolder & "img_" & Format(imgIdx, "0000") & ".pdf"
pptPres.SaveAs tempPdfPath, 32 ' ppSaveAsPDF
pptPres.Close
SkipImage:
DoEvents
Next imgIdx
' Закрываем PowerPoint если мы его открыли
If Not wasOpen Then
On Error Resume Next
pptApp.Quit
On Error GoTo 0
End If
End If
' ---- Собираем все PDF в правильном порядке ----
' Счётчики для отслеживания текущего индекса в каждой коллекции
Dim curImgPdf As Long: curImgPdf = 0
Dim curPdfFile As Long: curPdfFile = 0
For i = 1 To filesList.Count
If fileOrder(i) = "IMG" Then
curImgPdf = curImgPdf + 1
Dim imgPdfPath As String
imgPdfPath = tempFolder & "img_" & Format(curImgPdf, "0000") & ".pdf"
If Dir(imgPdfPath) <> "" Then
tempPDFs.Add imgPdfPath
End If
ElseIf fileOrder(i) = "PDF" Then
curPdfFile = curPdfFile + 1
tempPDFs.Add pdfFiles(curPdfFile)
End If
Next i
' ---- Объединяем все PDF ----
If tempPDFs.Count = 0 Then
MsgBox "Нечего объединять. Все файлы оказались пустышками! :f09f98b1:", vbExclamation
GoTo Cleanup
End If
Application.StatusBar = "Объединение PDF... Почти готово! :f09f8f81:"
If tempPDFs.Count = 1 Then
' Только один файл — просто копируем
FileCopy tempPDFs(1), outputPath
Else
' Объединяем через Adobe Acrobat (если есть) или через Shell
Dim merged As Boolean
merged = False
' Попытка 1: Adobe Acrobat Pro
merged = MergeWithAcrobat(tempPDFs, outputPath)
' Попытка 2: PDFtk (бесплатная утилита)
If Not merged Then
merged = MergeWithPDFtk(tempPDFs, outputPath)
End If
' Попытка 3: Ghostscript
If Not merged Then
merged = MergeWithGhostscript(tempPDFs, outputPath)
End If
' Попытка 4: Python (если установлен)
If Not merged Then
merged = MergeWithPython(tempPDFs, outputPath, tempFolder)
End If
If Not merged Then
' Последний вариант — сохраняем отдельные файлы
Dim fallbackFolder As String
fallbackFolder = Left(outputPath, InStrRev(outputPath, "\"))
Dim msg As String
msg = "Не удалось объединить PDF! :f09f98a4:" & vbCrLf & vbCrLf & _
"Не найден ни один инструмент для склейки:" & vbCrLf & _
"• Adobe Acrobat Pro" & vbCrLf & _
"• PDFtk (pdftk.exe)" & vbCrLf & _
"• Ghostscript (gswin64c.exe)" & vbCrLf & _
"• Python с PyPDF2/pikepdf" & vbCrLf & vbCrLf & _
"Сохранить отдельные PDF в папку?"
If MsgBox(msg, vbYesNo + vbQuestion) = vbYes Then
Dim outFolder As String
outFolder = Left(outputPath, InStrRev(outputPath, "\")) & "PDF_Pages\"
On Error Resume Next
MkDir outFolder
On Error GoTo 0
For i = 1 To tempPDFs.Count
Dim destFile As String
destFile = outFolder & "Page_" & Format(i, "000") & ".pdf"
FileCopy tempPDFs(i), destFile
Next i
MsgBox "Отдельные PDF сохранены в:" & vbCrLf & outFolder, vbInformation
End If
GoTo Cleanup
End If
End If
Application.StatusBar = False
MsgBox ":f09f8e89: PDF создан: " & outputPath & vbCrLf & _
"Страниц/файлов: " & tempPDFs.Count & vbCrLf & _
"(Картинок: " & imgCount & ", PDF: " & pdfCount & ")", vbInformation
Cleanup:
Application.StatusBar = False
' Чистим временные файлы
On Error Resume Next
Dim f As String
f = Dir(tempFolder & "*.*")
Do While f <> ""
Kill tempFolder & f
f = Dir
Loop
RmDir tempFolder
On Error GoTo 0
End Sub
' ============================================================
' ФУНКЦИИ ОБЪЕДИНЕНИЯ PDF
' (Четыре всадника PDF-апокалипсиса)
' ============================================================
Function MergeWithAcrobat(ByRef pdfFiles As Collection, ByVal outputPath As String) As Boolean
' Пытаемся использовать Adobe Acrobat Pro
' (Если у вас есть лицензия, вы — счастливчик!)
On Error GoTo AcrobatFail
Dim acroApp As Object
Set acroApp = CreateObject("AcroExch.App")
Dim primaryDoc As Object
Set primaryDoc = CreateObject("AcroExch.PDDoc")
' Открываем первый PDF
If Not primaryDoc.Open(pdfFiles(1)) Then GoTo AcrobatFail
' Добавляем остальные
Dim i As Long
For i = 2 To pdfFiles.Count
Dim nextDoc As Object
Set nextDoc = CreateObject("AcroExch.PDDoc")
If nextDoc.Open(pdfFiles(i)) Then
Dim numPages As Long
numPages = nextDoc.GetNumPages
primaryDoc.InsertPages primaryDoc.GetNumPages - 1, nextDoc, 0, numPages, False
nextDoc.Close
End If
Set nextDoc = Nothing
Next i
' Сохраняем
primaryDoc.Save 1, outputPath ' PDSaveFull
primaryDoc.Close
acroApp.Exit
Set primaryDoc = Nothing
Set acroApp = Nothing
MergeWithAcrobat = True
Exit Function
AcrobatFail:
On Error Resume Next
If Not primaryDoc Is Nothing Then primaryDoc.Close
If Not acroApp Is Nothing Then acroApp.Exit
Set primaryDoc = Nothing
Set acroApp = Nothing
On Error GoTo 0
MergeWithAcrobat = False
End Function
Function MergeWithPDFtk(ByRef pdfFiles As Collection, ByVal outputPath As String) As Boolean
' PDFtk — бесплатный швейцарский нож для PDF
' Скачать: https://www.pdflabs.com/tools/pdftk-the-pdf-toolkit/
On Error GoTo PDFtkFail
' Ищем pdftk
Dim pdftkPath As String
pdftkPath = FindExecutable("pdftk.exe")
If pdftkPath = "" Then
MergeWithPDFtk = False
Exit Function
End If
' Собираем команду
Dim cmd As String
cmd = """" & pdftkPath & """"
Dim i As Long
For i = 1 To pdfFiles.Count
cmd = cmd & " """ & pdfFiles(i) & """"
Next i
cmd = cmd & " cat output """ & outputPath & """"
' Запускаем и ждём
Dim exitCode As Long
exitCode = RunAndWait(cmd)
MergeWithPDFtk = (Dir(outputPath) <> "")
Exit Function
PDFtkFail:
MergeWithPDFtk = False
End Function
Function MergeWithGhostscript(ByRef pdfFiles As Collection, ByVal outputPath As String) As Boolean
' Ghostscript — олдскульный, но надёжный как танк
On Error GoTo GSFail
Dim gsPath As String
gsPath = FindExecutable("gswin64c.exe")
If gsPath = "" Then gsPath = FindExecutable("gswin32c.exe")
If gsPath = "" Then
MergeWithGhostscript = False
Exit Function
End If
Dim cmd As String
cmd = """" & gsPath & """ -dBATCH -dNOPAUSE -q -sDEVICE=pdfwrite" & _
" -sOutputFile=""" & outputPath & """"
Dim i As Long
For i = 1 To pdfFiles.Count
cmd = cmd & " """ & pdfFiles(i) & """"
Next i
Dim exitCode As Long
exitCode = RunAndWait(cmd)
MergeWithGhostscript = (Dir(outputPath) <> "")
Exit Function
GSFail:
MergeWithGhostscript = False
End Function
Function MergeWithPython(ByRef pdfFiles As Collection, ByVal outputPath As String, _
ByVal tempFolder As String) As Boolean
' Python — потому что почему бы и нет?
' Нужен PyPDF2 или pikepdf: pip install PyPDF2
On Error GoTo PythonFail
Dim pythonPath As String
pythonPath = FindExecutable("python.exe")
If pythonPath = "" Then pythonPath = FindExecutable("python3.exe")
If pythonPath = "" Then
MergeWithPython = False
Exit Function
End If
' Создаём Python-скрипт
Dim scriptPath As String
scriptPath = tempFolder & "merge_pdf.py"
Dim f As Integer
f = FreeFile
Open scriptPath For Output As #f
Print #f, "import sys"
Print #f, "try:"
Print #f, " from PyPDF2 import PdfMerger"
Print #f, " merger = PdfMerger()"
Dim i As Long
For i = 1 To pdfFiles.Count
Print #f, " merger.append(r'" & Replace(pdfFiles(i), "'", "\'") & "')"
Next i
Print #f, " merger.write(r'" & Replace(outputPath, "'", "\'") & "')"
Print #f, " merger.close()"
Print #f, " print('OK')"
Print #f, "except ImportError:"
Print #f, " try:"
Print #f, " import pikepdf"
Print #f, " pdf = pikepdf.Pdf.new()"
For i = 1 To pdfFiles.Count
Print #f, " src = pikepdf.Pdf.open(r'" & Replace(pdfFiles(i), "'", "\'") & "')"
Print #f, " pdf.pages.extend(src.pages)"
Next i
Print #f, " pdf.save(r'" & Replace(outputPath, "'", "\'") & "')"
Print #f, " print('OK')"
Print #f, " except ImportError:"
Print #f, " print('FAIL')"
Print #f, " sys.exit(1)"
Print #f, "except Exception as e:"
Print #f, " print(f'ERROR: {e}')"
Print #f, " sys.exit(1)"
Close #f
' Запускаем
Dim cmd As String
cmd = """" & pythonPath & """ """ & scriptPath & """"
Dim exitCode As Long
exitCode = RunAndWait(cmd)
MergeWithPython = (Dir(outputPath) <> "")
Exit Function
PythonFail:
MergeWithPython = False
End Function
' ============================================================
' ВСПОМОГАТЕЛЬНЫЕ ФУНКЦИИ
' ============================================================
Function FindExecutable(ByVal exeName As String) As String
' Ищем исполняемый файл в PATH и типичных местах
Dim testPaths As Variant
testPaths = Array( _
exeName, _
"C:\Program Files\PDFtk\bin\" & exeName, _
"C:\Program Files (x86)\PDFtk\bin\" & exeName, _
"C:\Program Files\gs\gs10.02.1\bin\" & exeName, _
"C:\Program Files\gs\gs10.01.2\bin\" & exeName, _
"C:\Program Files\gs\gs10.00.0\bin\" & exeName, _
"C:\Program Files\gs\gs9.56.1\bin\" & exeName, _
"C:\Program Files (x86)\gs\gs9.56.1\bin\" & exeName, _
Environ("LOCALAPPDATA") & "\Programs\Python\Python312\" & exeName, _
Environ("LOCALAPPDATA") & "\Programs\Python\Python311\" & exeName, _
Environ("LOCALAPPDATA") & "\Programs\Python\Python310\" & exeName, _
"C:\Python312\" & exeName, _
"C:\Python311\" & exeName, _
"C:\Python310\" & exeName _
)
' Сначала проверяем через WHERE (для файлов в PATH)
Dim tempFile As String
tempFile = Environ("TEMP") & "\vba_which_" & Replace(exeName, ".", "_") & ".txt"
On Error Resume Next
Shell "cmd /c where " & exeName & " > """ & tempFile & """ 2>nul", vbHide
' Даём время на выполнение
Dim waitStart As Single
waitStart = Timer
Do While Timer - waitStart < 2
DoEvents
If Dir(tempFile) <> "" Then
If FileLen(tempFile) > 0 Then Exit Do
End If
Loop
If Dir(tempFile) <> "" Then
If FileLen(tempFile) > 0 Then
Dim f As Integer
f = FreeFile
Dim line As String
Open tempFile For Input As #f
If Not EOF(f) Then
Line Input #f, line
line = Trim(line)
If line <> "" And Dir(line) <> "" Then
Close #f
Kill tempFile
FindExecutable = line
Exit Function
End If
End If
Close #f
End If
Kill tempFile
End If
On Error GoTo 0
' Проверяем известные пути
Dim p As Variant
For Each p In testPaths
If p <> exeName Then ' Пропускаем голое имя
On Error Resume Next
If Dir(CStr(p)) <> "" Then
FindExecutable = CStr(p)
Exit Function
End If
On Error GoTo 0
End If
Next p
FindExecutable = ""
End Function
Function RunAndWait(ByVal cmd As String) As Long
' Запускает команду и ждёт завершения
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
RunAndWait = wsh.Run("cmd /c " & cmd, 0, True) ' 0 = скрытое окно, True = ждать
Set wsh = Nothing
End Function |
