无法在 Visio VBA 组中粘合形状

Question

我想通过 VBA 将一个形状粘合到另一个形状上。 所有的形状都是用一个用户窗体模块创建的。 我希望某些形状与箭头连接（也通过用户窗体拖放到页面上）。它可以很好地连接两个不在一个组中的形状。现在我想连接两个形状，其中一个或两个可能在一个组中。

这适用于非分组形状

'get shp, src, aim
[...]
shp.Cells("BeginX").GlueTo src.Cells("PinX")
shp.Cells("EndX").GlueTo aim.Cells("PinX")

我使用这个函数获得了目标和 src 形状：

Function getShape(id As Integer, propName As String) As Shape
    Dim shp As Shape
    Dim subshp As Shape
    For Each shp In ActivePage.Shapes
        If shp.Type = 2 Then
            For Each subshp In shp.GroupItems
                If subshp.CellExistsU(propName, 0) Then
                    If subshp.CellsU(propName).ResultIU = id Then
                        Set getShape = subshp
                        Exit For
                    End If
                End If
            Next subshp
        End If

        If shp.CellExistsU(propName, 0) Then
            If shp.CellsU(propName).ResultIU = id Then
                Set getShape = shp
                Exit For
            End If
        End If
    Next
End Function

我认为我遍历子形状的方式有问题。 任何帮助表示赞赏。

Answer 1

啊，@Surrogate 打败了我 :) 但是自从我开始写作之后......除了他的回答之外，它很好地展示了如何调整内置的动态连接器，这是你的小组查找方法 + 一个自定义连接器。

代码假设了一些事情：

1. 已删除包含两个 2D 形状的页面
2. 其中一个形状是包含具有正确形状数据的子形状的组形状
3. 一个名为“MyConn”的自定义母版，它是一条简单的一维线，没有其他修改

Public Sub TestConnect()
Dim shp As Visio.Shape 'connector
Dim src As Visio.Shape 'connect this
Dim aim As Visio.Shape 'to this

Dim vPag As Visio.Page
Set vPag = ActivePage

Set shp = vPag.Drop(ActiveDocument.Masters("MyConn"), 1, 1)
shp.CellsU("ObjType").FormulaU = 2
Set src = vPag.Shapes(1)

Set aim = getShape(7, "Prop.ID")

If Not aim Is Nothing Then
    shp.CellsU("BeginX").GlueTo src.CellsU("PinX")
    shp.CellsU("EndX").GlueTo aim.CellsU("PinX")
End If

End Sub


Function getShape(id As Integer, propName As String) As Shape
        Dim shp As Shape
        Dim subshp As Shape
        For Each shp In ActivePage.Shapes
            If shp.Type = 2 Then
                For Each subshp In shp.Shapes
                    If subshp.CellExistsU(propName, 0) Then
                        If subshp.CellsU(propName).ResultIU = id Then
                            Set getShape = subshp
                            Exit For
                        End If
                    End If
                Next subshp
            End If

            If shp.CellExistsU(propName, 0) Then
                If shp.CellsU(propName).ResultIU = id Then
                    Set getShape = shp
                    Exit For
                End If
            End If
        Next
    End Function

请注意，如果您将read the docs 换成Cell.GlueTo，您将看到此项目：

二维形状的引脚（创建动态粘合）：被粘合的形状 from 必须是可路由的（ObjType 包括 visLOFlagsRoutable ） 或具有 动态粘合类型（GlueType 包括 visGlueTypeWalking），并且确实 不禁止动态粘合（GlueType 不包括 可见 GlueTypeNoWalking ）。粘合到 PinX 创建动态粘合 水平行走偏好和对 PinY 的粘合创建动态粘合 具有垂直行走偏好。

因此我将 ObjType 单元格设置为 2 (VisCellVals.visLOFlagsRoutable)。通常你会在你的主实例中设置它，所以不需要那行代码。

Answer 2

请试试这个代码

Dim connector As Shape, src As Shape, aim As Shape
' add new connector (right-angle) to page
Set connector = Application.ActiveWindow.Page.Drop(Application.ConnectorToolDataObject, 0, 0)
' change Right-angle Connector to Curved Connector
connector.CellsSRC(visSectionObject, visRowShapeLayout, visSLOLineRouteExt).FormulaU = "2"
connector.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = "1"
Set src = Application.ActiveWindow.Page.Shapes.ItemFromID(4)
Set aim = Application.ActiveWindow.Page.Shapes.ItemFromID(2)
Dim vsoCell1 As Visio.Cell
Dim vsoCell2 As Visio.Cell
Set vsoCell1 = connector.CellsU("BeginX")
Set vsoCell2 = src.Cells("PinX")
vsoCell1.GlueTo vsoCell2
Set vsoCell1 = connector.CellsU("EndX")
Set vsoCell2 = aim.Cells("PinX")
vsoCell1.GlueTo vsoCell2