Attribute VB_Name = "mdPrintImages"

'=========================================================================
'
' vbimg2pdf (c) 2018 by [email protected]
'
' Convert jpeg/png images to multi-page pdf file
'
'=========================================================================
Option Explicit
DefObj A-Z

'=========================================================================
' API
'=========================================================================

'--- for GetDeviceCaps

Private Const HORZRES As Long = 8
Private Const VERTRES As Long = 10
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
'--- for BITMAPINFOHEADER
Private Const BI_JPEG As Long = 4
Private Const BI_PNG As Long = 5
'--- for DocumentProperties
Private Const DM_OUT_BUFFER As Long = 2
Private Const DM_IN_BUFFER As Long = 8
Private Const IDOK As Long = 1
Private Const DM_ORIENTATION As Long = &H1
Private Const DM_PAPERSIZE As Long = &H2
'--- for FormatMessage
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As

Any, Source As Any, ByVal Length As Long)
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal
pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long)
As Long
Private Declare Function DocumentProperties Lib "winspool.drv" Alias
"DocumentPropertiesA" (ByVal hWnd As Long, ByVal hPrinter As Long, ByVal
pDeviceName As String, pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As
Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName
As String, ByVal lpDeviceName As String, ByVal lpOutput As Long, lpInitData As Any)
As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hDC As Long,
ByRef DOCINFO As DOCINFO) As Long
Private Declare Function EndDoc Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function StartPage Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function EndPage Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex
As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal
dwFlags As Long, lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As
Long, ByVal lpBuffer As String, ByVal nSize As Long, Args As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA"
(ByVal lpLibFileName As String) As Long
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal lX As
Long, ByVal lY As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long,
ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As
Any, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, ByVal dwRop As Long) As
Long
Private Declare Function VariantChangeType Lib "oleaut32" (Dest As Variant, src As
Variant, ByVal wFlags As Integer, ByVal vt As VbVarType) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal
lpFileName As String) As Long
'--- GDI+
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputBuf As
Any, Optional ByVal outputBuf As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal mFilename As
Long, ByRef mImage As Long) As Long
Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal Image As Long,
ByRef nWidth As Single, ByRef nHeight As Single) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As
Long

Private Type DOCINFO

cbSize As Long
lpszDocName As String
lpszOutput As String
End Type

Private Type DEVMODE

dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmLogPixels As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Private Type BITMAPINFOHEADER

biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
 biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

'=========================================================================
' Functions
'=========================================================================

Public Function PrintImages( _

sPrinterName As String, _
vInputFiles As Variant, _
Optional sOutputFile As String, _
Optional ByVal lPaperSize As Long, _
Optional ByVal lOrientation As Long, _
Optional vMargins As Variant, _
Optional sError As String) As Boolean
Dim baDevMode() As Byte
Dim hDC As Long
Dim uInfo As DOCINFO
Dim lDpiX As Long
Dim lDpiY As Long
Dim lLeft As Long
Dim lTop As Long
Dim lWidth As Long
Dim lHeight As Long
Dim lIdx As Long
Dim uHeader As BITMAPINFOHEADER
Dim baImage() As Byte
Dim lTargetX As Long
Dim lTargetY As Long
Dim lTargetW As Long
Dim lTargetH As Long

On Error GoTo EH
'--- will use GDI+ to retrieve input images dimensions
If Not StartGdip() Then
GoTo QH
End If
'--- setup printer paper size/orientation
If Not SetupDevMode(sPrinterName, lPaperSize, lOrientation, baDevMode, sError)
Then
GoTo QH
End If
'--- setup output file
hDC = CreateDC("", sPrinterName, 0, baDevMode(0))
If hDC = 0 Then
sError = GetSystemMessage(Err.LastDllError) & " [CreateDC]"
GoTo QH
End If
uInfo.cbSize = LenB(uInfo)
uInfo.lpszDocName = App.ProductName & " - PrintImages"
If LenB(sOutputFile) <> 0 Then
uInfo.lpszOutput = CanonicalPath(sOutputFile)
Call DeleteFile(uInfo.lpszOutput)
 End If
