用VBA在WORD中绘制图形及函数图象

http://s3/middle/557d2546ga7022ebb3a52&690

1.绘制一个“开关”图形

'宏 Switch实现在指定位置绘制一个“开关”图形。
Sub Switch()
    ActiveDocument.Shapes.AddLine(100, 110, 120, 110).Name = "shp1"
    ActiveDocument.Shapes.AddShape(msoShapeOval, 120, 108, 4, 4).Name = "shp2" 'Oval 椭圆形
    ActiveDocument.Shapes.AddShape(msoShapeOval, 130, 108, 4, 4).Name = "shp3"
    ActiveDocument.Shapes.AddLine(134, 110, 154, 110).Name = "shp4"
    ActiveDocument.Shapes.AddLine(122, 108, 132, 104).Name = "shp5"
    ActiveDocument.Shapes.Range(Array("shp1", "shp2", "shp3", "shp4", "shp5")).Group
End Sub

2.添加绘图画布

'下列示例在新文档中添加绘图画布，然后在绘图画布上添加两个图形，并设置填充和线条属性。

Sub AddInlineCanvas()
    Dim docNew As Document
    Dim shpCanvas As Shape

    Set docNew = Documents.Add

    'Add a drawing canvas to the new document
    Set shpCanvas = docNew.Shapes.AddCanvas( _
        Left:=150, Top:=150, Width:=70, Height:=70)
    shpCanvas.WrapFormat.Type = wdWrapInline

    'Add shapes to drawing canvas
    With shpCanvas.CanvasItems
        .AddShape msoShapeHeart, Left:=10, _
            Top:=10, Width:=50, Height:=60
        .AddLine BeginX:=0, BeginY:=0, _
            EndX:=70, EndY:=70
    End With
    With shpCanvas
        .CanvasItems(1).Fill.ForeColor _
            .RGB = RGB(Red:=255, Green:=0, Blue:=0)
        .CanvasItems(2).Line _
            .EndArrowheadStyle = msoArrowheadTriangle
    End With
End Sub

3.添加一条贝赛尔曲线

本例向活动文档添加一条两段的贝塞尔曲线，并且将其定位在第二段（文档中至少要有两段，否则出错）。

选择曲线，右击可编辑顶点。

Sub BezierCurve()
    Dim sngArray(1 To 7, 1 To 2) As Single

    sngArray(1, 1) = 0
    sngArray(1, 2) = 0
    sngArray(2, 1) = 72
    sngArray(2, 2) = 72
    sngArray(3, 1) = 100
    sngArray(3, 2) = 40
    sngArray(4, 1) = 20
    sngArray(4, 2) = 50
    sngArray(5, 1) = 90
    sngArray(5, 2) = 120
    sngArray(6, 1) = 60
    sngArray(6, 2) = 30
    sngArray(7, 1) = 150
    sngArray(7, 2) = 90

    ActiveDocument.Shapes.AddCurve SafeArrayOfPoints:=sngArray, Anchor:=ActiveDocument.Paragraphs(2).Range
End Sub

4.绘制正弦曲线

'在Word中画正弦曲线
Sub DrawSin()
  Dim i As Single, x1 As Single, x2 As Single, x As Single, n As Single
  Dim sngArray(1 To 100, 1 To 2) As Single
  Const PI As Single = 3.1415
  x1 = 0       '初始角度值
  x2 = 1440    '终止角度值
  x = 1440     '终初角度差
  n = x / 360  '波数
  For i = 1 To 100
    sngArray(i, 1) = 100 + 2 * i
    sngArray(i, 2) = 200 - 30 * Sin(4 * n * PI * i / 200 + x1)
  Next
    '添加贝塞尔曲线
    ActiveDocument.Shapes.AddCurve SafeArrayOfPoints:=sngArray
End Sub