Show Area of Shape insert

[Tze Chyi]

Dear all,
I wish to get the area of shapes to be shown whenever I insert new shape to excel.
Here is my coding.
currently I'm using divide to convert the point to inches, is there code to convert from point to inch?

Sub ShowArea()

For x = 1 To 50
Sheet1.Shapes(x).TextFrame.Characters.Text = Round(((Sheet1.Shapes(x).Width / 72) * (Sheet1.Shapes(x).Height / 72)), 2)
Next x

End Sub

Thank you.

 

[macropod]

Although Word has builtin functions for CentimetersToPoints, InchesToPoints, PointsToCentimeters, PointsToInches, Excel lacks them. You could, of course, create them. For example:

Function PointsToCentimeters(sngSize As Single)
PointsToCentimeters = sngSize * 2.54 / 72
End Function

Function PointsToInches(sngSize As Single)
PointsToInches = sngSize / 72
End Function

Function CentimetersToPoints(sngSize As Single)
CentimetersToPoints = sngSize * 72 / 2.54
End Function

Function InchesToPoints(sngSize As Single)
InchesToPoints = sngSize * 72
End Function

Cheers
Paul Edstein
[MS MVP - Word]

 

[Tze Chyi]

Hi macropod,
Thanks.

Perhaps you could help me further in below problem.
The code I have is to show the area of the shape I insert.
Now, all the shapes in the Excel Sheet will be shown the area once I hit the macro.
How if I only wan the shape which is active?
I tried with below code but it seems to be error.

ActiveSheet1.ActiveShapes.Select

Thanks.

 

[macropod]

If you want to get the selected shape, use something along the lines of:
MsgBox Selection.ShapeRange(1).Name
Thus:

With Selection.ShapeRange(1)
  MsgBox Round((.Width * .Height / 72 ^ 2), 2)
End With

Cheers
Paul Edstein
[MS MVP - Word]

 

[Tze Chyi]

Hi macropod,
Thank you very much~~~

 

[strongm]

>Excel lacks them

Er ... Excel does have them, at least the first 2 (and consequently we can simply derive the remaining 2), it is just that they are slightly borked, in the sense that they need to be qualified as Application, i.e.

Application.CentimetersToPoints
Application.InchesToPoints

 

[macropod]

Thanks strongm. That would explain why I got errors trying to use any of them...

Cheers
Paul Edstein
[MS MVP - Word]

 

[Tze Chyi]

Hi Strongm,
Thanks.
1). If I wish to have more than one data (width, height, area) show in the shape insert, how could I make it?
I tried with "+" but error prompted.
If separated to different coding, only one data will be shown.

2). What if I need the data to be shown automatically when I change the original shape? I tried with Change function but it doesn't work.
Private Sub ActiveShapes_Change(ByVal Target As String)
If Selection.ShapeRange(1).Change Then
Call ShowArea
End If
End Sub

 

[Andrzejek]

>If I wish to have more than one data (width, height, area) show in the shape insert
Have you tried something like this:

Sub ShowArea()

For x = 1 To 50
  Sheet1.Shapes(x).TextFrame.Characters.Text = "Width = " & [blue]125[/blue] & _
    ", Height = " & [blue]250[/blue] & ", Area = " & [blue]125 * 250[/blue]
Next x

End Sub

Just replace the [blue]BLUE[/blue] hard-coded numbers with your calculated values.

Have fun.

---- Andy

There is a great need for a sarcasm font.

 

[SkipVought]

I would not hard code the number of shapes in your sheet, WHATEVER SHEET your changing...

Sub ShowArea()
    Dim shp As Shape
    
    For Each shp In ActiveSheet.Shapes
      shp.TextFrame.Characters.Text = "Width = " & shp.Width & _
        ", Height = " & shp.Height & ", Area = " & shp.Width * shp.Height
    Next
End Sub

Of course, substitute your conversions.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[Tze Chyi]

Hi Andrzejek, SkipVought,
Thanks for the suggestion.
How bout the Auto Change of data if I change the shape?

Besides,
I'm using Round function for the area calculation but the decimal point seems to be having bugs.
If I had my coding for >0 of decimal point, the data shows will be 13 decimal points.
Sub ShowArea()
Dim Width As Single
Dim Height As Single

Width = Selection.ShapeRange(1).Width / 72
Height = Selection.ShapeRange(1).Height / 72

With Selection.ShapeRange(1)

Selection.ShapeRange(1).TextFrame.Characters.Text = Round(Width * Height, [highlight #CC0000]1[/highlight])

End With

End Sub