数学制卷过程中，常要在WORD中画坐标系及函数图象，用VBA不仅方便，而且准确。这里以绘制抛物线为例说明方法。结果如下图：

http://s8/bmiddle/557d2546ga7875a3c6497&690

第一步：WORD
中绘制直角坐标系，原点以页面左上角为绝对位置

先添加用户窗体，如下图：

 http://s4/bmiddle/557d2546ga77667ce5a83&690

再添加代码：

''*

''^The Code CopyIn [用户窗体-UserForm1]^''

''*
  

Private Sub CommandButton1_Click()

    Dim X0 As
Single, Y0 As Single, X1 As Single, Y1 As Single, X2 As Single, Y2
As Single

    Dim nX1 As
Integer, nX As Integer, nY1 As Integer, nY As Integer, nL As
Integer, nB As Integer, i As Integer, T1 As Integer

    Dim XLine As
Shape, YLine As Shape, MyTextbox As Shape

    Dim ct As
Single, M As Byte, MyValue As Single, ModValue As Byte

   

    On Error
Resume Next ''忽略错误

   
''必要数据判断

    If
Me.TextBox1 = "" Or Int(Me.TextBox1)
<> Me.TextBox1 * 1 Or Me.TextBox1 * 1
<= 0 Then MsgBox "请输入正整数! ", vbInformation: Exit
Sub

    If
Me.TextBox2 = "" Or Int(Me.TextBox2)
<> Me.TextBox2 * 1 Or Me.TextBox2 * 1
<= 0 Then MsgBox "请输入正整数! ", vbInformation: Exit
Sub

    If
Me.TextBox3 = "" Or Int(Me.TextBox3)
<> Me.TextBox3 * 1 Or Me.TextBox3 * 1
< 0 Then MsgBox "请输入自然数! ", vbInformation: Exit
Sub

    If
Me.TextBox4 = "" Or Int(Me.TextBox4)
<> Me.TextBox4 * 1 Or Me.TextBox4 * 1
<= 0 Then MsgBox "请输入正整数! ", vbInformation: Exit
Sub

    If
Me.TextBox5 = "" Or Int(Me.TextBox5)
<> Me.TextBox5 * 1 Or Me.TextBox5 * 1
< 0 Then MsgBox "请输入自然数! ", vbInformation: Exit
Sub

    If
Me.TextBox6 = "" Or Int(Me.TextBox6)
<> Me.TextBox6 * 1 Or Me.TextBox6 * 1
<= 0 Then MsgBox "请输入正整数! ", vbInformation: Exit
Sub

    If
Me.TextBox3 * 1 > Me.TextBox1 * 1 Or Me.TextBox6 * 1
> Me.TextBox2 * 1 Then MsgBox "无效数据!",
vbInformation: Exit Sub

  

   
Application.ScreenUpdating = False

   
''计算坐标轴交点及端点坐标，厘米转换为磅数,两端加长画箭头

    X0 =
CentimetersToPoints(Me.TextBox1)

    Y0 =
CentimetersToPoints(Me.TextBox2)

    T1 =
Me.TextBox3 * 1

    X1 = X0 -
CentimetersToPoints(Me.TextBox3 VBA.IIf(T1 > 0, 1,
0)) '负轴长为0时不加长

    X2 = X0
CentimetersToPoints(Me.TextBox4 1)

   

    T1 =
Me.TextBox5 * 1

    Y1 = Y0
CentimetersToPoints(Me.TextBox5 VBA.IIf(T1 > 0, 1,
0))

    Y2 = Y0 -
CentimetersToPoints(Me.TextBox6 1)

   

    With
