Calculate the correct image size of Image

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.