Построить график функции y(x), которую вводит пользователь

Sub CallPlotter()
    frmPlotter.Show
End Sub

Sub TabulateFunction()
    Dim h As Double
    Dim i As Long
    Const functionstring = "X^2 - 5*X + 7"
    Const a = 2
    Const b = 5
    'Функция табулируется на 10 отрезков.
    Const n = 10
    'Заголовки.
    Evaluate("a1:b1") = Evaluate("{""X"",""Y""}")
    'Определяем шаг табуляции.
    h = (b - a) / n
    'Заполняем данные по X (в столбце a) и Y (в столбце b).
    For i = 0 To n
        Evaluate("a" & (i + 2)) = a + i * h
        Evaluate("b" & (i + 2)) = Evaluate(Replace(UCase(functionstring), "X", "a" & (i + 2)))
    Next i
End Sub

Sub Macro1()
    ActiveSheet.Shapes.AddChart.Select
    ActiveChart.SetSourceData Source:=.Range("Sheet1!$B$1:$B$12")
    ActiveChart.ChartType = xlLine
    ActiveChart.SeriesCollection(1).XValues = "=Sheet1!$A$2:$A$12"
    ActiveChart.ChartArea.Copy
End Sub

Sub Macro1()
    Selection.TypeParagraph
    Selection.PasteAndFormat (wdChartLinked)
End Sub

'Процедура табуляции функции, заданной строкой functionstring,
'на отрезке от a до b.
Sub TabulateFunction(ByVal eApp As Object, ByVal functionstring As String, ByVal a As Double, ByVal b As Double)
    Dim h As Double
    Dim i As Long
    'Функция табулируется на 10 отрезков.
    Const n = 10
    With eApp
        'Заголовки.
        .Evaluate("a1:b1") = .Evaluate("{""X"",""Y""}")
        'Определяем шаг табуляции.
        h = (b - a) / n
        'Заполняем данные по X (в столбце a) и Y (в столбце b).
        For i = 0 To n
            .Evaluate("a" & (i + 2)) = a + i * h
            .Evaluate("b" & (i + 2)) = .Evaluate(Replace(UCase(functionstring), "X", "a" & (i + 2)))
        Next i
    End With
End Sub
 
'Записанная макрорекордером и немного модифицированная процедура
'построения графика на основе диапазона с данными по координатам X и Y функции.
'Предполагается, что функция табулируется на 10 отрезков (т.е.
'диапазон данных занимает 2 столбца и 12 строк, включая заголовки).
Sub ExcelMacro1(ByVal eApp As Object)
    With eApp
        .ActiveSheet.Shapes.AddChart.Select
        .ActiveChart.SetSourceData Source:=.Range("Лист1!$B$1:$B$12")
        .ActiveChart.ChartType = xlLine
        .ActiveChart.SeriesCollection(1).XValues = "=Лист1!$A$2:$A$12"
        'Построенный график копируем в буфер обмена.
        .ActiveChart.ChartArea.Copy
    End With
End Sub
 
'Записанная макрорекордером и немного модифицированная процедура вставки графика.
Sub WordMacro1()
    Selection.TypeParagraph
    Selection.PasteAndFormat wdChartPicture
End Sub
 
'Процедура создания графика в Word на основе строки
'functionstring, задающей функцию, и данных о границах a и b.
Sub MakeChartInWord(ByVal functionstring As String, ByVal a As Double, ByVal b As Double)
    Dim eApp As Object
    Dim eWbk As Object
    'Данные для тестирования.
    'functionstring = "X^2 - 5*X + 7"
    'a = 2
    'b = 5
    On Error GoTo ErrHandler
    Set eApp = CreateObject("Excel.Application")
    Set eWbk = eApp.Workbooks.Add
    TabulateFunction eApp, functionstring, a, b
    ExcelMacro1 eApp
    WordMacro1
    eWbk.Close False
    Set eWbk = Nothing
    Set eApp = Nothing
    On Error GoTo 0
    Exit Sub
    
ErrHandler:
    eWbk.Close False
    Set eWbk = Nothing
    Set eApp = Nothing
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

Private Sub cbOk_Click()
    Dim functionstring As String
    Dim a As Double
    Dim b As Double
    functionstring = tbFormula.Text
    a = CDbl(Val(tbA.Text))
    b = CDbl(Val(tbB.Text))
    MakeChartInWord functionstring, a, b
    Unload Me
End Sub

Sub TabulateFunction(ByVal eApp As Object, ByVal functionstring As String, ByVal a As Double, ByVal b As Double)
   Dim rgX As Object
   Dim h As Double
   Dim i As Long
   'Функция табулируется на 10 отрезков.
   Const n = 10
   'Настраиваем обработку регулярного выражения.
   Set rgX = CreateObject("VBScript.RegExp")
   With rgX
      .Global = True
      .IgnoreCase = True
      .Pattern = "([ ()+-/*^])x([ ()+-/*^])|^x([ ()+-/*^])|([ ()+-/*^])x$"
   End With
   With eApp
      'Заголовки.
      .Evaluate("a1:b1") = .Evaluate("{""X"",""Y""}")
      'Определяем шаг табуляции.
      h = (b - a) / n
      'Заполняем данные по X (в столбце a) и Y (в столбце b).
      For i = 0 To n
         .Evaluate("a" & (i + 2)) = a + i * h
         .Evaluate("b" & (i + 2)) = .Evaluate(rgX.Replace(functionstring, "$1$4" & "a" & (i + 2) & "$2$3"))
      Next i
   End With