ActiveDocument

       
'改名避免重复命名值出错

       
BeforeShapes = .Shapes.Count  
''获取工作之前的图形总数

       
If BeforeShapes >= 1 Then

           
For i = 1 To BeforeShapes

               
.Shapes(i).Name = "已有图形" & BeforeShapes
& i ''

           
Next

       
End If

       

       
'画轴

       
Set XLine = .Shapes.AddLine(X1, Y0, X2, Y0)

       
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, X2
- 5, Y0 2, 10, 15)

       
With
MyTextbox   
''设置X轴文本框

           
.Line.Visible = msoFalse

           
.TextFrame.MarginBottom = 0

           
.TextFrame.MarginLeft = 0

           
.TextFrame.MarginRight = 0

           
.TextFrame.MarginTop = 0

           
.TextFrame.TextRange.Font.Name = "Arial"

           
.TextFrame.TextRange.Font.Size = 10

           
.TextFrame.TextRange = "x"

       
End With

       
With XLine   
''设置箭头形状

           
.Line.EndArrowheadStyle = msoArrowheadTriangle

           
.Line.EndArrowheadLength = msoArrowheadLengthMedium

           
.Line.EndArrowheadWidth = msoArrowheadWidthMedium

       
End With

       

       
Set YLine = .Shapes.AddLine(X0, Y1, X0, Y2)

       
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, X0
- 12, Y2 - 5, 10, 15)

       
With
MyTextbox   
''设置Y轴文本框

           
.Line.Visible = msoFalse

           
.TextFrame.MarginBottom = 0

           
.TextFrame.MarginLeft = 0

           
.TextFrame.MarginRight = 0

           
.TextFrame.MarginTop = 0

           
.TextFrame.TextRange.Font.Name = "Arial"

           
.TextFrame.TextRange.Font.Size = 10

           
.TextFrame.TextRange = "y"

       
End With

       
With YLine   
''设置箭头形状

           
.Line.EndArrowheadStyle = msoArrowheadTriangle

           
.Line.EndArrowheadLength = msoArrowheadLengthMedium

           
.Line.EndArrowheadWidth = msoArrowheadWidthMedium

       
End With

       
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, X0
- 10, Y0 - 1, 15, 15)

       
With
MyTextbox   
''设置原点O文本框

           
.Line.Visible = msoFalse

           
.TextFrame.MarginBottom = 0

           
.TextFrame.MarginLeft = 0

           
.TextFrame.MarginRight = 0

           
.TextFrame.MarginTop = 0

           
.TextFrame.TextRange.Font.Name = "Arial"

           
.TextFrame.TextRange.Font.Size = 8

           
.TextFrame.TextRange = "O"

           
.ZOrder msoSendToBack

       
End With

       

       
''画刻度线

       
If Me.OptionButton1.Value = True Then Call SelAllShapes: End: Exit
Sub '未选刻度值退出

       
If Me.OptionButton2.Value = True Then MyValue = 1: ModValue =
1

       
If Me.OptionButton3.Value = True Then MyValue = 0.5: ModValue =
2

       
If Me.OptionButton4.Value = True Then MyValue = 0.1: ModValue =
10

       

       
nX1 = Me.TextBox1 * 1 - Me.TextBox3

       
nY1 = Me.TextBox2 * 1 Me.TextBox5

       
nL = Me.TextBox3 * ModValue

       
nB = Me.TextBox5 * ModValue

       
nX = (Me.TextBox3 * 1 Me.TextBox4) * ModValue

       
nY = (Me.TextBox5 * 1 Me.TextBox6) * ModValue

        

       
For i = 0 To nX

           
M = VBA.IIf(i Mod ModValue = 0, 6, 3)

           
ct = CentimetersToPoints(nX1 i * MyValue)

           
.Shapes.AddLine ct, Y0 - M, ct, Y0

           
If M = 6 And i <> nL
Then   ''忽略 0 值(与零点合)

               
''对X轴刻度

               
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, ct
- 2, Y0 3, 16, 16)

               
With
MyTextbox   
''设置刻度文本框及值

                   
.Line.Visible = msoFalse

                   
.TextFrame.MarginBottom = 0

                   
.TextFrame.MarginLeft = 0

                   
.TextFrame.MarginRight = 0

                   
.TextFrame.MarginTop = 0

                   
.TextFrame.TextRange.Font.Name = "Arial"

                   
.TextFrame.TextRange.Font.Size = 8

                   
.TextFrame.TextRange = (i - nL) / ModValue

                   
.ZOrder msoSendToBack

               
End With

           
End If

       
Next

       

         
For i = 0 To nY

           
M = VBA.IIf(i Mod ModValue = 0, 6, 3)

           
ct = CentimetersToPoints(nY1 - i * MyValue)

           
.Shapes.AddLine X0, ct, X0 M, ct

           
If M = 6 And i <> nB Then ''忽略 0
值(与零点合)

              
''对Y轴刻度

               
Set MyTextbox = .Shapes.AddTextbox(msoTextOrientationHorizontal, X0
- 12, ct - 8, 16, 16)

               
With
MyTextbox   
''设置刻度文本框及值

                   
.Line.Visible = msoFalse

                   
.TextFrame.MarginBottom = 0

                   
.TextFrame.MarginLeft = 0

                   
.TextFrame.MarginRight = 0

                   
.TextFrame.MarginTop = 0

                   
.TextFrame.TextRange.Font.Name = "Arial"

                   
.TextFrame.TextRange.Font.Size = 8

                   
.TextFrame.TextRange = (i - nB) / ModValue

                   
.ZOrder msoSendToBack

               
End With

           
End If

       
Next

       
Call SelAllShapes 
''组合新加的图形并全选(SelAllShapes)

    End
