Connect two 2d shapes in code

[JleruOHeP]

Hi!
I am trying to do the simplest thing - connect two 2d shapes in code with GlueTo.
I have dropped two shapes, added to them connection points with "In" and "Out". Now when I am trying to connect them with a mouse - it`s all ok.
Then I have written a macro:

Code Select Expand

Sub Macro5()

    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    ActiveDocument.DiagramServicesEnabled = visServiceVersion140

    Dim UndoScopeID1 As Long
    UndoScopeID1 = Application.BeginUndoScope("1")
    ActiveWindow.DeselectAll
    ActiveWindow.Select Application.ActiveWindow.Page.Shapes.ItemFromID(1), visSelect
    Application.ActiveWindow.Selection.Move -1.161417, 0.669291
    Dim vsoCell1 As Visio.Cell
    Dim vsoCell2 As Visio.Cell
    Set vsoCell1 = Application.ActiveWindow.Page.Shapes.ItemFromID(1).CellsU("PinX")
    Set vsoCell2 = Application.ActiveWindow.Page.Shapes.ItemFromID(15).CellsSRC(7, 0, 0)
    vsoCell1.GlueTo vsoCell2
    Dim vsoCell3 As Cell
    Dim vsoCell4 As Cell
    Set vsoCell3 = Application.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionConnectionPts, 0, 0)
    Set vsoCell4 = Application.ActiveWindow.Page.Shapes.ItemFromID(15).CellsSRC(visSectionConnectionPts, 0, 0)
    vsoCell3.GlueTo vsoCell4
    Application.EndUndoScope UndoScopeID1, True

    'Restore diagram services
    ActiveDocument.DiagramServicesEnabled = DiagramServices

End Sub

And it is not working... When I manually unglued shapes it throws "Inappropriate source object for this action" - but it`s macro!
Can you help me to write correct code?

[JleruOHeP]

Can someone help me?
Maybe any additional details needed?

[JleruOHeP]

It will work if add control handle and glue it, not PinX

[jimmyhopps]

can you clarify the 'control handle' and pinx comment?  i am having this same exact issue

[jimmyhopps]

got it.  see below for others with same question.


Public Sub GlueTwoD_Example()

    Dim sBoxLower As Visio.Shape ' lower box
    Dim sBoxCaption As Visio.Shape  ' upper caption box
    Dim vsoCellGlueFromObject As Visio.Cell
    Dim vsoCellGlueToObject As Visio.Cell
   
   
   
    Dim vsoCharacters1 As Visio.Characters    ' this is for adding text to the box
   
    'Draw the lower rectangle.
    Set sBoxLower = ActivePage.DrawRectangle(1, 1, 4, 2)
    sBoxLower.AddSection visSectionConnectionPts
    sBoxLower.AddRow visSectionConnectionPts, visRowLast, visTagDefault
    sBoxLower.CellsSRC(visSectionConnectionPts, 0, visCnnctX).FormulaForceU = "Width*1"
    sBoxLower.CellsSRC(visSectionConnectionPts, 0, visCnnctY).FormulaForceU = "Height*1"
    sBoxLower.CellsSRC(visSectionConnectionPts, 0, visCnnctDirX).FormulaForceU = "0 in"
    sBoxLower.CellsSRC(visSectionConnectionPts, 0, visCnnctDirY).FormulaForceU = "0 in"
    sBoxLower.CellsSRC(visSectionConnectionPts, 0, visCnnctType).FormulaForceU = "2"
    sBoxLower.CellsSRC(visSectionConnectionPts, 0, visCnnctAutoGen).FormulaForceU = "0 in"
    sBoxLower.CellsSRC(visSectionConnectionPts, 0, 6).FormulaForceU = ""
   


    'Draw the caption rectangle.
    Set sBoxCaption = ActivePage.DrawRectangle(5, 5, 5.3, 5.4)   
    sBoxCaption.AddSection visSectionConnectionPts
    sBoxCaption.AddRow visSectionConnectionPts, visRowLast, visTagDefault
    sBoxCaption.CellsSRC(visSectionConnectionPts, 0, visCnnctX).FormulaForceU = "Width*0"
    sBoxCaption.CellsSRC(visSectionConnectionPts, 0, visCnnctY).FormulaForceU = "Height*0"
    sBoxCaption.CellsSRC(visSectionConnectionPts, 0, visCnnctDirX).FormulaForceU = "0 in"
    sBoxCaption.CellsSRC(visSectionConnectionPts, 0, visCnnctDirY).FormulaForceU = "0 in"
    sBoxCaption.CellsSRC(visSectionConnectionPts, 0, visCnnctType).FormulaForceU = "2"  ' not 2 is required
    sBoxCaption.CellsSRC(visSectionConnectionPts, 0, visCnnctAutoGen).FormulaForceU = "0 in"
    sBoxCaption.CellsSRC(visSectionConnectionPts, 0, 6).FormulaForceU = ""


   'add text to captions box (upper box)
    Set vsoCharacters1 = sBoxCaption.Characters
    vsoCharacters1.Begin = 0
    vsoCharacters1.End = 0
    vsoCharacters1.text = "20%" & Chr(10) & "Text here"
   


    'Get the Cell objects needed to make the connections.  - the FROM object / line
    Set vsoCellGlueFromObject = sBoxCaption.CellsSRC(visSectionConnectionPts, 0, 0)
   
    'Get the Cell objects needed to make the connections.  - the TO object / Box
      Set vsoCellGlueToObject = sBoxLower.CellsSRC(visSectionConnectionPts, 0, 0)   ' UR corner of lower rectangle

    'Use the GlueTo method to glue the begin point of the line to the top right vertex (Geometry1.X3) of the lower 2-D shape.
    vsoCellGlueFromObject.GlueTo vsoCellGlueToObject       'debug this

End Sub