Retrieving the Actual Size of a Shape ?

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,616
Office Version
  1. 2016
Platform
  1. Windows
Cosider the two following worksheet star shapes .. The shape at the bottom is in fact an exact copy of the shape at the top, but with an added black thick outline.

Visually, the size of the shape at the bottom is clearly bigger after having added the black outline to it and one would expect that the Width and Height Properties of the shape at the bottom would be greater than the Width and Height of the shape at the top but, that's not the case.... Both shapes still have the same Widths and Heights despite one being physically bigger than the other.

Does anybody know how I could get the actual size of the shape with the outline ? I have tried adding .Line.Weight and a couple of other tricks like grouping but with no success... Is there some Property or Method in the Shape Class which I am not aware of that could be used to solve this ?

Thanks.


image_2020-10-22_224341.png
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
It is an interesting puzzle, which I will be watching to see how you progress
I cannot help answer your questions, but I played around and noticed the following which may help you indirectly (maybe ?)

1. With a very thick line, the shape becomes wider than VBA's Shape.Width and left edge of shape placed in column A (as far to left of cell as possible), disappears off the screen
ShapeLineWidthColumnA.jpg

2. The shape itself appears to get smaller when the line becomes wider The only diiference between the shapes is that the Line width goes from 1pt to 25pt to 50 pt

ShapeLineWidth.jpg


3. The star with thick line (50 pt) becomes bigger than square with thick line (also 50pt) - see above picture


4. If macro assigned to the 50pt star you must click on the visible star to run the macro - the area in between does not trigger the macro. When star is 1pt, and fits inside VBA shape then clicking anywhere inside the VBA shape triggers the macro

ShapeLineWidthTrigger.jpg
 
Last edited:
Upvote 0
Does this advance you in any way. My 2 hour struggle to get the code to return the line weight.

Code: 
xx = ActiveSheet.Shapes.Range(Array("5-Point Star 5")).Line.Weight
 
Upvote 0
Ignore that. I should have read the question again after finding the Line Weight!
 
Upvote 0
I would have expected the excel IShape interface to expose some Property or Method for reading the actual physical Width and Height but that doesn't seem to be the case ... I have looked through the IShape and IShapeRange members in the VBE Object Browser (F2) (including hidden members) but couldn't find anything.
 
Upvote 0
Using UIAutomation offers some hope, but it is an ugly workaround as it requires that the shape be fully visible on screen when calling the function.

Note: Code requires to set a project reference to UIAutomationClient library (UIAutomationCore.dll)

VBA Code: 
Option Explicit

Type POINTAPI
    x As Long
    y As Long
End Type

Type Size
    cx As Single
    cy As Single
End Type

#If VBA7 Then
    Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
    Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If



Function GetShapeRealSize(ByVal Shp As Shape) As Size

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    Dim oAutomation As IUIAutomation
    Dim oAllElements As IUIAutomationElementArray
    Dim oElement As IUIAutomationElement
    Dim oCondition As IUIAutomationCondition
    Dim tTagRect As tagRECT, tSize As Size, tLocation As POINTAPI
    Dim sTitle As String, i As Long, oWs As Worksheet
    
    On Error GoTo errHandler
    
    If Not Shp.Parent Is ActiveSheet Then
        Set oWs = ActiveSheet
        Application.EnableEvents = False
        Shp.Parent.Activate
        Application.EnableEvents = True
    End If
    
    sTitle = Shp.Title
    Shp.Title = "^|^|^|^|"
    
    With Shp
        tLocation.x = .Left
        tLocation.y = .Top
    End With
    
    With ActiveWindow.VisibleRange
        Shp.Left = (.Left + .Width) / 2
        Shp.Top = (.Top + .Height) / 2
    End With
    
    Application.Wait Now + TimeSerial(0, 0, 0.2)
    
    Set oAutomation = New CUIAutomation
    
    hwnd = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString)
    hwnd = FindWindowEx(hwnd, 0, "EXCEL7", vbNullString)
    Set oElement = oAutomation.ElementFromHandle(ByVal hwnd)
    
    Set oCondition = oAutomation.CreateTrueCondition
    Set oAllElements = oElement.FindAll(TreeScope_Descendants, oCondition)
    
    For i = 0 To oAllElements.Length - 1
        Set oElement = oAllElements.GetElement(i)
        If oElement.CurrentControlType = UIA_ImageControlTypeId And InStr(1, oElement.CurrentName, "^|^|^|^|") Then
            tTagRect = oElement.CurrentBoundingRectangle
            With tSize
                .cx = PXtoPT(tTagRect.Right - tTagRect.Left, False) / ActiveWindow.Zoom * 100
                .cy = PXtoPT(tTagRect.Bottom - tTagRect.Top, True) / ActiveWindow.Zoom * 100
                GetShapeRealSize = tSize
                Exit For
            End With
        End If
        DoEvents
    Next
    
errHandler:

    Shp.Title = sTitle
    With Shp
        Shp.Left = tLocation.x
        Shp.Top = tLocation.y
    End With
    If Not oWs Is Nothing Then
        Application.EnableEvents = False
        oWs.Activate
    End If
    Application.EnableEvents = True

End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    #If Win64 Then
        Dim hdc As LongLong
    #Else
        Dim hdc As Long
    #End If

    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1) As Long

    If lDPI(0) = 0 Then
        hdc = GetDC(0)
        lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If
    
    ScreenDPI = lDPI(Abs(bVert))

