insert image with true size doesn't work

[basb87]

Hi guys, I hope you can help me with a problem I am facing with inserting pictues in Excel. Somehow the size of the pictures when inserted are the same, while one of them is quite larger.

To make it very clear, I uploaded a little video on youtube, showing the problem:

Does anyone know how to solve this?

Best regards, Bas

 

[Jaafar Tribak]

Have you tried ticking the Do not compress images in file checkbox under Options|Advanced|Image Size and Quality ?

 

[basb87]

Have you tried ticking the Do not compress images in file checkbox under Options|Advanced|Image Size and Quality ?

Yes, I tried this also. It did not work

 

[Jaafar Tribak]

I have no idea why you are getting the erroneaous size for the 2nd picture. Maybe someone here knows.

But if using vba is ok with you, you could use the following AdjustImageSize routine to quickly adjust the size of the picture after it has been inserted on the worksheet. The size adjustment will be based on the actual pixel size of the original picture file.

1- In a Standard Module:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#End If

Sub AdjustImageSize(ByVal Pic As Shape, ByVal FilePathName As String)
    Dim img As Object, w As Double, h As Double
    On Error GoTo errHandler
    Set img = CreateObject("WIA.ImageFile")
    img.LoadFile FilePathName
    w = img.FileData.ImageFile.Width
    h = img.FileData.ImageFile.Height
    With Pic
        .Height = PXtoPT(h, True)
        .Width = PXtoPT(w, False)
    End With
    Set img = Nothing
    Exit Sub
errHandler:
    MsgBox Err.Description & vbLf & "Error# : " & Err.Number
End Sub

Function ScreenDPI(ByVal bVert As Boolean) As Long
    #If Win64 Then
        Const NULL_PTR = 0^
    #Else
        Const NULL_PTR = 0&
    #End If
    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    Static lDPI(1) As Long, hDC As LongPtr
    If lDPI(0&) = 0& Then
        hDC = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(NULL_PTR, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72&
    PXtoPT = (Pixels * POINTSPERINCH) / ScreenDPI(bVert)
End Function

2- Usage Example:

Sub Example()
    Dim sFilename As String, oShp As Shape
    sFilename = "C:\Images\MyPic.png"     '<= change to suit.
    Set oShp = Sheet1.Shapes("Picture 2") '<= change to suit.
    Call AdjustImageSize(Pic:=oShp, FilePathName:=sFilename)
End Sub

 

[basb87]

I have no idea why you are getting the erroneaous size for the 2nd picture. Maybe someone here knows.

But if using vba is ok with you, you could use the following AdjustImageSize routine to quickly adjust the size of the picture after it has been inserted on the worksheet. The size adjustment will be based on the actual pixel size of the original picture file.

1- In a Standard Module:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#End If

Sub AdjustImageSize(ByVal Pic As Shape, ByVal FilePathName As String)
    Dim img As Object, w As Double, h As Double
    On Error GoTo errHandler
    Set img = CreateObject("WIA.ImageFile")
    img.LoadFile FilePathName
    w = img.FileData.ImageFile.Width
    h = img.FileData.ImageFile.Height
    With Pic
        .Height = PXtoPT(h, True)
        .Width = PXtoPT(w, False)
    End With
    Set img = Nothing
    Exit Sub
errHandler:
    MsgBox Err.Description & vbLf & "Error# : " & Err.Number
End Sub

Function ScreenDPI(ByVal bVert As Boolean) As Long
    #If Win64 Then
        Const NULL_PTR = 0^
    #Else
        Const NULL_PTR = 0&
    #End If
    Const LOGPIXELSX As Long = 88&, LOGPIXELSY As Long = 90&
    Static lDPI(1) As Long, hDC As LongPtr
    If lDPI(0&) = 0& Then
        hDC = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
        hDC = ReleaseDC(NULL_PTR, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
 
Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72&
    PXtoPT = (Pixels * POINTSPERINCH) / ScreenDPI(bVert)
End Function

2- Usage Example:

Sub Example()
    Dim sFilename As String, oShp As Shape
    sFilename = "C:\Images\MyPic.png"     '<= change to suit.
    Set oShp = Sheet1.Shapes("Picture 2") '<= change to suit.
    Call AdjustImageSize(Pic:=oShp, FilePathName:=sFilename)
End Sub

Hi Jaafar, thank you very much.

I later found out that the problem was caused by a DPI setting. The difference between the first and second image was that the second image was 400 DPI, while the first image had a DPI that was much lower. Do you know if it's possible to check how much DPI an image has, with VBA? Maybe I can then use a multiplier to change the height and width of the image, based on how much DPI it has.

Best regards, Bas

 

[Jaafar Tribak]

Do you know if it's possible to check how much DPI an image has, with VBA?

One easy way is by using WIA library, just like we did above.

Here is this GetImageDPI routine:

Sub GetImageDPI( _
    ByVal FilePathName As String, _
    ByRef HorzDPI As Long, _
    ByRef VertDPI As Long _
)
    Dim img As Object
    On Error GoTo errHandler
    Set img = CreateObject("WIA.ImageFile")
    img.LoadFile FilePathName
    HorzDPI = img.HorizontalResolution
    VertDPI = img.VerticalResolution
    Set img = Nothing
    Exit Sub
errHandler:
    MsgBox Err.Description & vbLf & "Error# : " & Err.Number
End Sub

Then, in order to get the DPI values of the image file, you can use the above routine like in the following example:

Sub Test()
    Dim DPI_X As Long, DPI_Y As Long
    Dim sFimePathName As String
    
    sFimePathName = "C:\Images\MyPic.png" '<== change path to suit.
    
    Call GetImageDPI(FilePathName:=sFimePathName, _
                     HorzDPI:=DPI_X, _
                     VertDPI:=DPI_Y)
    If DPI_X Then
        Debug.Print "=========================="
        Debug.Print "Image DPI vals for: '"; sFimePathName & "'"
        Debug.Print "HorzDPI:"; DPI_X, "VertDPI:"; DPI_Y
        Debug.Print "=========================="
    End If
End Sub