求可提取Visio容器间连接关系至Excel的VBA代码

问题描述 #

需要编写VBA代码，将Visio页面中容器之间的连接关系导出到Excel表格，表格需包含两列：

• Predecessors：连接器无箭头端对应的容器文本
• Successors：连接器带箭头端对应的容器文本

现有代码可提取形状文本及自定义单元格数据，但无法获取连接器的连接关系数据，且ChatGPT生成的代码无法完成文件写入。自行编写的代码如下：

Sub ExportAllShapeDataToExcel()
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlWorksheet As Object
Dim i As Integer

' Create a new Excel application
Set xlApp = CreateObject("Excel.Application")

' Add a new workbook
Set xlWorkbook = xlApp.Workbooks.Add

' Set the worksheet
Set xlWorksheet = xlWorkbook.Worksheets(1)

' Initialize row number
i = 1

' Loop through all shapes in the active Visio page
For Each sh In ActivePage.Shapes
    ' Get the shape text
    Dim shapeText As String
    If Not sh.TextFrame Is Nothing Then
        shapeText = sh.TextFrame.TextRange.Text
    Else
        shapeText = ""
    End If
    
    ' Write the shape text to Excel
    xlWorksheet.Cells(i, 1).Value = "Shape"
    xlWorksheet.Cells(i, 2).Value = shapeText
    i = i + 1
    
    ' Loop through user-defined cells (data fields) of the shape
    For Each cell In sh.CellsU
        xlWorksheet.Cells(i, 1).Value = cell.Name
        xlWorksheet.Cells(i, 2).Value = cell.ResultStr("")
        i = i + 1
    Next cell
Next sh

' Save the Excel file
xlWorkbook.SaveAs "C:\Users\Jerod.cramb\Documents\VisioTestFile2.xlsx"

' Clean up
xlWorkbook.Close
xlApp.Quit
Set xlApp = Nothing

End Sub

修正后的代码 #

以下代码专门针对连接器的连接关系进行提取，同时修复文件写入问题：

Sub ExportConnectorRelationshipsToExcel()
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlWorksheet As Object
    Dim rowNum As Integer
    Dim connectorSh As Visio.Shape
    Dim beginShape As Visio.Shape
    Dim endShape As Visio.Shape
    Dim savePath As String
    
    ' 设置Excel保存路径，可自行修改
    savePath = "C:\Users\Jerod.cramb\Documents\VisioConnectorRelationships.xlsx"
    
    ' 创建Excel应用实例并显示窗口（方便调试，可注释）
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True ' 可选，打开时显示Excel窗口
    
    ' 添加新工作簿并设置工作表
    Set xlWorkbook = xlApp.Workbooks.Add
    Set xlWorksheet = xlWorkbook.Worksheets(1)
    xlWorksheet.Name = "Connector Relationships"
    
    ' 写入表头
    rowNum = 1
    xlWorksheet.Cells(rowNum, 1).Value = "Predecessors"
    xlWorksheet.Cells(rowNum, 2).Value = "Successors"
    rowNum = rowNum + 1
    
    ' 遍历当前页面所有形状，筛选连接器
    For Each connectorSh In ActivePage.Shapes
        ' 判断是否为连接器形状
        If connectorSh.OneD Then
            ' 获取连接器起点（无箭头端）对应的形状
            Set beginShape = connectorSh.Connects.Item(1).ToSheet
            ' 获取连接器终点（箭头端）对应的形状
            Set endShape = connectorSh.Connects.Item(connectorSh.Connects.Count).ToSheet
            
            ' 写入起点和终点形状的文本
            xlWorksheet.Cells(rowNum, 1).Value = GetShapeText(beginShape)
            xlWorksheet.Cells(rowNum, 2).Value = GetShapeText(endShape)
            rowNum = rowNum + 1
        End If
    Next connectorSh
    
    ' 自动调整列宽
    xlWorksheet.Columns("A:B").AutoFit
    
    ' 保存并清理
    On Error Resume Next ' 捕获文件已打开的错误
    xlWorkbook.SaveAs savePath
    On Error GoTo 0
    
    ' 如需自动关闭Excel可取消注释以下两行
    ' xlWorkbook.Close
    ' xlApp.Quit
    
    Set xlWorksheet = Nothing
    Set xlWorkbook = Nothing
    Set xlApp = Nothing
    
    MsgBox "连接关系已成功导出！", vbInformation
End Sub

' 辅助函数：获取形状的文本内容
Private Function GetShapeText(targetSh As Visio.Shape) As String
    If Not targetSh.TextFrame Is Nothing Then
        GetShapeText = targetSh.TextFrame.TextRange.Text
    Else
        GetShapeText = "无文本"
    End If
End Function

代码说明 #

• 筛选连接器：通过OneD属性判断形状是否为一维连接器
• 获取连接对象：使用Connects集合获取连接器的起点（Item(1)）和终点（Item(Count)）对应的形状
• 文本提取：封装GetShapeText函数统一处理形状文本获取逻辑，避免重复代码
• 优化体验：添加列宽自动调整、保存错误捕获、完成提示，同时保留Excel可见选项方便调试

内容的提问来源于stack exchange，提问作者Jerod Cramb