新浪博客
第一步：WORD
中绘制直角坐标系，原点以页面左上角为绝对位置
先添加用户窗体，如下图：
再添加代码：
''*
''^The Code CopyIn [用户窗体-UserForm1]^''
''*
Private Sub CommandButton1_Click()
Single, Y0 As Single, X1 As Single, Y1 As Single, X2 As Single, Y2
As Single
Integer, nX As Integer, nY1 As Integer, nY As Integer, nL As
Integer, nB As Integer, i As Integer, T1 As Integer
Shape, YLine As Shape, MyTextbox As Shape
Single, M As Byte, MyValue As Single, ModValue As Byte
Resume Next ''忽略错误
''必要数据判断
Me.TextBox1 = '' Or Int(Me.TextBox1)
<> Me.TextBox1 * 1 Or Me.TextBox1 * 1
<= 0 Then MsgBox '请输入正整数! ', vbInformation: Exit
Sub
Me.TextBox2 = '' Or Int(Me.TextBox2)
<> Me.TextBox2 * 1 Or Me.TextBox2 * 1
<= 0 Then MsgBox '请输入正整数! ', vbInformation: Exit
Sub
Me.TextBox3 = '' Or Int(Me.TextBox3)
<> Me.TextBox3 * 1 Or Me.TextBox3 * 1
< 0 Then MsgBox '请输入自然数! ', vbInformation: Exit
Sub
Me.TextBox4 = '' Or Int(Me.TextBox4)
<> Me.TextBox4 * 1 Or Me.TextBox4 * 1
<= 0 Then MsgBox '请输入正整数! ', vbInformation: Exit
Sub
Me.TextBox5 = '' Or Int(Me.TextBox5)
<> Me.TextBox5 * 1 Or Me.TextBox5 * 1
< 0 Then MsgBox '请输入自然数! ', vbInformation: Exit
Sub
Me.TextBox6 = '' Or Int(Me.TextBox6)
<> Me.TextBox6 * 1 Or Me.TextBox6 * 1
<= 0 Then MsgBox '请输入正整数! ', vbInformation: Exit
Sub
Me.TextBox3 * 1 > Me.TextBox1 * 1 Or Me.TextBox6 * 1
> Me.TextBox2 * 1 Then MsgBox '无效数据!',
vbInformation: Exit Sub
Application.ScreenUpdating = False
''计算坐标轴交点及端点坐标，厘米转换为磅数,两端加长画箭头
CentimetersToPoints(Me.TextBox1)
CentimetersToPoints(Me.TextBox2)
Me.TextBox3 * 1
CentimetersToPoints(Me.TextBox3 VBA.IIf(T1 > 0, 1,
0)) '负轴长为0时不加长
CentimetersToPoints(Me.TextBox4 1)
Me.TextBox5 * 1
CentimetersToPoints(Me.TextBox5 VBA.IIf(T1 > 0, 1,
0))
CentimetersToPoints(Me.TextBox6 1)
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(msoTextOrientationHorizo
- 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(msoTextOrientationHorizo
- 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(msoTextOrientationHorizo
- 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