一、參數的窗體配置
二、窗體中三個按鈕的代碼：
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 = Application.CentimetersToPoints(Me.TextBox1) '橫軸原點的位置
Y0 = Application.CentimetersToPoints(Me.TextBox2)'縱軸原點的位置
T1 = Me.TextBox3 * 1
X1 = X0 - Application.CentimetersToPoints(Me.TextBox3 + VBA.IIf(T1 > 0, 1, 0)) '負軸長爲0時不加長
X2 = X0 + Application.CentimetersToPoints(Me.TextBox4 + 1)
T1 = Me.TextBox5 * 1
Y1 = Y0 + Application.CentimetersToPoints(Me.TextBox5 + VBA.IIf(T1 > 0, 1, 0))
Y2 = Y0 - Application.CentimetersToPoints(Me.TextBox6 + 1)
With ActiveSheet 'ActiveDocument
'改名避免重複命名值出錯
BeforeShapes = .Shapes.Count ''獲取工作之前的圖形總數
If BeforeShapes >= 1 Then
.Shapes.SelectAll: Selection.Delete
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.Characters.Text= "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.Characters.Text= "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.Characters.Text= "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 '縱軸上第一個刻度的位置 (x0,y0)爲原點
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) '整點刻度爲6像素長，非整點刻度爲3像素長
ct = Application.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.Characters.Text= (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 = Application.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.Characters.Text= (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 = ActiveSheet.Shapes.Count
Y = 0
''定義一維上標可變數組,從 0 開始
ReDim AllShapes(ShapeCount - BeforeShapes - 1)
With ActiveSheet
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
四、繪製函數圖像
第二步：繪製拋物線，適當修改係數、區間及原點位置
''----------------------
'在excel中畫拋物線
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
'添加貝塞爾曲線
Activesheet.Shapes.AddCurve SafeArrayOfPoints:=sngArray
End Sub
