Question

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

这不适用于未分组的形状

'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击败了我:)但自从我开始写作...除了他的答案外，它很好地展示了如何适应内置的动态连接器，这是您的分组查找方法+一个自定义连接器。

代码假定了一些事情：

已删除两个2D形状的页面
形状之一是包含具有正确形状数据的子形状的组形状
一个名为“ 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

请注意，如果您将Cell.GlueTo的{{3}}用于ObjType，则会看到以下内容：

二维形状的销钉（创建动态胶水）：正在胶粘的形状 from必须是可路由的（ObjType包括visLOFlagsRoutable），或具有动态胶水类型（GlueType包含visGlueTypeWalking），并且不禁止动态胶水（GlueType不包括 visGlueTypeNoWalking）。粘合到PinX可以使用横向行走首选项并粘贴到PinY上创建动态胶水具有垂直步行偏好。

，以及为什么我将VisCellVals.visLOFlagsRoutable单元格设置为2（drawerToolbar = (Toolbar)findViewById(R.id.toolbarInner); should under the setContentView(R.layout.your_loayout);）。通常，您可以在主实例中进行设置，因此不需要该行代码。

Answer 2

请尝试使用此代码

let myArray:string[];
myArray = ["Bob","Fred"];
console.log(myArray[0]);

无法在Visio VBA组中成型胶水

2 个答案: