PPT里虽然绘图方便，但很多时候不够精确，比如我们要画一个120度的弧线，就很难做到准确。要想达到准确，最好的方法是用vba进行编程。下面我就写几段这样的程序。注意，这里只是针对一些图形难以精确画图的问题说的，所以不是vba画图语句大全。为清晰起见，下面的程序把关键地方加粗了。

先给出参数说明：

• t：图形到幻灯片页面顶部距离

• l：图形到幻灯片页面左边距离

• w：图形宽度

• h：图形高度（以上四个数据不是弧线本身所占据的位置和大小，而是弧线所属椭圆占据的位置和大小）

• a1：角度1

• a2：角度2（两个角度以横向右为正0度，逆时针为正，不明白的可以回忆中学数学课）

• a3：空心环宽度比例（0-100,100及以上为满扇形）

  
  

　　第1、2、3段程序中加粗语句的第一个参数决定了要绘制图形的类型，后四个参数分别决定了要绘制图形的位置和大小，即决定的是下左图中的八个浅色小点的位置，而s.Adjustments.Item(n)=…决定的是图形的具体形状，对应下左图中小黄点的位置。第四段程序中的加粗语句是以数组为参数，这些数组决定了多边形顶点坐标（见下右图的小黑点）。

　　各个参数中的长度以“磅”为单位，角度以度为单位。厘米转化为磅的代码为：

Public Function cm2p(cm As Single) As Single

    cm2p = cm * 28.35

End Function

　　我们可以先以厘米为单位设计好图形尺寸，用以上代码将其转化为磅，然后调用绘图程序。

程序1：画圆弧

Private Sub Draw1(t,l,w,h,a1,a2)

    On Err GoTo Err:

    Dim s As Shape

    Set s =ActiveWindow.View.Slide.Shapes.AddShape(msoShapeArc, t, l, w, h)

    s.Adjustments.Item(1) = -a2

    s.Adjustments.Item(2) = -a1

    Exit Sub

Err:

    MsgBox Err.Description, vbCritical + vbOKOnly, "错误"

End Sub

程序2：画弓形（在PPT里称为“弦形”，即弦及所对应的圆弧）

Private Sub Draw2(t, l, w, h, a1, a2)

    On Err GoTo Err:

    Dim s As Shape

    Set s = ActiveWindow.View.Slide.Shapes.AddShape(msoShapeChord, t, l, w, h)

    s.Adjustments.Item(1) = -a2

    s.Adjustments.Item(2) = -a1

    Exit Sub

Err:

    MsgBox Err.Description, vbCritical + vbOKOnly, "错误"

End Sub

程序3：画空心弧

Private Sub Draw3(t, l, w, h, a1, a2, a3)

    On Err GoTo Err:

    Dim s As Shape

    Set s =ActiveWindow.View.Slide.Shapes.AddShape(msoShapeBlockArc, t, l, w, h)

    s.Adjustments.Item(1) = -a2

    s.Adjustments.Item(2) = -a1

    s.Adjustments.Item(3) = a3 / 200     '将a3转化为0-0.5之间

    Exit Sub

Err:

    MsgBox Err.Description, vbCritical + vbOKOnly, "错误"

End Sub

程序4：画多边形（本例为画一个直角三角形，数组参数为顶点的坐标，其中a(*,0)为横向坐标，a(*,1)为纵向坐标，实际运行时改变其中的数组即可。如果首尾顶点坐标相同则为闭合的多边形，不同为折线段）

Private Sub Draw4( )

On Err GoTo Err:

    Dim arr() As Single

        ReDim arr(0 To 3, 0 To 1)

        arr(0, 0) = 0: arr(0, 1) = 0: arr(1, 0) = 0: arr(1, 1) = 100

        arr(2, 0) = 200: arr(2, 1) = 100: arr(3, 0) = 0: arr(3, 1) = 0

    ActiveWindow.View.Slide.Shapes.AddPolyline SafeArrayOfPoints:=arr

    Exit Sub

Err:

    MsgBox Err.Description, vbCritical + vbOKOnly, "错误"

End Sub

程序5：调整连接符。本例是先选择一个连接符对象，然后利用下面程序进行调整，即这里并没有创建新的连接符，而且本程序里连接符是否连接到已有对象以及连接符的类型【直线、肘形、曲线】

Private Sub Draw5(Optional a1=0,Optional a2=0.5,Optional a3=1)

On Error Goto Err:

    With ActiveWindow.Selection.ShapeRange(1)

        If .Connector = msoFalse Then        

            MsgBox "您选择的不是连接符，请选择一个连接符对象。", vbCritical + vbOKOnly, "警告"

        Else

            If .Adjustments.Count = 0 Then

                MsgBox "没有可以调整的点，如果您选择的是直线连接符，请改为肘形连接符或曲线连接符再进行调整。", vbOKOnly + vbInformation

           Else

                .Adjustments.Item(1)=a1

                If .Adjustments.Count >1 Then .Adjustments.Item(2)=a2

                If .Adjustments.Count >2 Then .Adjustments.Item(3)=a3

            End If

        End If

    End With

    Exit Sub

Err:

    MsgBox "没有选择对象，请选择一个连接符对象。", vbOKOnly + vbCritical, "警告"

End Sub