End Function

Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72
    PXtoPT = Pixels / (ScreenDPI(bVert) / POINTSPERINCH)
End Function


Usage Example:
VBA Code: 
Sub TEST()
 
    Dim tSize As Size
    
    tSize = GetShapeRealSize(Sheet1.Shapes("star"))
    Debug.Print "Real Width: " & tSize.cx & " pt" & vbTab & vbTab & "Real Height: " & tSize.cy & " pt"
    
    
    'Set the Width & Height of a dummy star shape for testing.
    Dim oDummyStarShape As Shape
    
    Set oDummyStarShape = Sheet1.Shapes.AddShape(msoShape5pointStar, 0, 0, tSize.cx, tSize.cy)

End Sub
 
Upvote 0
I figured out a clean way for getting the actual size of the shape without the need to select the sheet or bring the shape into view ... Works regardless of where the shape happens to be located when calling the function.

VBA Code: 
Option Explicit

Private Type Size
    cx As Single
    cy As Single
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If Win64 Then
        bmBits As LongLong
    #Else
        bmBits As Long
    #End If
End Type

#If VBA7 Then
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    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
#Else
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If
  
  
  
Private Function GetShapeRealSize(ByVal Shp As Shape) As Size

    Const IMAGE_BITMAP = 0
    Const LR_COPYRETURNORG = &H4
    Dim tSize As Size, tBM As BITMAP, oPic As StdPicture

    Set oPic = PicFromObject(Shp)
    Call GetObjectAPI(oPic.Handle, LenB(tBM), tBM)

    With tSize
        .cx = PXtoPT(tBM.bmWidth, False)
        .cy = PXtoPT(tBM.bmHeight, True)
    End With

    GetShapeRealSize = tSize

End Function


Private Function PicFromObject(ByVal obj As Variant) As StdPicture

    Const IMAGE_BITMAP = 0
    Const PICTYPE_BITMAP = 1
    Const LR_COPYRETURNORG = &H4
    Const CF_BITMAP = 2
    Const S_OK = 0

    #If Win64 Then
        Dim hImagePtr As LongLong
    #Else
        Dim hImagePtr As Long
    #End If

    Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
    Dim IPic As StdPicture

    On Error GoTo errHandler

    obj.CopyPicture xlScreen, xlBitmap

    Call OpenClipboard(0)
    hImagePtr = GetClipboardData(CF_BITMAP)
    hImagePtr = CopyImage(hImagePtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    Call EmptyClipboard
    Call CloseClipboard

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_BITMAP
        .hPic = hImagePtr
        .hPal = 0
    End With

    If OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) = S_OK Then
        Set PicFromObject = IPic
    End If

    Exit Function

errHandler:

    Call EmptyClipboard
    Call CloseClipboard

End Function


Private Function ScreenDPI(ByVal bVert As Boolean) As Long

    #If Win64 Then
        Dim hdc As LongLong
    #Else
        Dim hdc As Long
    #End If

    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Static lDPI(1) As Long

    If lDPI(0) = 0 Then
        hdc = GetDC(0)
        lDPI(0) = GetDeviceCaps(hdc, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If

    ScreenDPI = lDPI(Abs(bVert))

End Function

Private Function PXtoPT(ByVal Pixels As Long, ByVal bVert As Boolean) As Single
    Const POINTSPERINCH As Long = 72
    PXtoPT = Pixels / (ScreenDPI(bVert) / POINTSPERINCH)
End Function



Code Usage Example:
VBA Code: 
Sub TEST()

    Dim tSize As Size

    tSize = GetShapeRealSize(Sheet1.Shapes("star"))
    MsgBox "Real Width: " & tSize.cx & " pt" & vbCrLf & "Real Height: " & tSize.cy & " pt"

    'Set the Width & Height of a newly created dummy star shape for testing.
    Dim oDummyStarShape As Shape

    Set oDummyStarShape = Sheet1.Shapes.AddShape(msoShape5pointStar, 0, 0, tSize.cx, tSize.cy)

End Sub
 
Upvote 0
Nice job Jaafar.
The code above is over my head.

This was an interesting subject to look at though I came up with zilch code wise.

Looks like you took the size from an image, which is where I looked to see if I could find a pattern in the line weight changes.
So, I ended up emailing myself the pasted shape with line sizes 0- 5pt to see if there's any method of calculation for the new size based on the added line weight figures.
I also pasted into Paint, which gives just the px size.

The email source code gives the size in points and pixels as an image including the added border. There are slight rounding errors from conversions between cm, points and pixels.
(It also gives all of the Vector Markup Language to describe the shape, which may be useful - for someone who understands it.
VML - the Vector Markup Language)

I can't see a useful calculation/pattern from the results.
I tabulated the changes below for a 4x4 cm 5 point star.

5ptStar.png
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
Shape objects distorting on Mac only (not Windows)
Replies
0
Views
122
rline101
R
L
  • Question
VBA for pasting tables to PowerPoint - shape problem
Replies
0
Views
659
lukasz_rz
L
D
  • Solved
Text Boxes - How to populate them without overlapping, bumping in to each other
Replies
3
Views
782
dcoker
D
N
  • Solved
VBA Excel opens Word - Split Screen to Windows Planes
Replies
5
Views
644
NdNoviceHlp
NdNoviceHlp
L
  • Solved
VBA Help Modify Code - Prevent chart from resizing with columns / rows
Replies
3
Views
695
Anthony47
A

Forum statistics

Threads
1,214,921
Messages
6,122,280
Members
449,075
Latest member
staticfluids

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