Show Area of Freeform Shape

[ooitzechyi]

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]

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]

Can you record a macro?

[ooitzechyi]

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]

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]

Your code : "TextFrame"
Record macro : "TextFrame2"

[mana]

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]

Hi mana,
Yes, it works! Thank you very much~