'--- setup printable area
lDpiX = GetDeviceCaps(hDC, LOGPIXELSX)
lDpiY = GetDeviceCaps(hDC, LOGPIXELSY)
lLeft = C_Dbl(At(vMargins, 0)) * lDpiX
lTop = C_Dbl(At(vMargins, 1)) * lDpiY
lWidth = GetDeviceCaps(hDC, HORZRES) - lLeft - C_Dbl(At(vMargins, 2)) * lDpiX
lHeight = GetDeviceCaps(hDC, VERTRES) - lTop - C_Dbl(At(vMargins, 3)) * lDpiY
'--- output images
If StartDoc(hDC, uInfo) <= 0 Then
sError = GetSystemMessage(Err.LastDllError) & " [StartDoc]"
GoTo QH
End If
uHeader.biSize = LenB(uHeader)
For lIdx = 0 To UBound(vInputFiles)
Call StartPage(hDC)
If Not GetImageDimensions(CStr(vInputFiles(lIdx)), uHeader.biWidth,
uHeader.biHeight, sError) Then
GoTo QH
End If
baImage = ReadBinaryFile(CStr(vInputFiles(lIdx)))
uHeader.biSizeImage = UBound(baImage) + 1
uHeader.biCompression = IIf(baImage(0) = &H89, BI_PNG, BI_JPEG)
If CDbl(lHeight) * uHeader.biWidth > CDbl(lWidth) * uHeader.biHeight Then
lTargetW = lWidth
lTargetH = Int(CDbl(lWidth) * uHeader.biHeight / uHeader.biWidth + 0.5)
lTargetX = 0
lTargetY = Int(CDbl(lHeight - lTargetH) / 2 + 0.5)
Else
lTargetW = Int(CDbl(lHeight) * uHeader.biWidth / uHeader.biHeight +
0.5)
lTargetH = lHeight
lTargetX = Int(CDbl(lWidth - lTargetW) / 2 + 0.5)
lTargetY = 0
End If
Call StretchDIBits(hDC, _
lLeft + lTargetX, lTop + lTargetY, lTargetW, lTargetH, _
0, 0, uHeader.biWidth, uHeader.biHeight, _
baImage(0), uHeader, 0, vbSrcCopy)
Call EndPage(hDC)
Next
Call EndDoc(hDC)
'--- success
PrintImages = True
QH:
On Error Resume Next
If hDC <> 0 Then
Call DeleteDC(hDC)
hDC = 0
End If
Exit Function
EH:
sError = "Critical error: " & Err.Description & " (0x" & Hex(Err.Number) & ")
[PrintImages]"
Resume QH
End Function

Private Function SetupDevMode( _

sPrinterName As String, _
 ByVal lPaperSize As Long, _
ByVal lOrientation As Long, _
baDevMode() As Byte, _
sError As String) As Boolean
Dim hPrinter As Long
Dim lNeeded As Long
Dim uDevMode As DEVMODE

On Error GoTo EH
If OpenPrinter(sPrinterName, hPrinter, 0) = 0 Then
sError = GetSystemMessage(Err.LastDllError) & " [OpenPrinter]"
GoTo QH
End If
lNeeded = DocumentProperties(0, hPrinter, sPrinterName, ByVal 0&, ByVal 0&, 0)
If lNeeded <= 0 Then
sError = GetSystemMessage(Err.LastDllError) & " [DocumentProperties]"
GoTo QH
End If
'--- round up to next 2KB page
ReDim baDevMode(0 To (lNeeded And -2048) + 2047) As Byte
If DocumentProperties(0, hPrinter, sPrinterName, baDevMode(0), ByVal 0&,
DM_OUT_BUFFER) <> IDOK Then
sError = GetSystemMessage(Err.LastDllError) & " [DocumentProperties#2]"
GoTo QH
End If
Call CopyMemory(uDevMode, baDevMode(0), Len(uDevMode))
If lPaperSize <> 0 Then
uDevMode.dmPaperSize = lPaperSize
uDevMode.dmFields = uDevMode.dmFields Or DM_PAPERSIZE
End If
If lOrientation <> 0 Then
uDevMode.dmOrientation = lOrientation
uDevMode.dmFields = uDevMode.dmFields Or DM_ORIENTATION
End If
Call CopyMemory(baDevMode(0), uDevMode, Len(uDevMode))
Call DocumentProperties(0, hPrinter, sPrinterName, baDevMode(0), baDevMode(0),
DM_IN_BUFFER Or DM_OUT_BUFFER)
'--- success
SetupDevMode = True
QH:
On Error Resume Next
If hPrinter <> 0 Then
Call ClosePrinter(hPrinter)
hPrinter = 0
End If
Exit Function
EH:
sError = "Critical error: " & Err.Description & " (0x" & Hex(Err.Number) & ")
[SetupDevMode]"
Resume QH
End Function

