PDA

View Full Version : [SOLVED] Show Area of Freeform Shape



ooitzechyi
09-18-2016, 07:50 PM
Hi,
May I know is there anyway to use VB to calc a freeform shape area?
I could done it with regular shapes (eg: rectangular), but the code is not function for freeform shape..

Sub ShowArea()
Dim Width As Double
Dim Height As Double

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

With Selection.ShapeRange

Selection.ShapeRange(1).TextFrame.Characters.Text = Round(Width * Height * 1.0044345, 2) & "m2"

Selection.ShapeRange(1).TextFrame.HorizontalAlignment = xlHAlignCenter
Selection.ShapeRange(1).TextFrame.VerticalAlignment = xlVAlignCenter
Selection.ShapeRange(1).TextEffect.FontBold = msoCTrue
Selection.ShapeRange(1).TextEffect.FontSize = 100


n = Selection.ShapeRange(1).TextFrame.Characters.Count
If Len(n) > 0 Then
Selection.ShapeRange(1).TextFrame.Characters(n, 1).Font.Superscript = True
End If

End With
End Sub


Thank you~

ooitzechyi
09-18-2016, 08:04 PM
I found that if I replace below coding with MsgBox, it works.
But I'm not sure where it goes wrong that it couldn't show the area calculated in text.

With Selection.ShapeRange

Selection.ShapeRange(1).TextFrame.Characters.Text = Round(Width * Height * 1.0044345, 2) & "m2"

Selection.ShapeRange(1).TextFrame.HorizontalAlignment = xlHAlignCenter
Selection.ShapeRange(1).TextFrame.VerticalAlignment = xlVAlignCenter
Selection.ShapeRange(1).TextEffect.FontBold = msoCTrue
Selection.ShapeRange(1).TextEffect.FontSize = 100


n = Selection.ShapeRange(1).TextFrame.Characters.Count
If Len(n) > 0 Then
Selection.ShapeRange(1).TextFrame.Characters(n, 1).Font.Superscript = True
End If

End With


perhaps there is any expert can help....

mana
09-18-2016, 10:03 PM
Can you record a macro?

ooitzechyi
09-18-2016, 10:57 PM
Hi mana,
Yes, the macro recorded is for specific shape, what if I need to make it available to all freeform shapes in my worksheet based on my selection?
ActiveSheet.Shapes.Range(Array("Freeform 646")).Select

Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "defa = jdkaf"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 12).ParagraphFormat. _
FirstLineIndent = 0
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 12).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Size = 11
.Name = "+mn-lt"
End With
Range("T14").Select
End Sub

I try to remove the Array but it prompt error.

ooitzechyi
09-18-2016, 11:23 PM
Hi,
I tried with below code, it works for text appears but for the Superscript, still detecting error "1004: Application-defined or object-defined error"

Sub ShowArea()
Dim Width As Double
Dim Height As Double

Width = Selection.ShapeRange(1).Width / 72
Height = Selection.ShapeRange(1).Height / 72
Area = Round(Width * Height * 1.0044345, 2)
MsgBox Format(Area)

Set shprng = Selection.ShapeRange(1)
With shprng

shprng.TextFrame2.TextRange.Characters.Text = Round(Width * Height * 1.0044345, 2) & "m2"

shprng.TextFrame.HorizontalAlignment = xlHAlignCenter
shprng.TextFrame.VerticalAlignment = xlVAlignCenter
shprng.TextEffect.FontBold = msoCTrue
shprng.TextEffect.FontSize = 100

n = shprng.TextFrame.Characters.Count
If Len(n) > 0 Then
shprng.TextFrame.Characters(n, 1).Font.Superscript = True
End If

End With
End Sub

mana
09-19-2016, 12:13 AM
Your code : "TextFrame"
Record macro : "TextFrame2"

mana
09-19-2016, 12:19 AM
Option Explicit

Sub test()
Dim sp As Shape

For Each sp In ActiveSheet.Shapes
If sp.Type = msoFreeform Then ShowArea sp
Next

End Sub


Private Sub ShowArea(sp As Shape)
Dim W As Double
Dim H As Double
Dim A As Double
Dim n As Long

With sp
W = .Width / 72
H = .Height / 72
A = Round(W * H * 1.0044345, 2)
With .TextFrame2
.TextRange.Characters.Text = A & "m2"
n = .TextRange.Characters.Count
.TextRange.Characters(n, 1).Font.Superscript = True
'other formatting

End With
End With

End Sub

ooitzechyi
09-19-2016, 12:45 AM
Hi mana,
Yes, it works! Thank you very much~