Calculate the correct image size of Image - vba

Question

I have a script that lets me select a folder and load single or multiple images in different image formats.
Then it creates a two-column table and places the loaded images in the left column.
In the right column, the file name and the original image size are displayed.
But I have problems calculating the correct image size in pixels.
Here is my script; the problem starts following the comment below:
'Image height and width
On Error GoTo fehler
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
Dim pic As InlineShape, bildname As String, pfad As String, details As String
Dim bildHoehePt As Single, bildbreitePt As Single
Dim faktor As Single, origbreitePt As Single, origbreiteCm As Single, orighoehePt As Single, orighoeheCm As Single
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files And click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
' Add a 'Picture' caption label
CaptionLabels.Add Name:="Picture"
'Add a 1-row by 3-column table with same width to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 1, 3)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 1 / 3, RulerStyle:=wdAdjustProportional
.Borders.Enable = True
End With
For i = 1 To .SelectedItems.Count
' Add extra rows as needed
With oTbl
If i > .Rows.Count Then oTbl.Rows.Add
With .Rows(i)
.Range.Style = "Normal" 'In a German Word version, change "Normal" to "Standard"
.Cells(1).Range.Text = vbCr
.Cells(1).Range.Characters.Last.Style = "Caption" 'In a German Word version, change "Caption" to "Beschriftung"
End With
End With
'Insert the Picture
Set pic = ActiveDocument.InlineShapes.AddPicture(FileName:=.SelectedItems(i), _
LinkToFile:=False, SaveWithDocument:=True, _
Range:=oTbl.Cell(i, 1).Range.Characters.First)
' Image name and path
pfad = .SelectedItems(i)
bildname = Mid(pfad, InStrRev(pfad, "\", -1) + 1)
MsgBox "Pfad " & pfad & vbLf & "Filename: " & bildname
'Image height and width
bildbreitePt = pic.Width
bildHoehePt = pic.Height
' Scale factor
faktor = pic.ScaleWidth
'Original size
origbreitePt = bildbreitePt / faktor * 100 ' pt
orighoehePt = bildHoehePt / faktor * 100 'Pt
origbreiteCm = origbreitePt * 0.0353 'cm
orighoeheCm = orighoehePt * 0.0353
'Bilddetails zusammensetzen
details = "Filename: " & bildname & vbLf & "ImageSize (cm): " & origbreiteCm & " x " & orighoeheCm & vbLf & _
"Scaling: " & faktor & "%" & " BildbreitePt: " & bildbreitePt & " OrigbreitePt: " & origbreitePt & " OrigbreitePX: " & origbreitePX
' Insert the Caption on the line below the picture
With oTbl.Cell(i, 1).Range
.Characters.Last.Previous.InsertCaption Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionAbove, ExcludeLabel:=False
.Characters.Last.Previous = vbNullString
End With
'Writes the image details in column 2
oTbl.Cell(i, 2).Range = details
Next
End If
End With
Application.ScreenUpdating = True
Exit Sub
fehler:
Application.ScreenUpdating = True
MsgBox "Fehler: " & Err.Number & ": " & Err.Description
End Sub```
**Can anyone help me to get the correct image size (width and length) in pixels?**
Thank you very much and best regards

Answer 1

Max, I have used Domenic's answer and integrated it with your code. It seems to work, and produces the following document for two sample images I used (snapshot below is for the MS Word document created):
I checked the image dimensions using Paint.Net, and they are correct. I left the MsgBox statements in the code (commented out) for you to test with if necessary. Let me know if you have questions.
You mention that the code creates two columns; your code actually created a table of three columns. I used a variable called ColumnCount that you can set for the number of columns you want. It's currently set to two columns.
You can download the MS Word macro document and the two images here: https://1drv.ms/u/s!AjKDc68HR6lQkHlLfdPppPIAIgk9?e=UBdAy6
Note: I have upvoted Domenic's answer, and I hope you will do the same.
Sub Mumm()
On Error GoTo fehler
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
Dim pic As InlineShape, bildname As String, pfad As String, details As String
Dim bildHoehePt As Single, bildbreitePt As Single
Dim faktor As Single, origbreitePt As Single, origbreiteCm As Single, orighoehePt As Single, orighoeheCm As Single
Dim foldername As String
Dim Pos_of_x As Integer
Dim Width As Integer
Dim Height As Integer
Dim pixel_dimensions As Variant
Dim shell_app As Object
Dim ColumnCount As Integer
' Number of columns in the table
ColumnCount = 2
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
' Add a 'Picture' caption label
CaptionLabels.Add Name:="Picture"
'Insert table row.
Set oTbl = Selection.Tables.Add(Selection.Range, 1, ColumnCount)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 1 / ColumnCount, RulerStyle:=wdAdjustProportional
.Borders.Enable = True
End With
Set shell_app = CreateObject("Shell.Application")
For i = 1 To .SelectedItems.Count
' Add extra rows as needed
With oTbl
If i > .Rows.Count Then oTbl.Rows.Add
With .Rows(i)
.Range.Style = "Normal" 'In a German Word version, change "Normal" to "Standard"
.Cells(1).Range.Text = vbCr
.Cells(1).Range.Characters.Last.Style = "Caption" 'In a German Word version, change "Caption" to "Beschriftung"
End With ' .Rows(i)
End With ' oTbl
'Insert the Picture
Set pic = ActiveDocument.InlineShapes.AddPicture(FileName:=.SelectedItems(i), _
LinkToFile:=False, SaveWithDocument:=True, _
Range:=oTbl.Cell(i, 1).Range.Characters.First)
' Image name and path
pfad = .SelectedItems(i)
bildname = Mid(pfad, InStrRev(pfad, "\", -1) + 1)
foldername = Left(pfad, InStrRev(pfad, "\"))
' MsgBox _
' "pfad (image pathname): " & pfad & vbLf & _
' "foldername: " & foldername & vbLf & _
' "bildname (image filename): " & bildname
'Image height and width
pixel_dimensions = GetImagePixelDimensions(shell_app, foldername, bildname)
Pos_of_x = InStr(pixel_dimensions, "x")
Width = Mid(pixel_dimensions, 1, Pos_of_x - 2)
Height = Mid(pixel_dimensions, Pos_of_x + 2, Len(pixel_dimensions))
' MsgBox _
' "pixel_dimensions: " & pixel_dimensions & vbLf & _
' "Width: " & Width & vbLf & _
' "Height: " & Height
bildbreitePt = Width
bildHoehePt = Height
' Scale factor
faktor = pic.ScaleWidth
'Original size
origbreitePt = bildbreitePt / faktor * 100 ' pt
orighoehePt = bildHoehePt / faktor * 100 'Pt
origbreiteCm = origbreitePt * 0.0353 'cm
orighoeheCm = orighoehePt * 0.0353
'Bilddetails zusammensetzen
details = "Filename: " & bildname & vbLf & "ImageSize (cm): " & origbreiteCm & " x " & orighoeheCm & vbLf & _
"Scaling: " & faktor & "%" & " BildbreitePt: " & bildbreitePt & " OrigbreitePt: " & origbreitePt & " OrigbreitePX: " & origbreitePX
' Insert the Caption on the line below the picture
With oTbl.Cell(i, 1).Range
.Characters.Last.Previous.InsertCaption Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionAbove, ExcludeLabel:=False
.Characters.Last.Previous = vbNullString
End With ' oTbl.Cell(i, 1).Range
'Writes the image details in column 2
oTbl.Cell(i, 2).Range = details
Next ' For i = 1 To .SelectedItems.Count
End If ' If .Show = -1 Then
End With ' With Application.FileDialog(msoFileDialogFilePicker)
Application.ScreenUpdating = True
Exit Sub
fehler:
Application.ScreenUpdating = True
MsgBox "Fehler: " & Err.Number & ": " & Err.Description
End Sub
Function GetImagePixelDimensions(ByVal shell_app As Object, ByVal path As String, ByVal image_filename As String) As Variant
' From here: https://stackoverflow.com/a/62647100/
Dim Pos_of_x As Integer
Dim Width As Integer
Dim Height As Integer
On Error GoTo error_handler
Dim shell_folder As Object
Set shell_folder = shell_app.Namespace(CVar(path)) 'Namespace requires a Variant
Dim pixel_dimensions As String
pixel_dimensions = shell_folder.ParseName(image_filename).ExtendedProperty("Dimensions")
pixel_dimensions = Replace(pixel_dimensions, ChrW(8234), "") 'remove the LEFT-TO-RIGHT EMBEDDING invisible character
pixel_dimensions = Replace(pixel_dimensions, ChrW(8236), "") 'remove the POP DIRECTIONAL FORMATTING invisible character
'Pos_of_x = InStr(pixel_dimensions, "x")
'Width = Mid(pixel_dimensions, 1, Pos_of_x - 2)
'Height = Mid(pixel_dimensions, Pos_of_x + 2, Len(pixel_dimensions))
'MsgBox "pixel_dimensions: " & pixel_dimensions & vbLf & "Width: " & Width & vbLf & "Height: " & Height
GetImagePixelDimensions = pixel_dimensions
Exit Function
error_handler:
GetImagePixelDimensions = CVErr(2015) 'xlErrValue
End Function
Sub test_GetImagePixelDimensions()
Dim shell_app As Object
Set shell_app = CreateObject("Shell.Application")
Dim pixel_dimensions As Variant
pixel_dimensions = GetImagePixelDimensions(shell_app, "C:\TMP\", "image_68_KB.jpg")
If Not IsError(pixel_dimensions) Then
MsgBox "Dimensions: " & pixel_dimensions
Else
MsgBox "Unable to get the dimensions."
End If
End Sub

Answer 2

The following function will return the dimensions of an image file in pixels. Note that you'll need to pass it in a Shell Application object, along with the path and image filename.
The reason why the Shell Application object is created in the calling procedure and passed in to the called function is that you'll be using it in a loop. If it were created in the called function, you would be needlessly creating multiple Shell Application objects.
Also, note that the function will return an error value when the path and/or image filename does not exist. However, you'll be able to test for an error using the IsError function.
Here's the function...
Function GetImagePixelDimensions(ByVal shell_app As Object, ByVal path As String, ByVal image_filename As String) As Variant
On Error GoTo error_handler
Dim shell_folder As Object
Set shell_folder = shell_app.Namespace(CVar(path)) 'Namespace requires a Variant
Dim pixel_dimensions As String
pixel_dimensions = shell_folder.ParseName(image_filename).ExtendedProperty("Dimensions")
pixel_dimensions = Replace(pixel_dimensions, ChrW(8234), "") 'remove the LEFT-TO-RIGHT EMBEDDING invisible character
pixel_dimensions = Replace(pixel_dimensions, ChrW(8236), "") 'remove the POP DIRECTIONAL FORMATTING invisible character
GetImagePixelDimensions = pixel_dimensions
Exit Function
error_handler:
GetImagePixelDimensions = CVErr(2015) 'xlErrValue
End Function
And here's an example of how the function can be called...
Sub test()
Dim shell_app As Object
Set shell_app = CreateObject("Shell.Application")
Dim pixel_dimensions As Variant
pixel_dimensions = GetImagePixelDimensions(shell_app, "c:\users\domenic\pictures", "image_filename.jpg")
If Not IsError(pixel_dimensions) Then
MsgBox "Dimensions: " & pixel_dimensions
Else
MsgBox "Unable to get the dimensions."
End If
End Sub
Change the path and image filename accordingly.