使用VB代码在Visio中连接两个图形

7. 获取shape的xy位置

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim visioApp As Visio.Application
        visioApp = New Visio.Application

        visioApp.Visible = False


        Dim filePath3 As String = "C:\Users\XUST\Desktop\5566.vsdx"

        Dim doc = visioApp.Documents.Open(filePath3)

        '获取当前的page
        Dim visioPage = visioApp.ActivePage

        '创建一个矩形
        Dim r1Master = doc.Masters.ItemU("Rectangle")
        Dim r1Shape = visioPage.Drop(r1Master, 1, 10)

        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = "59.999999263609 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = "154.99999857324 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "79.999999263609 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "64.6 mm"

        '设置矩形中心点的x的坐标
        'r1Shape.CellsSRC(1, 1, 0).FormulaU = "0 mm"
        '设置矩形中心点y的坐标
        'r1Shape.CellsSRC(1, 1, 1).FormulaU = "10 mm"
        '设置矩形高度
        r1Shape.CellsSRC(1, 1, 3).FormulaU = "0.25"
        '设置矩形宽度
        r1Shape.CellsSRC(1, 1, 2).FormulaU = "6"

        '获取shape的xy坐标，单位是里面
        Dim xpt = r1Shape.Cells("PinX").Result("cm")
        Dim ypt = r1Shape.Cells("PinY").Result("cm")

        MessageBox.Show("" & xpt & "___" & ypt)

        '再创建一个矩形
        Dim r2Master = doc.Masters.ItemU("Rectangle")
        Dim r2Shape = visioPage.Drop(r2Master, 8, 10)

        '设置矩形高度
        r2Shape.CellsSRC(1, 1, 3).FormulaU = "0.25"
        '设置矩形宽度
        r2Shape.CellsSRC(1, 1, 2).FormulaU = "6"

        '创建一个动态线图元
        Dim newLineMaster = doc.Masters.ItemU("Dynamic connector")

        '在00位置把这个动态线放下去，并获得对应的shape
        Dim newLineShape = visioPage.Drop(newLineMaster, 0#, 0#)

        Dim vsoCell1 As Visio.Cell
        Dim vsoCell2 As Visio.Cell

        '设置newLineShap链接线的起始位置位于id为1的元素的720位置
        vsoCell1 = newLineShape.CellsU("BeginX")
        vsoCell2 = r1Shape.CellsSRC(7, 2, 0)
        vsoCell1.GlueTo(vsoCell2)

        vsoCell1 = newLineShape.CellsU("EndX")
        vsoCell2 = r2Shape.CellsSRC(7, 0, 0)
        vsoCell1.GlueTo(vsoCell2)

        doc.SaveAs("C:\Users\XUST\Desktop\55667.vsdx")

        visioApp.Quit()

    End Sub

结果示例：

6.使用示例数据完成设置宽高

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim visioApp As Visio.Application
        visioApp = New Visio.Application

        visioApp.Visible = False


        Dim filePath3 As String = "C:\Users\XUST\Desktop\5566.vsdx"

        Dim doc = visioApp.Documents.Open(filePath3)

        '获取当前的page
        Dim visioPage = visioApp.ActivePage

        '创建一个矩形
        Dim r1Master = doc.Masters.ItemU("Rectangle")
        Dim r1Shape = visioPage.Drop(r1Master, 1, 10)

        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = "59.999999263609 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = "154.99999857324 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "79.999999263609 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "64.6 mm"

        '设置矩形中心点的x的坐标
        'r1Shape.CellsSRC(1, 1, 0).FormulaU = "0 mm"
        '设置矩形中心点y的坐标
        'r1Shape.CellsSRC(1, 1, 1).FormulaU = "10 mm"
        '设置矩形高度
        r1Shape.CellsSRC(1, 1, 3).FormulaU = "0.25"
        '设置矩形宽度
        r1Shape.CellsSRC(1, 1, 2).FormulaU = "6"

        '再创建一个矩形
        Dim r2Master = doc.Masters.ItemU("Rectangle")
        Dim r2Shape = visioPage.Drop(r2Master, 8, 10)


        '设置矩形高度
        r2Shape.CellsSRC(1, 1, 3).FormulaU = "0.25"
        '设置矩形宽度
        r2Shape.CellsSRC(1, 1, 2).FormulaU = "6"

        '创建一个动态线图元
        Dim newLineMaster = doc.Masters.ItemU("Dynamic connector")

        '在00位置把这个动态线放下去，并获得对应的shape
        Dim newLineShape = visioPage.Drop(newLineMaster, 0#, 0#)

        Dim vsoCell1 As Visio.Cell
        Dim vsoCell2 As Visio.Cell

        '设置newLineShap链接线的起始位置位于id为1的元素的720位置
        vsoCell1 = newLineShape.CellsU("BeginX")
        vsoCell2 = r1Shape.CellsSRC(7, 2, 0)
        vsoCell1.GlueTo(vsoCell2)

        vsoCell1 = newLineShape.CellsU("EndX")
        vsoCell2 = r2Shape.CellsSRC(7, 0, 0)
        vsoCell1.GlueTo(vsoCell2)

        doc.SaveAs("C:\Users\XUST\Desktop\55667.vsdx")

        visioApp.Quit()

    End Sub

大概效果如下：

5. 设置举行宽度和位置

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim visioApp As Visio.Application
        visioApp = New Visio.Application

        visioApp.Visible = False


        Dim filePath3 As String = "C:\Users\XUST\Desktop\5566.vsdx"

        Dim doc = visioApp.Documents.Open(filePath3)

        '获取当前的page
        Dim visioPage = visioApp.ActivePage

        '创建一个矩形
        Dim r1Master = doc.Masters.ItemU("Rectangle")
        Dim r1Shape = visioPage.Drop(r1Master, 1, 10)

        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = "59.999999263609 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = "154.99999857324 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "79.999999263609 mm"
        'r1Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "64.6 mm"

        '设置矩形中心点的x的坐标
        r1Shape.CellsSRC(1, 1, 0).FormulaU = "0 mm"
        '设置矩形中心点y的坐标
        r1Shape.CellsSRC(1, 1, 1).FormulaU = "10 mm"
        '设置矩形高度
        r1Shape.CellsSRC(1, 1, 3).FormulaU = "80 mm"
        '设置矩形宽度
        r1Shape.CellsSRC(1, 1, 2).FormulaU = "60 mm"

        '再创建一个矩形
        Dim r2Master = doc.Masters.ItemU("Rectangle")
        Dim r2Shape = visioPage.Drop(r2Master, 5, 10)

        '创建一个动态线图元
        Dim newLineMaster = doc.Masters.ItemU("Dynamic connector")

        '在00位置把这个动态线放下去，并获得对应的shape
        Dim newLineShape = visioPage.Drop(newLineMaster, 0#, 0#)

        Dim vsoCell1 As Visio.Cell
        Dim vsoCell2 As Visio.Cell

        '设置newLineShap链接线的起始位置位于id为1的元素的720位置
        vsoCell1 = newLineShape.CellsU("BeginX")
        vsoCell2 = r1Shape.CellsSRC(7, 2, 0)
        vsoCell1.GlueTo(vsoCell2)

        vsoCell1 = newLineShape.CellsU("EndX")
        vsoCell2 = r2Shape.CellsSRC(7, 0, 0)
        vsoCell1.GlueTo(vsoCell2)

        doc.SaveAs("C:\Users\XUST\Desktop\55667.vsdx")

        visioApp.Quit()

    End Sub

1. 原始版本

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim filePath1 As String = "C:\Users\XUST\Desktop\sample.vsdx"
        Dim filePath2 As String = "C:\Users\XUST\Desktop\sample-save.vsdx"
        Dim visioApp As Visio.Application
        visioApp = New Visio.Application
        'Dim doc As Visio.Document = visioApp.Documents.Add("")

        visioApp.Visible = False


        Dim filePath3 As String = "C:\Users\XUST\Desktop\3334455.vsdx"

        Dim doc = visioApp.Documents.Open(filePath3)

        '原文件中创建一个连接线，在00位置，由于源文件中最后一个图形ID为8，所以下面这句话创建的图像id为9
        visioApp.ActiveWindow.Page.Drop(doc.Masters.ItemU("Dynamic connector"), 0#, 0#)

        Dim vsoCell1 As Visio.Cell
        Dim vsoCell2 As Visio.Cell

        '设置id为9的链接线的起始位置位于id为1的元素的720位置
        vsoCell1 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(9).CellsU("BeginX")
        vsoCell2 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(7, 2, 0)
        vsoCell1.GlueTo(vsoCell2)

        vsoCell1 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(9).CellsU("EndX")
        vsoCell2 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(7).CellsSRC(7, 0, 0)
        vsoCell1.GlueTo(vsoCell2)

        doc.SaveAs("C:\Users\XUST\Desktop\4455.vsdx")

        visioApp.Quit()

    End Sub

2. 优化版本

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim visioApp As Visio.Application
        visioApp = New Visio.Application

        visioApp.Visible = False


        Dim filePath3 As String = "C:\Users\XUST\Desktop\3334455.vsdx"

        Dim doc = visioApp.Documents.Open(filePath3)

        '获取当前的page
        Dim visioPage = visioApp.ActivePage

        '创建一个动态线图元
        Dim newLineMaster = doc.Masters.ItemU("Dynamic connector")

        '在00位置把这个动态线放下去，并获得对应的shape
        Dim newLineShape = visioPage.Drop(newLineMaster, 0#, 0#)

        Dim vsoCell1 As Visio.Cell
        Dim vsoCell2 As Visio.Cell

        '设置newLineShap链接线的起始位置位于id为1的元素的720位置
        vsoCell1 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(newLineShape.ID).CellsU("BeginX")
        vsoCell2 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(7, 2, 0)
        vsoCell1.GlueTo(vsoCell2)

        vsoCell1 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(newLineShape.ID).CellsU("EndX")
        vsoCell2 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(7).CellsSRC(7, 0, 0)
        vsoCell1.GlueTo(vsoCell2)

        doc.SaveAs("C:\Users\XUST\Desktop\4455.vsdx")

        visioApp.Quit()

    End Sub

3. 继续优化
   替换visioApp.ActiveWindow.Page.Shapes.ItemFromID(newLineShape.ID)为newlineshape

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim visioApp As Visio.Application
        visioApp = New Visio.Application

        visioApp.Visible = False


        Dim filePath3 As String = "C:\Users\XUST\Desktop\3334455.vsdx"

        Dim doc = visioApp.Documents.Open(filePath3)

        '获取当前的page
        Dim visioPage = visioApp.ActivePage

        '创建一个动态线图元
        Dim newLineMaster = doc.Masters.ItemU("Dynamic connector")

        '在00位置把这个动态线放下去，并获得对应的shape
        Dim newLineShape = visioPage.Drop(newLineMaster, 0#, 0#)

        Dim vsoCell1 As Visio.Cell
        Dim vsoCell2 As Visio.Cell

        '设置newLineShap链接线的起始位置位于id为1的元素的720位置
        vsoCell1 = newLineShape.CellsU("BeginX")
        vsoCell2 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(7, 2, 0)
        vsoCell1.GlueTo(vsoCell2)

        vsoCell1 = newLineShape.CellsU("EndX")
        vsoCell2 = visioApp.ActiveWindow.Page.Shapes.ItemFromID(7).CellsSRC(7, 0, 0)
        vsoCell1.GlueTo(vsoCell2)

        doc.SaveAs("C:\Users\XUST\Desktop\4455.vsdx")

        visioApp.Quit()

    End Sub

4. 动态绘制矩形并连接

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Dim visioApp As Visio.Application
        visioApp = New Visio.Application

        visioApp.Visible = False


        Dim filePath3 As String = "C:\Users\XUST\Desktop\5566.vsdx"

        Dim doc = visioApp.Documents.Open(filePath3)

        '获取当前的page
        Dim visioPage = visioApp.ActivePage

        '创建一个矩形
        Dim r1Master = doc.Masters.ItemU("Rectangle")
        Dim r1Shape = visioPage.Drop(r1Master, 1, 10)

        '再创建一个矩形
        Dim r2Master = doc.Masters.ItemU("Rectangle")
        Dim r2Shape = visioPage.Drop(r2Master, 5, 10)

        '创建一个动态线图元
        Dim newLineMaster = doc.Masters.ItemU("Dynamic connector")

        '在00位置把这个动态线放下去，并获得对应的shape
        Dim newLineShape = visioPage.Drop(newLineMaster, 0#, 0#)

        Dim vsoCell1 As Visio.Cell
        Dim vsoCell2 As Visio.Cell

        '设置newLineShap链接线的起始位置位于id为1的元素的720位置
        vsoCell1 = newLineShape.CellsU("BeginX")
        vsoCell2 = r1Shape.CellsSRC(7, 2, 0)
        vsoCell1.GlueTo(vsoCell2)

        vsoCell1 = newLineShape.CellsU("EndX")
        vsoCell2 = r2Shape.CellsSRC(7, 0, 0)
        vsoCell1.GlueTo(vsoCell2)

        doc.SaveAs("C:\Users\XUST\Desktop\55667.vsdx")

        visioApp.Quit()

    End Sub