excel - 将形状数据从 Visio 2010 传输到 Excel 2010，以便使用 VBA 进行进一步操作

Question

我正在尝试获取形状数据(具有特定形状)并将其值传输到 Excel 电子表格中，以便 Excel 可以对传输的值运行函数。该计划是单击一个形状并自动将其特定形状数据发送到 Excel，在那里将对其进行进一步操作以创建一个非常具体的电子表格。我使用 VBA 进行所有编程。

我知道如何获取形状数据并在 Visio 中对其进行操作，但我不确定如何将其传递到 Excel。

那么，这可能吗？我知道您可以将形状链接到数据(我已经这样做了)并将形状超链接到特定文档(我也已经这样做了)，但是是否可以将特定形状数据发送到文档以进行进一步操作？

请帮忙，我在任何地方都找不到有关此情况的任何信息。

提前谢谢您!

Answer 1

是的，这是可能的。以下是一些用于从 Visio 创建 Excel 报告的 VBA 代码。请记住，Excel VBA 和 Visio VBA 具有相同名称的属性，因此请确保完全限定 Excel 引用。否则 VBA 会变得困惑。

Public Sub ExcelReport()

Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim celObj1 As Visio.Cell, celObj2 As Visio.Cell
Dim curShapeIndx As Integer
Dim localCentx As Double, localCenty As Double, localCenty1 As Double
Dim ShapesCnt As Integer, i As Integer
Dim ShapeHeight As Visio.Cell, ShapeWidth As Visio.Cell
Dim XlApp As Excel.Application
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet

Set XlApp = CreateObject("excel.application")
' You may have to set Visible property to True if you want to see the application.
XlApp.Visible = True
Set XlWrkbook = XlApp.Workbooks.Add
Set XlSheet = XlWrkbook.Worksheets("sheet1")
Set shpObjs = ActivePage.Shapes
ShapesCnt = shpObjs.Count

    XlSheet.Cells(1, 1) = "Indx"
    XlSheet.Cells(1, 2) = "Name"
    XlSheet.Cells(1, 3) = "Text"
    XlSheet.Cells(1, 4) = "localCenty"
    XlSheet.Cells(1, 5) = "localCentx"
    XlSheet.Cells(1, 6) = "Width"
    XlSheet.Cells(1, 7) = "Height"
' Loop through all the shapes on the page to find their locations
For curShapeIndx = 1 To ShapesCnt
Set shpObj = shpObjs(curShapeIndx)
If Not shpObj.OneD Then
    Set celObj1 = shpObj.Cells("pinx")
    Set celObj2 = shpObj.Cells("piny")
    localCentx = celObj1.Result("inches")
    localCenty = celObj2.Result("inches")
    Set ShapeWidth = shpObj.Cells("Width")
    Set ShapeHeight = shpObj.Cells("Height")
    Debug.Print shpObj.Name, shpObj.Text, curShapeIndx; Format(localCenty, "000.0000") & " " & Format(localCentx, "000.0000"); " "; ShapeWidth; " "; ShapeHeight
    i = curShapeIndx + 1
    XlSheet.Cells(i, 1) = curShapeIndx
    XlSheet.Cells(i, 2) = shpObj.Name
    XlSheet.Cells(i, 3) = shpObj.Text
    XlSheet.Cells(i, 4) = localCenty
    XlSheet.Cells(i, 5) = localCentx
    XlSheet.Cells(i, 6) = ShapeWidth
    XlSheet.Cells(i, 7) = ShapeHeight
End If
Next curShapeIndx
XlApp.Quit    ' When you finish, use the Quit method to close
Set XlApp = Nothing    '

End Sub

约翰...Visio MVP