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....
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
Your code : "TextFrame"
Record macro : "TextFrame2"
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~
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.