无法粘附到 Visio 组中的形状 VBA

Question

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

这适用于非分组形状

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

我使用这个函数得到了目标和源形状：

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

请尝试此代码

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

Answer 2

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

代码假设了一些事情：

一个包含两个二维形状的页面已经被删除
其中一个形状是包含具有正确形状数据的子形状的组形状
一个名为 '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，您将看到此项目：

The pin of a 2-D shape (creates dynamic glue): The shape being glued from must be routable (ObjType includes visLOFlagsRoutable ) or have a dynamic glue type (GlueType includes visGlueTypeWalking ), and does not prohibit dynamic glue (GlueType does not include visGlueTypeNoWalking ). Gluing to PinX creates dynamic glue with a horizontal walking preference and gluing to PinY creates dynamic glue with a vertical walking preference.

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

无法粘附到 Visio 组中的形状 VBA

Cant glue to shape in group Visio VBA

vba

visio