For a project I was working on I needed to combine/merge multiple images into a single image. I figured it could somehow be done with WIA, but was unsure how. So I started digging, okay Googling. Let’s just summarize that it wasn’t easy to dig up anything under VBA, but eventually I found a starting point, in a .net forum I believe, upon which I was able to build. The key was how to create a new blank canvas to insert the images into and the solution from that came from the following piece of code
The Basic Concept
Create a new Class Module and name it BmpGen and then paste the following into it
Option Compare Database
Option Explicit
'Source: Unknown, if anyone knows the original source please let me know!
'======
'BmpGen
'======
'
'A helper class for creating a solid-color image in BMP file
'format and returning it as a Byte array.
'
'This can be useful when working with WIA 2.0, since creating
'a blank image (ImageFile object) can be costly when using
'Vector.Add of the required number of Longs.
'
'Here we have just the MakeMono() method since a monochrome
'image works fine for our needs and WIA will "scale it up" to
'32-bit color as needed. This also keeps the array small
'(one bit per pixel).
'
'You could also add something like a MakeRGB() method that
'creates a "32 bit color" RGB BMP "file" for non-WIA purposes.
'
Private Const BI_RGB As Long = 0
Private Const PPM As Long = 3780 'Pixels per meter, we'll use 96 DPI.
'We can't use a BITMAPFILEHEADER due to padding added by VB6 following
'the bfType. So we're using this version with a junk Integer for
'padding:
Private Type BITMAPFILEHEADER_VB_HACK
bfJunk As Integer
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits 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
Private Type BITMAPINFO_MONOCHROME
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As Long 'RGBQUAD
End Type
Private Type BMP_HEADERS_MONO_VB_HACK
bmfHack As BITMAPFILEHEADER_VB_HACK
bmpiMono As BITMAPINFO_MONOCHROME
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Public Function MakeMono(ByVal BackColor As Long, _
ByVal WidthPx As Long, _
ByVal HeightPx As Long) As Byte()
Dim BitmapBitsSize As Long
Dim BmpHack As BMP_HEADERS_MONO_VB_HACK
Dim bytFullBmp() As Byte
BitmapBitsSize = ((WidthPx + 31) \ 32) * 4 * HeightPx
With BmpHack
With .bmpiMono
With .bmiHeader
.biSize = Len(BmpHack.bmpiMono.bmiHeader)
.biWidth = WidthPx
.biHeight = HeightPx
.biPlanes = 1
.biBitCount = 1 'Monochrome.
'.biCompression=BI_RGB 'Already 0.
.biSizeImage = BitmapBitsSize
.biXPelsPerMeter = PPM
.biYPelsPerMeter = PPM
.biClrUsed = 2 'Monochrome color table.
'.biClrImportant=0 'Means "all" and already 0.
End With
'Convert from "VB color" COLORREF BGR format value to RGBQUAD
'RGB format for our background "color 0" palette value:
.bmiColors(0) = (BackColor And &HFF00&) _
Or ((BackColor And &HFF&) * &H10000) _
Or (BackColor \ &H10000)
'.bmiColors(1) = 0 'Already 0.
End With
With .bmfHack
.bfType = &H4D42 'Little-endian "BM" file type.
.bfOffBits = Len(BmpHack) - 2
.bfSize = .bfOffBits + BitmapBitsSize
'Leave our bitmap bits all 0s since we want a solid
'color image based on color 0:
ReDim bytFullBmp(.bfOffBits + BitmapBitsSize - 1)
CopyMemory bytFullBmp(0), .bfType, .bfOffBits
End With
End With
MakeMono = bytFullBmp
End Function
Now that we have that critical piece, we can then easily manipulate and build our images using standard WIA. First we create a simple ENUM so we don’t have to deal with the image GUIDs directly. So create a standard Module and copy/paste in the following ENUM declaration
Public Enum wiaFormat
BMP = 0
GIF = 1
JPEG = 2
PNG = 3
TIFF = 4
End Enum
Then, copy paste in either, or both, of the following functions
Vertical Merging
'---------------------------------------------------------------------------------------
' Procedure : WIA_Combine2Images_Vertically
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Combine 2 image vertically into a single image
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
' Req: wiaFormat Enum and BmpGen class module
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile1 Fully qualified path and filename (with the extension) of the 1st
' image to combine into a single image
' sFile2 Fully qualified path and filename (with the extension) of the 2nd
' image to combine into a single image
' ** sFile1 will be the top image, sFile2 will be the bottom image **
' sResultingImage Fully qualified path and filename (without an extension) of the final
' file to be generated
' lFormat Format of the sResultingImage image, if not specified default to jpeg
' lQuality Quality level used when generating the sResultingImage image, if not
' specified default to 85%
' Note: it doesn't apply to all image formats! Yes -> JPEG
' No -> BMP, GIF, PNG, TIFF
'
' Usage:
' ~~~~~~
' WIA_Combine2Images_Vertically "C:\Temp\temp1.jpg", "C:\Temp\temp2.gif", "C:\Temp\TestImage"
' WIA_Combine2Images_Vertically "C:\Temp\temp1.jpg", "C:\Temp\temp2.gif", "C:\Temp\TestImage", , 50
' WIA_Combine2Images_Vertically "C:\Temp\temp1.jpg", "C:\Temp\temp2.jpg", "C:\Temp\TestImage", GIF
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-10-28 Public Release
'---------------------------------------------------------------------------------------
Public Function WIA_Combine2Images_Vertically(ByVal sFile1 As String, _
ByVal sFile2 As String, _
ByVal sResultingImage As String, _
Optional lFormat As wiaFormat = 2, _
Optional lQuality As Long = 85) As Boolean
Dim oIF1 As Object 'WIA.ImageFile
Dim oIF2 As Object 'WIA.ImageFile
Dim oVectNew As Object 'WIA.Vector
Dim oIFNew As Object 'WIA.ImageFile
Dim oIP As Object 'WIA.ImageProcess
Dim sFormatID As String
Dim sExt As String
Dim lPixelsWide As Long
Dim lPixelsHigh As Long
Const BG_COLOR As Long = vbBlack
On Error GoTo Error_Handler
'Convert our Enum over to the proper value used by WIA
Select Case lFormat
Case 0
sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
sExt = "BMP"
Case 1
sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
sExt = "GIF"
Case 2
sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
sExt = "JPEG"
Case 3
sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
sExt = "PNG"
Case 4
sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
sExt = "TIFF"
End Select
Set oIF1 = CreateObject("WIA.ImageFile") 'New WIA.ImageFile
With oIF1
.LoadFile sFile1
lPixelsWide = .Width
lPixelsHigh = .Height
End With
Set oIF2 = CreateObject("WIA.ImageFile") 'New WIA.ImageFile
With oIF2
.LoadFile sFile2
If .Width > lPixelsWide Then lPixelsWide = .Width 'Get the width only if it is wider than the 1st image
lPixelsHigh = lPixelsHigh + .Height
End With
'Create a new image file based on the dimensions we just determined above
With New BmpGen
Set oVectNew = CreateObject("WIA.Vector") 'New WIA.Vector
oVectNew.BinaryData = .MakeMono(BG_COLOR, lPixelsWide, lPixelsHigh)
End With
Set oIFNew = oVectNew.ImageFile
Set oVectNew = Nothing
'Append our images to this new image
Set oIP = CreateObject("WIA.ImageProcess")
With oIP
.Filters.Add .FilterInfos!Stamp.FilterID
With .Filters(1).Properties
Set !ImageFile = oIF1
!Left = 0
!Top = 0
End With
.Filters.Add .FilterInfos!Stamp.FilterID
With .Filters(2).Properties
Set !ImageFile = oIF2
!Left = 0
!Top = oIF1.Height
End With
.Filters.Add .FilterInfos!Convert.FilterID
With .Filters(3).Properties
!FormatID = sFormatID
!Quality = lQuality
End With
Set oIFNew = .Apply(oIFNew)
End With
'Save the new image
On Error Resume Next
Kill sResultingImage & "." & LCase(sExt)
On Error GoTo Error_Handler
oIFNew.SaveFile sResultingImage & "." & LCase(sExt)
WIA_Combine2Images_Vertically = True
Error_Handler_Exit:
On Error Resume Next
If Not oIP Is Nothing Then Set oIP = Nothing
If Not oIFNew Is Nothing Then Set oIFNew = Nothing
If Not oVectNew Is Nothing Then Set oVectNew = Nothing
If Not oIF2 Is Nothing Then Set oIF2 = Nothing
If Not oIF1 Is Nothing Then Set oIF1 = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WIA_Combine2Images_Vertically" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Horizontal Merging
'---------------------------------------------------------------------------------------
' Procedure : WIA_Combine2Images_Horizontally
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Combine 2 image horizontally into a single image
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
' Req: wiaFormat Enum and BmpGen class module
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile1 Fully qualified path and filename (with the extension) of the 1st
' image to combine into a single image
' sFile2 Fully qualified path and filename (with the extension) of the 2nd
' image to combine into a single image
' ** sFile1 will be the leftmost image, sFile2 will be the rightmost image **
' sResultingImage Fully qualified path and filename (without an extension) of the final
' file to be generated
' lFormat Format of the sResultingImage image, if not specified default to jpeg
' lQuality Quality level used when generating the sResultingImage image, if not
' specified default to 85%
' Note: it doesn't apply to all image formats! Yes -> JPEG
' No -> BMP, GIF, PNG, TIFF
'
' Usage:
' ~~~~~~
' WIA_Combine2Images_Horizontally "C:\Temp\temp1.jpg", "C:\Temp\temp2.gif", "C:\Temp\TestImage"
' WIA_Combine2Images_Horizontally "C:\Temp\temp1.jpg", "C:\Temp\temp2.gif", "C:\Temp\TestImage", , 50
' WIA_Combine2Images_Horizontally "C:\Temp\temp1.jpg", "C:\Temp\temp2.jpg", "C:\Temp\TestImage", GIF
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-10-28 Public Release
'---------------------------------------------------------------------------------------
Public Function WIA_Combine2Images_Horizontally(ByVal sFile1 As String, _
ByVal sFile2 As String, _
ByVal sResultingImage As String, _
Optional lFormat As wiaFormat = 2, _
Optional lQuality As Long = 85) As Boolean
Dim oIF1 As Object 'WIA.ImageFile
Dim oIF2 As Object 'WIA.ImageFile
Dim oVectNew As Object 'WIA.Vector
Dim oIFNew As Object 'WIA.ImageFile
Dim oIP As Object 'WIA.ImageProcess
Dim sFormatID As String
Dim sExt As String
Dim lPixelsWide As Long
Dim lPixelsHigh As Long
Const BG_COLOR As Long = vbWhite 'This will be the image background color for any blank areas if the images aren't exactly the same color.
On Error GoTo Error_Handler
'Convert our Enum over to the proper value used by WIA
Select Case lFormat
Case 0
sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
sExt = "BMP"
Case 1
sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
sExt = "GIF"
Case 2
sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
sExt = "JPEG"
Case 3
sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
sExt = "PNG"
Case 4
sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
sExt = "TIFF"
End Select
Set oIF1 = CreateObject("WIA.ImageFile") 'New WIA.ImageFile
With oIF1
.LoadFile sFile1
lPixelsWide = .Width
lPixelsHigh = .Height
End With
Set oIF2 = CreateObject("WIA.ImageFile") 'New WIA.ImageFile
With oIF2
.LoadFile sFile2
lPixelsWide = lPixelsWide + .Width
If .Height > lPixelsHigh Then lPixelsHigh = .Height 'Get the height only if it is higher than the 1st image
End With
'Create a new image file based on the dimensions we just determined above
With New BmpGen
Set oVectNew = CreateObject("WIA.Vector") 'New WIA.Vector
oVectNew.BinaryData = .MakeMono(BG_COLOR, lPixelsWide, lPixelsHigh)
End With
Set oIFNew = oVectNew.ImageFile
Set oVectNew = Nothing
'Append our images to this new image
Set oIP = CreateObject("WIA.ImageProcess")
With oIP
.Filters.Add .FilterInfos!Stamp.FilterID
With .Filters(1).Properties
Set !ImageFile = oIF1
!Left = 0
!Top = 0
End With
.Filters.Add .FilterInfos!Stamp.FilterID
With .Filters(2).Properties
Set !ImageFile = oIF2
!Left = oIF1.Width
!Top = 0
End With
.Filters.Add .FilterInfos!Convert.FilterID
With .Filters(3).Properties
!FormatID = sFormatID
!Quality = lQuality
End With
Set oIFNew = .Apply(oIFNew)
End With
'Save the new image
On Error Resume Next
Kill sResultingImage & "." & LCase(sExt)
On Error GoTo Error_Handler
oIFNew.SaveFile sResultingImage & "." & LCase(sExt)
WIA_Combine2Images_Horizontally = True
Error_Handler_Exit:
On Error Resume Next
If Not oIP Is Nothing Then Set oIP = Nothing
If Not oIFNew Is Nothing Then Set oIFNew = Nothing
If Not oVectNew Is Nothing Then Set oVectNew = Nothing
If Not oIF2 Is Nothing Then Set oIF2 = Nothing
If Not oIF1 Is Nothing Then Set oIF1 = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WIA_Combine2Images_Horizontally" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
and that’s it. You can now merge images as you see fit.
Since this is all generic VBA, this code should work throughout Office applications (Access, Excel, Word, PowerPoint, …) without issue.
Taking Things Further!
In my specific case, I needed to merge/combine more than 2 images together at a time and the exact number was variable. I could repetitively call the combine functions above over and over, but that is less than an ideal solution, so I pursued development and came up with the 2 functions below that accept an array of files as the input, so you can specify as many files to combine in one call.
Vertical Multiple Merging
'---------------------------------------------------------------------------------------
' Procedure : WIA_Combine2Images_Vertically
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Combine multiple images vertically into a single image
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
' Req: wiaFormat Enum and BmpGen class module
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' aFiles An array of fully qualified path and filename (with the extension)
' of all the images to combine into a single image
' sResultingImage Fully qualified path and filename (without an extension) of the final
' file to be generated
' lFormat Format of the sResultingImage image, if not specified default to jpeg
' lQuality Quality level used when generating the sResultingImage image, if not
' specified default to 85%
' Note: it doesn't apply to all image formats! Yes -> JPEG
' No -> BMP, GIF, PNG, TIFF
'
' Usage:
' ~~~~~~
' WIA_CombineImages_Vertically array("C:\Temp\temp1.jpg", "C:\Temp\temp2.gif", "C:\Temp\temp3.jpg"), "C:\Temp\TestImage"
' WIA_CombineImages_Vertically array("C:\Temp\temp1.jpg", "C:\Temp\temp2.gif"), "C:\Temp\TestImage", , 50
' WIA_CombineImages_Vertically array("C:\Temp\temp1.jpg", "C:\Temp\temp2.jpg"), "C:\Temp\TestImage", GIF
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-10-28 Public Release
'---------------------------------------------------------------------------------------
Public Function WIA_CombineImages_Vertically(ByVal aFiles As Variant, _
ByVal sResultingImage As String, _
Optional lFormat As wiaFormat = 2, _
Optional lQuality As Long = 85) As Boolean
Dim oVectNew As Object 'WIA.Vector
Dim oIFNew As Object 'WIA.ImageFile
Dim oIP As Object 'WIA.ImageProcess
Dim oWIAImage() As Object
Dim sFormatID As String
Dim sExt As String
Dim lPixelsWide As Long
Dim lPixelsHigh As Long
Dim lHeight As Long
Dim lngVar As Long
Const BG_COLOR As Long = vbWhite 'vbBlack
On Error GoTo Error_Handler
'Convert our Enum over to the proper value used by WIA
Select Case lFormat
Case 0
sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
sExt = "BMP"
Case 1
sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
sExt = "GIF"
Case 2
sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
sExt = "JPEG"
Case 3
sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
sExt = "PNG"
Case 4
sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
sExt = "TIFF"
End Select
ReDim oWIAImage(UBound(aFiles)) As Object
For lngVar = 0 To UBound(aFiles)
Set oWIAImage(lngVar) = CreateObject("WIA.ImageFile") 'New WIA.ImageFile
With oWIAImage(lngVar)
.LoadFile aFiles(lngVar)
If .Width > lPixelsWide Then lPixelsWide = .Width
lPixelsHigh = lPixelsHigh + .Height
End With
Next lngVar
'Create a new image file based on the dimensions we just determined above
With New BmpGen
Set oVectNew = CreateObject("WIA.Vector") 'New WIA.Vector
oVectNew.BinaryData = .MakeMono(BG_COLOR, lPixelsWide, lPixelsHigh)
End With
Set oIFNew = oVectNew.ImageFile
Set oVectNew = Nothing
'Append our images to this new image
Set oIP = CreateObject("WIA.ImageProcess")
With oIP
For lngVar = 0 To UBound(oWIAImage)
.Filters.Add .FilterInfos!Stamp.FilterID
With .Filters(lngVar + 1).Properties
Set !ImageFile = oWIAImage(lngVar)
!Left = 0
!Top = lHeight
End With
lHeight = lHeight + oWIAImage(lngVar).Height
Next lngVar
.Filters.Add .FilterInfos!Convert.FilterID
With .Filters(lngVar + 1).Properties
!FormatID = sFormatID
!Quality = lQuality
End With
Set oIFNew = .Apply(oIFNew)
End With
'Save the new image
On Error Resume Next
Kill sResultingImage & "." & LCase(sExt)
On Error GoTo Error_Handler
oIFNew.SaveFile sResultingImage & "." & LCase(sExt)
WIA_CombineImages_Vertically = True
Error_Handler_Exit:
On Error Resume Next
If Not oIP Is Nothing Then Set oIP = Nothing
If Not oIFNew Is Nothing Then Set oIFNew = Nothing
If Not oVectNew Is Nothing Then Set oVectNew = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WIA_CombineImages_Vertically" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Horizontal Multiple Merging
'---------------------------------------------------------------------------------------
' Procedure : WIA_CombineImages_Horizontally
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Combine multiple images horizontally into a single image
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
' Req: wiaFormat Enum and BmpGen class module
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' aFiles An array of fully qualified path and filename (with the extension)
' of all the images to combine into a single image
' sResultingImage Fully qualified path and filename (without an extension) of the final
' file to be generated
' lFormat Format of the sResultingImage image, if not specified default to jpeg
' lQuality Quality level used when generating the sResultingImage image, if not
' specified default to 85%
' Note: it doesn't apply to all image formats! Yes -> JPEG
' No -> BMP, GIF, PNG, TIFF
'
' Usage:
' ~~~~~~
' WIA_CombineImages_Horizontally array*"C:\Temp\temp1.jpg", "C:\Temp\temp2.gif", "C:\Temp\temp3.jpg"), "C:\Temp\TestImage"
' WIA_CombineImages_Horizontally array("C:\Temp\temp1.jpg", "C:\Temp\temp2.gif"), "C:\Temp\TestImage", , 50
' WIA_CombineImages_Horizontally array("C:\Temp\temp1.jpg", "C:\Temp\temp2.jpg"), "C:\Temp\TestImage", GIF
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2019-10-28 Public Release
'---------------------------------------------------------------------------------------
Public Function WIA_CombineImages_Horizontally(ByVal aFiles As Variant, _
ByVal sResultingImage As String, _
Optional lFormat As wiaFormat = 2, _
Optional lQuality As Long = 85) As Boolean
Dim oVectNew As Object 'WIA.Vector
Dim oIFNew As Object 'WIA.ImageFile
Dim oIP As Object 'WIA.ImageProcess
Dim oWIAImage() As Object
Dim sFormatID As String
Dim sExt As String
Dim lPixelsWide As Long
Dim lPixelsHigh As Long
Dim lWidth As Long
Dim lngVar As Long
Const BG_COLOR As Long = vbWhite 'vbBlack
On Error GoTo Error_Handler
'Convert our Enum over to the proper value used by WIA
Select Case lFormat
Case 0
sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
sExt = "BMP"
Case 1
sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
sExt = "GIF"
Case 2
sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
sExt = "JPEG"
Case 3
sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
sExt = "PNG"
Case 4
sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
sExt = "TIFF"
End Select
ReDim oWIAImage(UBound(aFiles)) As Object
For lngVar = 0 To UBound(aFiles)
Set oWIAImage(lngVar) = CreateObject("WIA.ImageFile") 'New WIA.ImageFile
With oWIAImage(lngVar)
.LoadFile aFiles(lngVar)
lPixelsWide = lPixelsWide + .Width
If .Height > lPixelsHigh Then lPixelsHigh = .Height
End With
Next lngVar
'Create a new image file based on the dimensions we just determined above
With New BmpGen
Set oVectNew = CreateObject("WIA.Vector") 'New WIA.Vector
oVectNew.BinaryData = .MakeMono(BG_COLOR, lPixelsWide, lPixelsHigh)
End With
Set oIFNew = oVectNew.ImageFile
Set oVectNew = Nothing
'Append our images to this new image
Set oIP = CreateObject("WIA.ImageProcess")
With oIP
For lngVar = 0 To UBound(oWIAImage)
.Filters.Add .FilterInfos!Stamp.FilterID
With .Filters(lngVar + 1).Properties
Set !ImageFile = oWIAImage(lngVar)
!Left = lWidth
!Top = 0
End With
lWidth = lWidth + oWIAImage(lngVar).Width
Next lngVar
.Filters.Add .FilterInfos!Convert.FilterID
With .Filters(lngVar + 1).Properties
!FormatID = sFormatID
!Quality = lQuality
End With
Set oIFNew = .Apply(oIFNew)
End With
'Save the new image
On Error Resume Next
Kill sResultingImage & "." & LCase(sExt)
On Error GoTo Error_Handler
oIFNew.SaveFile sResultingImage & "." & LCase(sExt)
WIA_CombineImages_Horizontally = True
Error_Handler_Exit:
On Error Resume Next
If Not oIP Is Nothing Then Set oIP = Nothing
If Not oIFNew Is Nothing Then Set oIFNew = Nothing
If Not oVectNew Is Nothing Then Set oVectNew = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WIA_CombineImages_Horizontally" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
So now, you can, with a single function, combine as many images together as you’d like and only make one I/O to the disk to save the final result.
Special Thanks
I’d like to thank a couple of my fellow MVP (or MVP Alum) for their critical assistance in how I could create an unknown number of objects in my functions, in no particular order:
- The Smiley Coder
- Tom van Stiphout
- Adrian Bell
Wow, it blow my mind how great it actually works, I am using it in Excel to parse JPEGs and works flawlessly. Even handling 600+ files and final size being over 70MB. Definitely will drop it in my tool box
Excellent code and many thanks for publishing it.
Worked like a dream.
Ben
Hi,
Is there any way to export the PNG/JPG to an animated GIF?
Not with WIA, not to my knowledge. There are exe utilities you can download and feed your images to and that output Animated GIFs, and which you could automate to do the job though.
Brilliant. Worked perfectly. Saved me many days of work. Thanks so much!!!!!
I was able to use a very slightly modified version of this script to put an image signature on top of some image documents. I couldn’t even do it using an RPA software. An absolutely great script!
Glad it was helpful.
Hi Kirbs, could you please post the modified script here. I have similar need.
Thanks
Hi Daniel, thanks for posting this code. I sometimes get memory error. My computer has 32-cores and 128gb memory. Is there any WIA limitation on size of final image. My output image would be approx 22gigapixel?
Hi Daniel,
Thanks a lot for this code, it’s easy to implement and works really well! The images I am combining to have a bit of overlaps, do you think there would be a way for me to crop the images in this script? Or would you recommend using another module which would first crop the images before I combine them?
Best regards,
Sam
how can stamp just two stream data,i dont want save file or load file i have just two binary data as array or stream data , now how can use stamp?
I’m afraid I’m not sure I understand the question properly. I’d recommend you ask your question in a forum to benefit from the help of many.
i resolved my problem with use a special class name “cGDIPlusCache”
https://www.vbforums.com/showthread.php?898911
i can examplin better,my language is not english
i have a() and b() array for keep images stream now i want use stamp wia for can stamp these streams,how can do that?
i have no any file exteranl i have just some arrays ,i asked in some forums too like as this :
https://stackoverflow.com/questions/75193778/possible-to-use-wia-stamp-for-stamp-2-stream-data-in-vb6-without-use-file-addres
or
https://www.vbforums.com/showthread.php?898911-how-can-use-wia-for-stamp-a-image-of-picturebox-with-a-pngstream-or-without-wia&p=5592325#post5592325
there is no matter to use wia or other way i jst do like as tamp with these two arrays
Apologies this is an old post.
Having copied and pasted your code as instructed I get a compile error :
‘Create a new image file based on the dimensions we just determined above
With New BmpGen
User-defined type not defined
I can’t see anywhere in your code that creates a BmpGen ?
It’s the class module at the very beginning of the article.
Did you follow the instructions “Create a new Class Module and name it BmpGen and then paste the following”? That will allow the code to function properly.