insert image with true size doesn't work

B

basb87

New Member
Joined
May 3, 2017
Messages
30
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
Have you tried ticking the Do not compress images in file checkbox under Options|Advanced|Image Size and Quality ?
 
Upvote 0
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:

VBA Code: 
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:
VBA Code: 
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
 
Last edited:
Upvote 0
Jaafar Tribak said:
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:

VBA Code: 
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:
VBA Code: 
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
Click to expand...
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
 
Upvote 0
Do you know if it's possible to check how much DPI an image has, with VBA?
Click to expand...
One easy way is by using WIA library, just like we did above.

Here is this GetImageDPI routine:
VBA Code: 
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:

VBA Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
font size in outlook email (12 points doesn't work)
2
Replies
13
Views
289
basb87
B
melodramatic
  • Question Question
Vba - insert photo with varying sizes
Replies
1
Views
528
Micron
M
O
  • Question Question
VBA insert image from url and lock original aspect ratio even when resizing columns and rows
Replies
1
Views
4K
Anthony47
A
K
  • Question Question
Inserting pictures from folder automatically with VBA
Replies
1
Views
2K
kefier
K
C
  • Question Question
INSERTING A BLANK ROW BETWEEN LISTBOX ROWS
Replies
3
Views
1K
BSALV
BSALV

Forum statistics

Threads
1,223,903
Messages
6,175,287
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top