VBA: 怎样批量数据从Excel派出到Visio

上周派到了个case, 是批量从Excel导出数据导Visio每个图形中.

花了些时间实现了这个功能.

原理如下:

1. 打开Excel
2. 新建/打开表单
3. 指向所选择的表单
4. 遍历所在列的所有数据
5. 打开Visio
6. 建立/打开Visio页面(Visio是和Excel一样, 需要建立指定页面.)
7. 指向所选择的Visio页面.
8. 打开diagram service 服务
9. 遍历所有数据在新的图形中做文字.

代码如下:

Sub Test11()

Dim rowCount As Long
Dim sourceSheet As Worksheet
Dim targetWorksheet As Worksheet
Dim copyTimes As Integer
Dim vsoPage As Page

Set sourceSheet = Worksheets("Sheet1")
Dim FName As String
Dim VsApp As Object

On Error Resume Next
Set VsApp = GetObject(, "Visio.Application")
   If VsApp Is Nothing Then
       Set VsApp = CreateObject("Visio.Application")
           If VsApp Is Nothing Then
               MsgBox "Can't connect to Visio"
           Exit Sub
           End If
   End If
On Error GoTo 0

FName = "D:drawing.vsdm"

VsApp.Documents.Open FName
VsAppPage = "Page-1"
VsApp.ActivePage = VsAppPage
Cancel = True
 
 'Enable diagram services
Dim DiagramServices As Integer
DiagramServices = VsApp.ActiveDocument.DiagramServicesEnabled
VsApp.ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150
 
  
   For i = 2 To sourceSheet.UsedRange.Rows.Count
       'MsgBox sourceSheet.Cells(i, 1).Value
        
        
       VsApp.Application.Windows.ItemEx("drawing.vsdm").Activate
       VsApp.ActivePage.Drop VsApp.Application.Documents.Item("BASIC_U.VSSX").Masters.ItemU("Square"), 3.128788, 9.25
       Set vsoCharacters1 = VsApp.ActiveWindow.Selection(1).Characters
       vsoCharacters1.Begin = 0
       vsoCharacters1.End = 0
       vsoCharacters1.text = sourceSheet.Cells(i, 1).Value

Next sourceSheet.Activate End Sub