Skip to content

Instantly share code, notes, and snippets.

@Surrogate-TM

Surrogate-TM/ModifyGeometry.md

Last active May 31, 2023 09:58
Show Gist options
  • Save Surrogate-TM/9ef89cb4bbcc03c60fb242141b882166 to your computer and use it in GitHub Desktop.
Save Surrogate-TM/9ef89cb4bbcc03c60fb242141b882166 to your computer and use it in GitHub Desktop.
Download ZIP
Работа с разделом Geometry.
Raw
ModifyGeometry.md

К этому разбору кода меня подтолкнула тема Аналог "копирки" в висио для создание фигур, взаимодействие.
Цель: научиться добавлять в целевую фигуру дополнительные разделы Geometry (visSectionFirstComponent), как в фигуре-образце.

Нижеследующий код получен при записи макрорекордером (добавлены комментарии/убраны UNDO).

Sub ModifyGeometry()
' Add new Geomtry section +1
    Application.ActiveWindow.Shape.AddSection visSectionFirstComponent + 1  ' Add new Geometry Section for Line
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 1, visRowComponent, visTagComponent  ' Add default settings Geometry
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 1, visRowVertex, visTagLineTo  ' Add default tag LineTo
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 1, visRowVertex, visTagMoveTo  ' Add default tag MoveTo
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 0, 0).FormulaForceU = "TRUE"  ' NoFill
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 0, 1).FormulaForceU = "FALSE"  ' NoLine
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 0, 2).FormulaForceU = "FALSE"  ' NoShow
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 0, 3).FormulaForceU = "FALSE"  ' NoSnap
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 0, 5).FormulaForceU = "FALSE"  ' NoQuckDrag
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 1, 0).FormulaU = "0"  ' Default Geometry[N].X1
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 1, 1).FormulaU = "0"  ' Default Geometry[N].Y1
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 2, 0).FormulaU = "0"  ' Default Geometry[N].X2
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 2, 1).FormulaU = "0"  ' Default Geometry[N].Y2
' Change Geomtry section +1
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 0, 0).FormulaU = "0"  ' NoFill
    Application.ActiveWindow.Shape.RowType(visSectionFirstComponent + 1, 1) = visTagMoveTo  ' Change tag to MoveTo
    Application.ActiveWindow.Shape.RowType(visSectionFirstComponent + 1, 2) = visTagLineTo  ' Change tag to LineTo
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 1, 0).FormulaU = "0-5 mm"  ' Change cell Geometry[N].X1
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 1, 1).FormulaU = "0 - 5 mm"  ' Change cell Geometry[N].Y1
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 2, 0).FormulaU = "Width*1+5 mm"  ' Change cell Geometry[N].X2
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 1, 2, 1).FormulaU = "Geometry2.Y1"  ' Change cell Geometry[N].Y2

' Add new Geomtry section +2
    Application.ActiveWindow.Shape.AddSection visSectionFirstComponent + 2  ' Add new Geometry Section for Ellipse
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 2, visRowComponent, visTagComponent  ' Add default settings Geometry
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 2, visRowVertex, visTagEllipse  ' Add default tag LineTo
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 0, 0).FormulaForceU = "FALSE"  ' NoFill
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 0, 1).FormulaForceU = "FALSE"  ' NoLine
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 0, 2).FormulaForceU = "FALSE"  ' NoShow
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 0, 3).FormulaForceU = "FALSE"  ' NoSnap
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 0, 5).FormulaForceU = "FALSE"  ' NoQuckDrag
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 0).FormulaForceU = "Width*0.5"  ' Default Geometry[N].X
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 1).FormulaForceU = "Height*0.5"  ' Default Geometry[N].Y
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 2).FormulaForceU = "Width*1"  ' Default Geometry[N].A
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 3).FormulaForceU = "Height*0.5"  ' Default Geometry[N].B
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 4).FormulaForceU = "Width*0.5"  ' Default Geometry[N].C
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 5).FormulaForceU = "Height*1"  ' Default Geometry[N].D
' Change Geomtry section +2
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 0, 0).FormulaU = "1"  ' Change NoFill
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 0).FormulaU = "Width*0"  ' Change Geometry[N].X
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 2).FormulaU = "10 mm"  ' Change
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 4).FormulaU = "0 mm"  ' Change
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 2, 1, 5).FormulaU = "30 mm"  ' Change

' Add new Geomtry section +3
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 3, visRowComponent, visTagComponent  ' Add default settings Geometry
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 3, visRowVertex, visTagLineTo  ' Add default tag LineTo
    Application.ActiveWindow.Shape.AddRow visSectionFirstComponent + 3, visRowVertex, visTagMoveTo  ' Add default tag MoveTo
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 0, 0).FormulaForceU = "TRUE"  ' NoFill
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 0, 1).FormulaForceU = "FALSE"  ' NoLine
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 0, 2).FormulaForceU = "FALSE"  ' NoShow
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 0, 3).FormulaForceU = "FALSE"  ' NoSnap
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 0, 5).FormulaForceU = "FALSE"  ' NoQuckDrag
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 0).FormulaU = "0"  ' Default Geometry[N].X1
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 1).FormulaU = "0"  ' Default Geometry[N].Y1
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 2, 0).FormulaU = "0"  ' Default Geometry[N].X2
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 2, 1).FormulaU = "0"  ' Default Geometry[N].Y2
' Change Geomtry section +3
    Application.ActiveWindow.Shape.RowType(visSectionFirstComponent + 3, 1) = visTagEllipse ' Change tag from Line to Ellipse
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 0).FormulaU = "60 mm"  ' Change Geometry[N].X
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 1).FormulaU = "0 mm"  ' Change Geometry[N].Y
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 2).FormulaU = "65 mm"  ' Change Geometry[N].A
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 3).FormulaU = "0 mm"  ' Change Geometry[N].B
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 4).FormulaU = "60 mm"  ' Change Geometry[N].C
    Application.ActiveWindow.Shape.CellsSRC(visSectionFirstComponent + 3, 1, 5).FormulaU = "5 mm"  ' Change Geometry[N].D

End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment