如何用VBA绘制多边形

        Office软件不是作图软件，但是很多时候就是需要在其中画图，甚至想用VBA去自动操作，也许是奇葩的想法，但是存在的就是合理的，一起来看看在Word和Excel中如何实现吧。

        想要画出多边形，无外乎下面两种思路：

        - 方法1：多个独立线段，首尾相连
        - 方法2：直接调用Office VBA对象模型的相关

使用方法2更容易对于多边形进行一些格式控制之类的操作。

        绘制多边形的核心是计算多边形的顶点坐标，这个是纯数学问题，不知道如何处理的，请自行百度补脑。为了简化，下面的示例代码以四边形为例进行演示。

>>   Excel示例1

Sub ExcelPolyline1()
    Dim Shp As Shape
    Dim arrPoint(1 To 5, 1 To 2) As Single

    arrPoint(1, 1) = 50
    arrPoint(1, 2) = 50
    arrPoint(2, 1) = 50
    arrPoint(2, 2) = 150
    arrPoint(3, 1) = 150
    arrPoint(3, 2) = 150
    arrPoint(4, 1) = 150
    arrPoint(4, 2) = 50
    arrPoint(5, 1) = 50
    arrPoint(5, 2) = 50

    Set Shp = ActiveSheet.Shapes.AddPolyline(SafeArrayOfPoints:=arrPoint)
    Shp.Fill.Visible = msoFalse
End Sub

        四边形的四个顶点坐标分别为(50,50), (50,150), (150,150), (150,50)，既然只有四个顶点，那么arrPoint数组为什么要定义成5x2的数组呢？为了绘制闭合曲线，顶点坐标最后一个和第一应要重合。

语法

表达式。AddPolyline( SafeArrayOfPoints )

表达式_一个表示形状对象的变量。

参数

名称	必需/可选	数据类型	说明
SafeArrayOfPoints	必需	Variant	由指定多边形顶点的坐标对组成的数组。

返回值

Shape

注解

若要形成一个闭合的多边形，请为多边形的起点和终点指定相同的坐标。

>>   Excel示例2

        前面提到绘制多边形，最核心的是计算顶点，Excel肯定是最擅长这项任务的了，Excel中算完了在贴到代码中有些太费事，即使是VBA小白也知道，直接读取单元格就可以了，Bingo开始操练起来。

        在Excel中已经计算出了四个顶点坐标，代码读取单元格，太太简单了吧。先定义了如下名称：

                

Sub ExcelPolyline2()
    Dim Shp As Shape, arrPoint
    Call ClearShp
    arrPoint = [Point].Value
    Set Shp = ActiveSheet.Shapes.AddPolyline(SafeArrayOfPoints:=arrPoint)
    Shp.Fill.Visible = msoFalse
End Sub

        代码有了，直接F5吧，什么情况，这么简单的代码也会出错！？

        拿出单步调试的法宝，最终发现是这行代码在作怪。

    Set Shp = ActiveSheet.Shapes.AddPolyline(SafeArrayOfPoints:=arrData)

        仔细拜读一下MSDN，参数SafeArrayOfPoints类型为Variant，其实经过多次测试发现，这个参数赋值必须是Single！必须是Single！必须是Single！ （重要的事情说三遍！）。下面代码产生的数组是Double类型，这就是1004跳出来的原因。

arrPoint = [Point].Value

        原因找到了，动手改造一下代码：

Sub ExcelPolyline2Rev()
    Dim Shp As Shape, arrData, i, j
    Dim arrPoint() As Single
    Call ClearShp
    arrData = [Point].Value
    ReDim arrPoint(1 To 5, 1 To 2)
    For i = 1 To 5
        For j = 1 To 2
            arrPoint(i, j) = arrData(i, j)
        Next
    Next
    Set Shp = ActiveSheet.Shapes.AddPolyline(SafeArrayOfPoints:=arrPoint)
    Shp.Fill.Visible = msoFalse
End Sub

        这次终于可以画出四边形了。

>>   Excel示例3

        如果绘制图形时调整一下图形的参数，可以画出一些好玩的东西来，上代码！

Sub ExcelPolyline3()
    Dim Shp As Shape, arrData, i, j, k
    Dim arrPoint() As Single
    Call ClearShp
    For k = 20 To 200 Step 20
        [Rad] = k
        '[Center_X] = [Center_X] + k - 10
        [Center_X] = [Center_X] + k / 40
        [Center_Y] = [Center_Y] + k / 40
        arrData = [Point].Value
        ReDim arrPoint(1 To 5, 1 To 2)
        For i = 1 To 5
            For j = 1 To 2
                arrPoint(i, j) = arrData(i, j)
            Next
        Next
        Set Shp = ActiveSheet.Shapes.AddPolyline(SafeArrayOfPoints:=arrPoint)
        Shp.Fill.Visible = msoFalse
    Next
    [Center_X] = 300
    [Center_Y] = 350
End Sub

        是不是有点儿立体图的感觉，有兴趣的可以再精雕细琢填充渐变色。

>>   Excel示例补充代码

        每次绘图前清理工作表中Shape对象的代码。

Sub ClearShp()
    For Each s In ActiveSheet.Shapes
        s.Delete
    Next
End Sub

>>   Word示例

        Excel可以轻松画图，同门师弟Word自然也可以轻松搞定，但是代码略有不同，需要AddCanvas。

Sub WordCanvasPolyline()
    Dim objDoc As Document
    Dim shpCanvas As Shape
    Dim arrPoint(1 To 5, 1 To 2) As Single
    Set objDoc = ThisDocument
    Set shpCanvas = objDoc.Shapes.AddCanvas( _
        Left:=100, Top:=100, Width:=400, Height:=400)
    arrPoint(1, 1) = 50
    arrPoint(1, 2) = 50
    arrPoint(2, 1) = 50
    arrPoint(2, 2) = 150
    arrPoint(3, 1) = 150
    arrPoint(3, 2) = 150
    arrPoint(4, 1) = 150
    arrPoint(4, 2) = 50
    arrPoint(5, 1) = 50
    arrPoint(5, 2) = 50
    Set Shp = shpCanvas.CanvasItems.AddPolyline(SafeArrayOfPoints:=sngArray)
    Shp.Fill.Visible = msoFalse
End Sub

        写在最后，VBA中画图有什么用呢？仁者见仁，智者见智。如果对于你有用，尽管拿去用吧，如果你用不到，就看个乐吧。