End Sub

'        .ActiveChart.SetSourceData Source:=.Range("Sheet1!$B$1:$B$" & ntabs + 2)
        .ActiveChart.SetSourceData Source:=.activesheet.Range("B1:B" & ntabs + 2)
        .ActiveChart.ChartType = xlLine
'        .ActiveChart.SeriesCollection(1).XValues = "=Sheet1!$A$2:$A$" & ntabs + 2
        .ActiveChart.SeriesCollection(1).XValues = .activesheet.Range("A1:A" & ntabs + 2)

Sub DrawGraph()
 
Dim Lex(1 To 200) As String
    frmAskFormula.Tag = ""
    frmAskFormula.Show
    If frmAskFormula.Tag = "" Then Exit Sub
    Formula$ = frmAskFormula.TextBox1.Text
    Parse Formula$, Lex()
    For i% = 1 To 200
        If Lex(i%) = "" Then Exit For
        If UCase$(Lex(i%)) = "X" Then Lex(i%) = "AL1"
    Next i%
    Formula$ = "="
    For i% = 1 To 200
        If Lex(i%) = "" Then Exit For
        Formula$ = Formula$ + Lex$(i%)
    Next i%
    Sheets(1).Range("AM1").Formula = UCase$(Formula$)
    xMin# = Val(frmAskFormula.TextBox2.Text)
    xMax# = Val(frmAskFormula.TextBox3.Text)
    dx# = (xMax# - xMin#) / 100
    x# = xMin#
    For i% = 1 To 100
        Sheets(1).Range("AL1").Value = x#
        Sheets(1).Range("AO" + CStr(i%)).Value = x#
        Sheets(1).Range("AP" + CStr(i%)).Value = Sheets(1).Range("AM1").Value
        x# = x# + dx#
    Next i%
End Sub
 
Sub Parse(Frm As String, Lex() As String)
    For i% = 1 To UBound(Lex, 1)
        Lex(i%) = ""
    Next
    p% = 0
    Tmp$ = ""
    For i% = 1 To Len(Frm)
        s$ = Mid$(Frm, i%, 1)
        Select Case (s$)
               Case "+", "-", "*", "/", "^", "(", ")"
                    If Tmp$ <> "" Then
                       p% = p% + 1
                       Lex(p%) = Tmp$
                    End If
                    p% = p% + 1
                    Lex(p%) = s$
                    Tmp$ = ""
               Case " "
               Case Else
                    Tmp$ = Tmp$ + s$
          End Select
     Next i%
     If Tmp$ <> "" Then
        p% = p% + 1
        Lex(p%) = Tmp$
     End If
End Sub
 
Sub Clear()
    Columns("AM:AP").Select
    Selection.ClearContents
    Range("A1").Select
End Sub

'Процедура табуляции функции, заданной строкой functionstring,
'на отрезке от a до b.
Sub TabulateFunction(ByVal eApp As Object, ByVal functionstring As String, ByVal a As Double, ByVal b As Double)
   Dim rgX As Object
   Dim h As Double
   Dim i As Long, j As Long
   Dim s As String, pn As String
   Dim nx As Object 'excel.name
   With eApp.activesheet
      'Заголовки.
      .Range("a1:b1") = Split("X Y(x)")
      'Определяем шаг табуляции.
      h = (b - a) / ntabs
      'Заполняем данные по X (в столбце a) и Y (в столбце b).
      For i = 0 To ntabs
         .Names.Add "x", "=" & Str(a + i * h) 'существующее имя заменяется новым
         .Range("a" & (i + 2)) = a + i * h 'или .Evaluate("x")
         .Range("b" & (i + 2)) = .Evaluate(functionstring)
      Next i
   End With
End Sub

'Процедура табуляции функции, заданной строкой functionstring,
'на отрезке от a до b.
Sub TabulateFunction(ByVal eApp As Object, ByVal functionstring As String, ByVal a As Double, ByVal b As Double)
   Dim rgX As Object
   Dim h As Double
   Dim i As Long, j As Long
   Dim s As String, pn As String
   Dim nx As Object 'excel.name
   With eApp.activesheet
      'Заголовки.
      .Range("a1:b1") = Split("X Y(x)")
      .Names.Add "x", "=RC[-1]" 'имя, которое ссылается на ячейку слева
      With .Range("a2").Resize(ntabs+1)
        .Cells(1) = a
        .Cells(ntabs+1) = b
        'заполняем диапазон Х инструментом "прогрессия"
        .DataSeries , -4132, , , , True '-4132=xlLinear, True - тренд
        'заполняем диапазон Y формулой
        .Offset(, 1).Formula = "=" & functionstring
      End With
   End With
End Sub