Private Function GetImageDimensions(sFile As String, lWidth As Long, lHeight As

Long, sError As String) As Boolean
Dim hBitmap As Long
Dim sngWidth As Single
Dim sngHeight As Single

On Error GoTo EH
 If GdipLoadImageFromFile(StrPtr(sFile), hBitmap) <> 0 Then
If Err.LastDllError = 0 Then
sError = "File '" & Mid$(sFile, InStrRev(sFile, "\") + 1) & "' is
invalid image [GdipLoadImageFromFile]"
Else
sError = GetSystemMessage(Err.LastDllError) & "
[GdipLoadImageFromFile]"
End If
GoTo QH
End If
If GdipGetImageDimension(hBitmap, sngWidth, sngHeight) <> 0 Then
sError = GetSystemMessage(Err.LastDllError) & " [GdipGetImageDimension]"
GoTo QH
End If
lWidth = sngWidth
lHeight = sngHeight
'--- success
GetImageDimensions = True
QH:
If hBitmap <> 0 Then
Call GdipDisposeImage(hBitmap)
End If
Exit Function
EH:
sError = "Critical error: " & Err.Description & " (0x" & Hex(Err.Number) & ")
[GetImageDimensions]"
Resume QH
End Function

Private Function ReadBinaryFile(sFile As String) As Byte()

Dim baBuffer() As Byte
Dim nFile As Integer

On Error GoTo EH
nFile = FreeFile
Open sFile For Binary Access Read Shared As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
End If
Close nFile
ReadBinaryFile = baBuffer
Exit Function
EH:
Close nFile
End Function

Private Function CanonicalPath(sPath As String) As String

Dim oFSO As FileSystemObject

Set oFSO = CreateObject("Scripting.FileSystemObject")

With oFSO
CanonicalPath = .GetAbsolutePathName(sPath)
End With
End Function

Private Function StartGdip() As Boolean

Dim aInput(0 To 3) As Long
 If GetModuleHandle("gdiplus") = 0 Then
aInput(0) = 1
Call GdiplusStartup(0, aInput(0))
End If
'--- success
StartGdip = True
End Function

Private Function GetSystemMessage(ByVal lLastDllError As Long) As String

Dim lSize As Long

GetSystemMessage = Space$(2000)
lSize = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or
FORMAT_MESSAGE_IGNORE_INSERTS, 0&, lLastDllError, 0&, GetSystemMessage,
Len(GetSystemMessage), 0&)
If lSize > 2 Then
If Mid$(GetSystemMessage, lSize - 1, 2) = vbCrLf Then
lSize = lSize - 2
End If
End If
GetSystemMessage = Left$(GetSystemMessage, lSize) & " (" & lLastDllError & ")"
End Function

Private Function At(vArray As Variant, ByVal lIdx As Long) As Variant

On Error GoTo QH
If IsArray(vArray) Then
If lIdx >= LBound(vArray) And lIdx <= UBound(vArray) Then
At = vArray(lIdx)
End If
End If
QH:
End Function

Private Function C_Dbl(Value As Variant) As Double

Dim vDest As Variant

If VarType(Value) = vbDouble Then

C_Dbl = Value
ElseIf VariantChangeType(vDest, Value, 0, vbDouble) = 0 Then
C_Dbl = vDest
End If
End Function