Excel VBA: Получение размеров фигур для формул

Sub GetShapeDimensions()
    Dim sh As Shape
    Set sh = ActiveSheet.Shapes("Rectangle 1")
    
    Debug.Print "Ширина: " & sh.Width & " пунктов"
    Debug.Print "Высота: " & sh.Height & " пунктов"
End Sub

Function GetShapeWidth(shapeName As String) As Double
    On Error Resume Next
    GetShapeWidth = ActiveSheet.Shapes(shapeName).Width
    On Error GoTo 0
End Function

Function GetShapeHeight(shapeName As String) As Double
    On Error Resume Next
    GetShapeHeight = ActiveSheet.Shapes(shapeName).Height
    On Error GoTo 0
End Function

Function GetShapeSize(shapeName As String, dimension As String, Optional unit As String = "pt") As Double
    Dim sh As Shape
    On Error Resume Next
    Set sh = ActiveSheet.Shapes(shapeName)
    
    If sh Is Nothing Then
        GetShapeSize = 0
        Exit Function
    End If
    
    Select Case LCase(unit)
        Case "cm"
            If LCase(dimension) = "width" Then
                GetShapeSize = sh.Width / 28.3464567 ' Преобразование пунктов в см
            ElseIf LCase(dimension) = "height" Then
                GetShapeSize = sh.Height / 28.3464567 ' Преобразование пунктов в см
            End If
        Case "in"
            If LCase(dimension) = "width" Then
                GetShapeSize = sh.Width / 72 ' Преобразование пунктов в дюймы
            ElseIf LCase(dimension) = "height" Then
                GetShapeSize = sh.Height / 72 ' Преобразование пунктов в дюймы
            End If
        Case Else ' По умолчанию в пунктах
            If LCase(dimension) = "width" Then
                GetShapeSize = sh.Width
            ElseIf LCase(dimension) = "height" Then
                GetShapeSize = sh.Height
            End If
    End Select
    On Error GoTo 0
End Function

Function GetShapePositionInfo(shapeName As String) As String
    Dim sh As Shape
    On Error Resume Next
    Set sh = ActiveSheet.Shapes(shapeName)
    
    If sh Is Nothing Then
        GetShapePositionInfo = "Фигура не найдена"
        Exit Function
    End If
    
    GetShapePositionInfo = "Ширина: " & sh.Width & " пт, Высота: " & sh.Height & " пт" & _
                          " | Слева: " & sh.Left & " пт, Сверху: " & sh.Top & " пт"
    On Error GoTo 0
End Function

Sub SizeCircle(Name As String, Diameter)
    Dim xCenterX As Single
    Dim xCenterY As Single
    Dim xCircle As Shape
    Dim xDiameter As Single
    
    On Error GoTo ExitSub
    xDiameter = Diameter
    
    If xDiameter > 10 Then xDiameter = 10
    If xDiameter < 1 Then xDiameter = 1
    
    Set xCircle = ActiveSheet.Shapes(Name)
    With xCircle
        xCenterX = .Left + (.Width / 2)
        xCenterY = .Top + (.Height / 2)
        .Width = Application.CentimetersToPoints(xDiameter)
        .Height = Application.CentimetersToPoints(xDiameter)
        .Left = xCenterX - (.Width / 2)
        .Top = xCenterY - (.Height / 2)
    End With
    
ExitSub:
End Sub

Function PointsToColumnWidth(points As Double) As Double
    ' Это приближение - вам нужно откалибровать это для вашей системы
    PointsToColumnWidth = points * 0.13 ' Пример коэффициента преобразования
End Function

Sub SetPreciseShapeSize()
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.LockAspectRatio = msoFalse
        sh.Height = 12
        sh.Width = 12
        sh.Placement = xlMove
        sh.LockAspectRatio = msoTrue
    Next sh
End Sub

Function GetDashboardMetrics() As Variant
    Dim metrics(1 To 4) As Double
    Dim statusShape As Shape
    
    On Error Resume Next
    Set statusShape = ActiveSheet.Shapes("StatusIndicator")
    
    If Not statusShape Is Nothing Then
        metrics(1) = statusShape.Width ' Ширина в пунктах
        metrics(2) = statusShape.Height ' Высота в пунктах
        metrics(3) = statusShape.Left / 72 ' Позиция слева в дюймах
        metrics(4) = statusShape.Top / 72 ' Позиция сверху в дюймах
    End If
    
    GetDashboardMetrics = metrics
    On Error GoTo 0
End Function

Function CalculateShapeArea(shapeName As String) As Double
    Dim sh As Shape
    On Error Resume Next
    Set sh = ActiveSheet.Shapes(shapeName)
    
    If sh Is Nothing Then
        CalculateShapeArea = 0
        Exit Function
    End If
    
    CalculateShapeArea = sh.Width * sh.Height / 144 ' Преобразование в квадратные дюймы
    On Error GoTo 0
End Function

Sub CheckShapeSizes()
    Dim sh As Shape
    Dim outputRange As Range
    
    Set outputRange = Range("A1:A10")
    outputRange.ClearContents
    
    For Each sh In ActiveSheet.Shapes
        outputRange.Cells(1, 1).Value = sh.Name
        outputRange.Cells(1, 2).Value = sh.Width
        outputRange.Cells(1, 3).Value = sh.Height
        outputRange.Cells(1, 4).Value = sh.Width * sh.Height
        
        Set outputRange = outputRange.Offset(1, 0)
    Next sh
End Sub