From eb6b3e229429765ab13c2bf5c80b33933a47824d Mon Sep 17 00:00:00 2001 From: Vlad Vissoultchev Date: Fri, 14 Dec 2018 12:06:56 +0200 Subject: [PATCH] Initial commit --- .gitattributes | 7 + .gitignore | 19 +++ README.md | 28 ++++ mdPrintImages.bas | 360 +++++++++++++++++++++++++++++++++++++++++ mdStartup.bas | 403 ++++++++++++++++++++++++++++++++++++++++++++++ vbimg2pdf.vbp | 39 +++++ 6 files changed, 856 insertions(+) create mode 100644 .gitattributes create mode 100644 .gitignore create mode 100644 README.md create mode 100644 mdPrintImages.bas create mode 100644 mdStartup.bas create mode 100644 vbimg2pdf.vbp diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..da782b8 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,7 @@ +# Auto detect text files and perform LF normalization +* text eol=crlf + +*.exe -text +*.dll -text +*.cmp -text +*.cobj -text diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3c697d8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,19 @@ +## VB6 workspace + +*.vbw +*.bak +*.log +*.scc +*.zip +*.exp +*.lib +*.obj +*.dll +*.exe +*.pdb +**/_del +~* +*.xlsb +*.out +*.pdf +**/jpegs \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..589b278 --- /dev/null +++ b/README.md @@ -0,0 +1,28 @@ +## vbimg2pdf +Convert jpeg/png images to multi-page pdf file + +### Description + +Can be used to embed jpeg/png images in a single pdf file without resizing and recompressing input format. Uses `Microsoft Print to PDF` printer as pdf writer. + +### Sample usage + + - Generate `output.pdf` from all jpegs in current folder +``` + c:> vbimg2pdf.exe *.jpg -o output.pdf +``` +### Command-line +``` +vbimg2pdf 0.1 (c) 2018 by wqweto@gmail.com +Convert jpeg/png images to multi-page pdf + +Usage: vbimg2pdf.exe [options] ... + +Options: + -o OUTFILE write result to OUTFILE + -paper SIZE output paper size (e.g. A4) + -orientation ORNT page orientation (e.g. portrait) + -margins L[/T/R/B] page margins in inches (e.g. 0.25) + -q in quiet operation outputs only errors + -nologo suppress startup banner +``` diff --git a/mdPrintImages.bas b/mdPrintImages.bas new file mode 100644 index 0000000..5c4741d --- /dev/null +++ b/mdPrintImages.bas @@ -0,0 +1,360 @@ +Attribute VB_Name = "mdPrintImages" +'========================================================================= +' +' vbimg2pdf (c) 2018 by wqweto@gmail.com +' +' 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) + 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) + 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 = "[&H" & Hex(Err.Number) & "] Critical: " & Err.Description & " [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 = "[&H" & Hex(Err.Number) & "] Critical: " & Err.Description & " [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 = "Invalid image: " & Mid$(sFile, InStrRev(sFile, "\") + 1) & " [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 = "[&H" & Hex(Err.Number) & "] Critical: " & Err.Description & " [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 = "[" & lLastDllError & "] " & Left$(GetSystemMessage, lSize) +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 diff --git a/mdStartup.bas b/mdStartup.bas new file mode 100644 index 0000000..48c427d --- /dev/null +++ b/mdStartup.bas @@ -0,0 +1,403 @@ +Attribute VB_Name = "mdStartup" +'========================================================================= +' +' vbimg2pdf (c) 2018 by wqweto@gmail.com +' +' Convert jpeg/png images to multi-page pdf file +' +'========================================================================= +Option Explicit +DefObj A-Z + +'========================================================================= +' API +'========================================================================= + +Private Const STD_OUTPUT_HANDLE As Long = -11& +Private Const STD_ERROR_HANDLE As Long = -12& +'--- for DeviceCapabilities +Private Const DC_PAPERS As Long = 2 +Private Const DC_PAPERSIZE As Long = 3 +Private Const DC_PAPERNAMES As Long = 16 +Private Const PAPERNAME_SIZE As Long = 64 + +Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) +Private Declare Function CommandLineToArgvW Lib "shell32" (ByVal lpCmdLine As Long, pNumArgs As Long) As Long +Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long +Private Declare Function ApiSysAllocString Lib "oleaut32" Alias "SysAllocString" (ByVal Ptr As Long) As Long +Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long +Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long +Private Declare Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" (ByVal lpszSrc As String, lpszDst As Any, ByVal cchDstLength As Long) As Long +Private Declare Sub ExitProcess Lib "kernel32" (ByVal lExitCode As Long) +Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long +Private Declare Function DeviceCapabilities Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, ByVal dev 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) + +'========================================================================= +' Constants and member variables +'========================================================================= + +Private Const STR_PDF_PRINTER As String = "Microsoft Print to PDF" + +Private m_oOpt As Object + +Private Type UcsPaperInfoType + PaperSize As Long + Name As String + Width As Single + Height As Single +End Type + +'========================================================================= +' Functions +'========================================================================= + +Private Sub Main() + Dim lExitCode As Long + + lExitCode = Process(SplitArgs(Command$)) + If Not InIde Then + Call ExitProcess(lExitCode) + End If +End Sub + +Private Function Process(vArgs As Variant) As Long + Dim sPrinterName As String + Dim cFiles As Collection + Dim vInputFiles As Variant + Dim lIdx As Long + Dim sError As String + Dim lPos As Long + Dim sFolder As String + Dim lPaperSize As Long + Dim lOrientation As Long + Dim vMargins As Variant + Dim uPapers() As UcsPaperInfoType + Dim sText As String + + Set m_oOpt = GetOpt(vArgs, "printer:orientation:paper:margins:o") + If Not m_oOpt.Item("-nologo") And Not m_oOpt.Item("-q") Then + ConsoleError App.ProductName & " " & App.Major & "." & App.Minor & " (c) 2018 by wqweto@gmail.com" & vbCrLf + ConsoleError "Convert jpeg/png images to multi-page pdf file" & vbCrLf & vbCrLf + End If + If LenB(m_oOpt.Item("error")) <> 0 Then + ConsoleError "Error in command line: " & m_oOpt.Item("error") & vbCrLf & vbCrLf + If Not (m_oOpt.Item("-h") Or m_oOpt.Item("-?") Or m_oOpt.Item("arg0") = "?") Then + Exit Function + End If + End If + If m_oOpt.Item("#arg") < 0 Or m_oOpt.Item("-h") Or m_oOpt.Item("-?") Or m_oOpt.Item("arg0") = "?" Then + ConsoleError "Usage: %1.exe [options] ..." & vbCrLf & vbCrLf, App.EXEName + ConsoleError "Options:" & vbCrLf & _ + " -o OUTFILE write result to OUTFILE" & vbCrLf & _ + " -paper SIZE output paper size (e.g. A4)" & vbCrLf & _ + " -orientation ORNT page orientation (e.g. portrait)" & vbCrLf & _ + " -margins L[/T/R/B] page margins in inches (e.g. 0.25)" & vbCrLf & _ + " -q in quiet operation outputs only errors" & vbCrLf & _ + " -nologo suppress startup banner" & vbCrLf + If m_oOpt.Item("#arg") < 0 Then + Process = 100 + End If + Exit Function + End If + Set cFiles = New Collection + For lIdx = 0 To m_oOpt.Item("#arg") + If FileExists(m_oOpt.Item("arg" & lIdx)) Then + cFiles.Add m_oOpt.Item("arg" & lIdx) + Else + lPos = InStrRev(m_oOpt.Item("arg" & lIdx), "\") + If lPos > 0 Then + sFolder = Left$(m_oOpt.Item("arg" & lIdx), lPos - 1) + End If + If DirectoryExists(sFolder) And lPos > 0 Then + EnumFiles sFolder, Mid$(m_oOpt.Item("arg" & lIdx), lPos), RetVal:=cFiles + Else + If Not m_oOpt.Item("-q") Then + ConsoleError "Warning: '%1' not found" & vbCrLf, m_oOpt.Item("arg" & lIdx) + End If + End If + End If + Next + ReDim vInputFiles(0 To cFiles.Count - 1) As String + For lIdx = 1 To cFiles.Count + vInputFiles(lIdx - 1) = cFiles.Item(lIdx) + Next + sPrinterName = m_oOpt.Item("-printer") + If LenB(sPrinterName) = 0 Then + sPrinterName = STR_PDF_PRINTER + End If + Select Case LCase$(m_oOpt.Item("-orientation")) + Case "p", "portrait" + lOrientation = 1 + Case "l", "landscape" + lOrientation = 2 + End Select + If Not IsEmpty(m_oOpt.Item("-paper")) Then + lPaperSize = C_Dbl(m_oOpt.Item("-paper")) + If lPaperSize = 0 Then + uPapers = EnumPrinterPapers(sPrinterName) + For lIdx = 0 To UBound(uPapers) + sText = sText & ", '" & uPapers(lIdx).Name & "'" + If LCase$(uPapers(lIdx).Name) = LCase$(m_oOpt.Item("-paper")) Then + lPaperSize = uPapers(lIdx).PaperSize + Exit For + End If + Next + End If + If lPaperSize = 0 Then + If Not m_oOpt.Item("-q") Then + If LenB(sText) <> 0 Then + sText = ". Not from " & Mid$(sText, 3) + End If + ConsoleError "Warning: '%1' paper ignored" & sText & vbCrLf, m_oOpt.Item("-paper") + End If + End If + End If + If Not IsEmpty(m_oOpt.Item("-margins")) Then + vMargins = Split(m_oOpt.Item("-margins"), "/") + If UBound(vMargins) = 0 And C_Dbl(At(vMargins, 0)) > 0 Then + vMargins = C_Dbl(At(vMargins, 0)) + vMargins = Array(vMargins, vMargins, vMargins, vMargins) + End If + End If + If Not PrintImages( _ + sPrinterName, _ + vInputFiles, _ + m_oOpt.Item("-o"), _ + lPaperSize:=lPaperSize, _ + lOrientation:=lOrientation, _ + vMargins:=vMargins, _ + sError:=sError) Then + ConsoleError sError & vbCrLf & vbCrLf + Process = 2 + GoTo QH + End If + For lIdx = 1 To 30 + If FileExists(m_oOpt.Item("-o")) Then + Exit For + End If + Call Sleep(100) + Next + If FileExists(m_oOpt.Item("-o")) Then + If Not m_oOpt.Item("-q") Then + ConsoleError m_oOpt.Item("-o") & " output sucesfully!" & vbCrLf & vbCrLf + End If + End If +QH: +End Function + +Private Function SplitArgs(sText As String) As Variant + Dim vRetVal As Variant + Dim lPtr As Long + Dim lArgc As Long + Dim lIdx As Long + Dim lArgPtr As Long + + If LenB(sText) <> 0 Then + lPtr = CommandLineToArgvW(StrPtr(sText), lArgc) + End If + If lArgc > 0 Then + ReDim vRetVal(0 To lArgc - 1) As String + For lIdx = 0 To UBound(vRetVal) + Call CopyMemory(lArgPtr, ByVal lPtr + 4 * lIdx, 4) + vRetVal(lIdx) = SysAllocString(lArgPtr) + Next + Else + vRetVal = Split(vbNullString) + End If + Call LocalFree(lPtr) + SplitArgs = vRetVal +End Function + +Private Function SysAllocString(ByVal lPtr As Long) As String + Dim lTemp As Long + + lTemp = ApiSysAllocString(lPtr) + Call CopyMemory(ByVal VarPtr(SysAllocString), lTemp, 4) +End Function + +Private Function ConsolePrint(ByVal sText As String, ParamArray A() As Variant) As String + ConsolePrint = pvConsoleOutput(GetStdHandle(STD_OUTPUT_HANDLE), sText, CVar(A)) +End Function + +Private Function ConsoleError(ByVal sText As String, ParamArray A() As Variant) As String + ConsoleError = pvConsoleOutput(GetStdHandle(STD_ERROR_HANDLE), sText, CVar(A)) +End Function + +Private Function pvConsoleOutput(ByVal hOut As Long, ByVal sText As String, A As Variant) As String + Const LNG_PRIVATE As Long = &HE1B6 '-- U+E000 to U+F8FF - Private Use Area (PUA) + Dim lIdx As Long + Dim sArg As String + Dim baBuffer() As Byte + Dim dwDummy As Long + + If LenB(sText) = 0 Then + Exit Function + End If + '--- format + For lIdx = UBound(A) To LBound(A) Step -1 + sArg = Replace(A(lIdx), "%", ChrW$(LNG_PRIVATE)) + sText = Replace(sText, "%" & (lIdx - LBound(A) + 1), sArg) + Next + pvConsoleOutput = Replace(sText, ChrW$(LNG_PRIVATE), "%") + '--- output + If hOut = 0 Then + Debug.Print pvConsoleOutput; + Else + ReDim baBuffer(0 To Len(pvConsoleOutput) - 1) As Byte + If CharToOemBuff(pvConsoleOutput, baBuffer(0), UBound(baBuffer) + 1) Then + Call WriteFile(hOut, baBuffer(0), UBound(baBuffer) + 1, dwDummy, ByVal 0&) + End If + End If +End Function + +Private Function GetOpt(vArgs As Variant, Optional OptionsWithArg As String) As Dictionary + Dim oRetVal As Dictionary + Dim lIdx As Long + Dim bNoMoreOpt As Boolean + Dim vOptArg As Variant + Dim vElem As Variant + Dim sValue As String + + vOptArg = Split(OptionsWithArg, ":") + Set oRetVal = CreateObject("Scripting.Dictionary") + With oRetVal + .CompareMode = vbTextCompare + .Item("#arg") = -1& + For lIdx = 0 To UBound(vArgs) + Select Case Left$(At(vArgs, lIdx), 1 + bNoMoreOpt) + Case "-", "/" + For Each vElem In vOptArg + If Mid$(At(vArgs, lIdx), 2, Len(vElem)) = vElem Then + If Mid(At(vArgs, lIdx), Len(vElem) + 2, 1) = ":" Then + sValue = Mid$(At(vArgs, lIdx), Len(vElem) + 3) + ElseIf Len(At(vArgs, lIdx)) > Len(vElem) + 1 Then + sValue = Mid$(At(vArgs, lIdx), Len(vElem) + 2) + ElseIf LenB(At(vArgs, lIdx + 1)) <> 0 Then + sValue = At(vArgs, lIdx + 1) + lIdx = lIdx + 1 + Else + .Item("error") = "Option `" & vElem & "` requires an argument" + End If + vElem = "-" & vElem + If Not .Exists(vElem) Then + .Item(vElem) = sValue + Else + .Item("#" & vElem) = .Item("#" & vElem) + 1 + .Item(vElem & .Item("#" & vElem)) = sValue + End If + GoTo Continue + End If + Next + vElem = "-" & Mid$(At(vArgs, lIdx), 2) + .Item(vElem) = True + Case Else + vElem = "arg" + sValue = At(vArgs, lIdx) + .Item("#" & vElem) = .Item("#" & vElem) + 1 + .Item(vElem & .Item("#" & vElem)) = sValue + End Select +Continue: + Next + End With + Set GetOpt = oRetVal +End Function + +Private Property Get InIde() As Boolean + Debug.Assert pvSetTrue(InIde) +End Property + +Private Function pvSetTrue(bValue As Boolean) As Boolean + bValue = True + pvSetTrue = True +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 FileExists(sFile As String) As Boolean + FileExists = GetFileAttributes(sFile) <> -1 +End Function + +Private Function DirectoryExists(sFile As String) As Boolean + DirectoryExists = (GetFileAttributes(sFile) And vbDirectory + vbVolume) = vbDirectory +End Function + +Private Function EnumFiles( _ + sFolder As String, _ + Optional sMask As String, _ + Optional ByVal eAttrib As VbFileAttribute, _ + Optional RetVal As Collection) As Collection + Dim sFile As String + + If RetVal Is Nothing Then + Set RetVal = New Collection + End If + sFile = Dir(PathCombine(sFolder, sMask)) + Do While LenB(sFile) <> 0 + If sFile <> "." And sFile <> ".." Then + sFile = PathCombine(sFolder, sFile) + If (GetAttr(sFile) And eAttrib) = eAttrib Then + RetVal.Add sFile + End If + End If + sFile = Dir + Loop + Set EnumFiles = RetVal +End Function + +Private Function PathCombine(sPath As String, sFile As String) As String + PathCombine = sPath & IIf(LenB(sPath) <> 0 And Right$(sPath, 1) <> "\" And LenB(sFile) <> 0, "\", vbNullString) & sFile +End Function + +Private Function EnumPrinterPapers(sPrinterName As String) As UcsPaperInfoType() + Dim lNum As Long + Dim lIdx As Long + Dim naPapers() As Integer + Dim sPaperNames As String + Dim laPaperSizes() As Long + Dim uRetVal() As UcsPaperInfoType + + lNum = DeviceCapabilities(sPrinterName, vbNullString, DC_PAPERS, ByVal vbNullString, 0) + If lNum <= 0 Then + ReDim uRetVal(-1 To -1) As UcsPaperInfoType + GoTo QH + End If + ReDim naPapers(0 To lNum - 1) As Integer + Call DeviceCapabilities(sPrinterName, vbNullString, DC_PAPERS, naPapers(0), 0) + sPaperNames = String$(PAPERNAME_SIZE * lNum, 0) + Call DeviceCapabilities(sPrinterName, vbNullString, DC_PAPERNAMES, ByVal sPaperNames, 0) + ReDim laPaperSizes(0 To 2 * lNum - 1) As Long + Call DeviceCapabilities(sPrinterName, vbNullString, DC_PAPERSIZE, laPaperSizes(0), 0) + ReDim uRetVal(0 To lNum - 1) As UcsPaperInfoType + For lIdx = 0 To lNum - 1 + With uRetVal(lIdx) + .PaperSize = naPapers(lIdx) + .Name = Mid$(sPaperNames, PAPERNAME_SIZE * lIdx + 1, PAPERNAME_SIZE) + .Name = Left$(.Name, InStr(1, .Name, Chr$(0)) - 1) + .Width = laPaperSizes(2 * lIdx) / 10# + .Height = laPaperSizes(2 * lIdx + 1) / 10# + End With + Next +QH: + EnumPrinterPapers = uRetVal +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 + diff --git a/vbimg2pdf.vbp b/vbimg2pdf.vbp new file mode 100644 index 0000000..c7ffc63 --- /dev/null +++ b/vbimg2pdf.vbp @@ -0,0 +1,39 @@ +Type=Exe +Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation +Reference=*\G{420B2830-E718-11CF-893D-00A0C9054228}#1.0#0#..\..\..\Windows\SysWOW64\scrrun.dll#Microsoft Scripting Runtime +Module=mdPrintImages; mdPrintImages.bas +Module=mdStartup; mdStartup.bas +Startup="Sub Main" +HelpFile="" +Title="vbimg2pdf" +ExeName32="vbimg2pdf.exe" +Command32="-printer "Microsoft XPS Document Writer" -paper letter -margins 0.25 -orientation l C:\Work\Temp\vbimg2pdf\jpegs\Data_1.jpg C:\Work\Temp\vbimg2pdf\jpegs\Data_7.jpg -o d:\temp\ccc.xps " +Name="vbimg2pdf" +HelpContextID="0" +CompatibleMode="0" +MajorVer=0 +MinorVer=1 +RevisionVer=0 +AutoIncrementVer=0 +ServerSupportFiles=0 +VersionCompanyName="VBForumsCommunity" +VersionFileDescription="Convert jpeg/png images to multi-page pdf" +VersionProductName="vbimg2pdf" +CompilationType=0 +OptimizationType=0 +FavorPentiumPro(tm)=0 +CodeViewDebugInfo=0 +NoAliasing=0 +BoundsCheck=0 +OverflowCheck=0 +FlPointCheck=0 +FDIVCheck=0 +UnroundedFP=0 +StartMode=0 +Unattended=0 +Retained=0 +ThreadPerObject=0 +MaxNumberOfThreads=1 + +[VBCompiler] +LinkSwitches=/SUBSYSTEM:CONSOLE