With

   
Application.ScreenUpdating = True

    End

End Sub

''----------------------

Private Sub CommandButton2_Click()

    Me.TextBox1
= 10

    Me.TextBox2
= 10

    Me.TextBox3
= 4

    Me.TextBox4
= 4

    Me.TextBox5
= 4

    Me.TextBox6
= 4

   
Me.OptionButton1.Value = False

   
Me.OptionButton2.Value = True

   
Me.OptionButton3.Value = False

   
Me.OptionButton4.Value = False

End Sub

''----------------------

  

Private Sub CommandButton3_Click()

    End

End Sub

''----------------------

Private Sub UserForm_Activate()

   
Me.TextBox3.SetFocus

   
Me.CommandButton1.Default = True

End Sub

'* -------------------------------------------------------------------------- 

'^The Code CopyIn [标准模块-模块 1]^' 
  

'* -----------------------------------------------------------------   

Public BeforeShapes
As Integer

Sub 画坐标系()

   
UserForm1.Show

End Sub

''----------------------

Sub SelAllShapes()

    Dim
AllShapes(), ShapeCount As Integer, N As Shape, Y As Integer

    ShapeCount =
ActiveDocument.Shapes.Count

    Y = 0

   
''定义一维上标可变数组,从 0 开始

    ReDim
AllShapes(ShapeCount - BeforeShapes - 1)

    With
ActiveDocument

       
For Each N In .Shapes

           
If N.Name Like "已有图形*" = False Then

               
AllShapes(Y) = N.Name

               
Y = Y 1

           
End If

       
Next N

       
With .Shapes.Range(AllShapes).Group

           
.ZOrder msoSendToBack

           
.Select

           
''   .Name = "坐标系"

       
End With

    End
With

End Sub

''----------------------

运行效果图：

http://s8/middle/557d2546ga77671c1c1d7&690
 

第二步：绘制抛物线，适当修改系数、区间及原点位置

''----------------------

'在Word中画抛物线

Sub DrawParabola()

  Dim a As Single, b As Single, c As Single, m As
Single, n As Single, x As Single

  Dim sngArray(1 To 100, 1 To 2) As Single

 

  a = 0.5 '系数a,b,c

  b = -1

  c = -1.5

  m = -2.5 '指定区间[m,n]

  n = 4.5

 

  For i = 1 To 100

    x = m i *
(n - m) / 100

    sngArray(i,
1) = CentimetersToPoints(10 x) '以厘米为单位，原点位置(10，10)

    sngArray(i,
2) = CentimetersToPoints(10 - (a * x * x b * x
c))'二次函数解析式

  Next

   
'添加贝塞尔曲线

   
ActiveDocument.Shapes.AddCurve SafeArrayOfPoints:=sngArray

End Sub

修改解析式，可类似绘制各种函数图象或曲线。在图象上右击鼠标可编辑结点。

代码下载

http://www.3djihe.com 3D几何网下载中心