Замена формул в ячейках зависящих от длины/ширины фигур на их абсолютные значения в милиметрах.

MakeGeometryAbsolute.md

Замена формул на значения в разделе Geometry

По долгу службы пришлось в разделах Geometry заменить формулы в ячейках содержащие относительные значения (вроде Width*0.5) на их абсолютные значения в милиметрах.

Sub MakeGeometryAbsolute()
Dim src As Shape    ' Declare Selected Shape variable
Dim gs_s%   ' Declare Geometry section quanaity variable
Dim S%    ' Declare Geometry section counter variable
Dim R%    ' Declare Row in Geometry section counter variable
Dim gsr%    ' Declare current rowtype value variable
Dim gr% ' Declare row quanaity variable
Set src = ActiveWindow.Selection.PrimaryItem   ' Define Selected Shape
gs_s = src.GeometryCount - 1    ' Define how many geometry sections contain shape
For S = 0 To gs_s ' Iterate geometry sections
gr = src.Section(visSectionFirstComponent + S).Count - 1  ' Define how many rows contain geometry section
For R = 1 To gr ' Iterate geometry sections
    gsr = src.RowType(visSectionFirstComponent + S, R)    ' Define current row's RowType value
    Select Case gsr ' Select Case RowType
    Case 138, 139 ' Case RowType is Move/Line
        src.CellsSRC(visSectionFirstComponent + S, R, 0).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 0).ResultStrU(visMillimeters) ' Change formula to value in 1st cell Geometry[S].X[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 1).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 1).ResultStrU(visMillimeters) ' Change formula to value in 2nd cell Geometry[S].Y[R]

    Case 140 ' Case RowType is Arc
        src.CellsSRC(visSectionFirstComponent + S, R, 0).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 0).ResultStrU(visMillimeters) ' Change formula to value in 1st cell Geometry[S].X[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 1).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 1).ResultStrU(visMillimeters) ' Change formula to value in 2nd cell Geometry[S].Y[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 2).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 2).ResultStrU(visMillimeters) ' Change formula to value in 3rd cell Geometry[S].A[R]
        
    Case 143 ' Case RowType is Ellipse
        src.CellsSRC(visSectionFirstComponent + S, R, 0).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 0).ResultStrU(visMillimeters) ' Change formula to value in 1st cell Geometry[S].X[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 1).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 1).ResultStrU(visMillimeters) ' Change formula to value in 2nd cell Geometry[S].Y[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 2).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 2).ResultStrU(visMillimeters) ' Change formula to value in 3rd cell Geometry[S].A[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 3).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 3).ResultStrU(visMillimeters) ' Change formula to value in 4th cell Geometry[S].B[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 4).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 4).ResultStrU(visMillimeters) ' Change formula to value in 5th cell Geometry[S].C[R]
        src.CellsSRC(visSectionFirstComponent + S, R, 5).FormulaU = src.CellsSRC(visSectionFirstComponent + S, R, 5).ResultStrU(visMillimeters) ' Change formula to value in 6th cell Geometry[S].D[R]

    End Select
Next
Next
MsgBox "TheEnd!!!"
End Sub