VERSION 5.00
Begin VB.Form Form1 
   BackColor       =   &H00C000C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Решение уравнения 3x-4ln x -5 =0, [2;4]"
   ClientHeight    =   6615
   ClientLeft      =   45
   ClientTop       =   615
   ClientWidth     =   10440
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6615
   ScaleWidth      =   10440
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton CmdSaveText 
      Caption         =   "Сохранить"
      Height          =   375
      Left            =   240
      TabIndex        =   15
      Top             =   6000
      Width           =   1695
   End
   Begin VB.CommandButton CmdSaveBitmap 
      Caption         =   "Сохранить рисунок"
      Height          =   375
      Left            =   2160
      TabIndex        =   14
      Top             =   6000
      Width           =   1695
   End
   Begin VB.CommandButton ClearCmd 
      Caption         =   "Очистить"
      Height          =   375
      Left            =   2160
      TabIndex        =   13
      Top             =   5400
      Width           =   1695
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0FFFF&
      Height          =   6375
      Left            =   3960
      ScaleHeight     =   6315
      ScaleWidth      =   6315
      TabIndex        =   8
      Top             =   120
      Width           =   6375
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Вычислить"
      Default         =   -1  'True
      Height          =   375
      Left            =   240
      TabIndex        =   7
      Top             =   5400
      Width           =   1695
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H00E0E0E0&
      Caption         =   "Исходные данные и результаты вычислений"
      Height          =   4935
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   3735
      Begin VB.TextBox Text5 
         BackColor       =   &H00C0FFC0&
         Height          =   285
         Left            =   2040
         TabIndex        =   12
         Top             =   1320
         Width           =   1575
      End
      Begin VB.TextBox Text4 
         BackColor       =   &H00C0FFC0&
         Height          =   285
         Left            =   2040
         TabIndex        =   11
         Top             =   840
         Width           =   1575
      End
      Begin VB.TextBox Text3 
         BackColor       =   &H00C0FFC0&
         Height          =   285
         Left            =   2040
         Locked          =   -1  'True
         TabIndex        =   6
         Top             =   4440
         Width           =   1575
      End
      Begin VB.TextBox Text2 
         BackColor       =   &H00C0FFC0&
         Height          =   2085
         Left            =   120
         Locked          =   -1  'True
         MultiLine       =   -1  'True
         ScrollBars      =   3  'Both
         TabIndex        =   5
         Top             =   2160
         Width           =   3495
      End
      Begin VB.TextBox Text1 
         BackColor       =   &H00C0FFC0&
         Height          =   285
         Left            =   2040
         TabIndex        =   4
         ToolTipText     =   "Введите точность вычисления от 0,00000001 до 0,1"
         Top             =   360
         Width           =   1575
      End
      Begin VB.Label Label5 
         BackStyle       =   0  'Transparent
         Caption         =   "Конечное значение"
         Height          =   255
         Left            =   120
         TabIndex        =   10
         Top             =   1320
         Width           =   1575
      End
      Begin VB.Label Label4 
         BackStyle       =   0  'Transparent
         Caption         =   "Начальное значение"
         Height          =   255
         Left            =   120
         TabIndex        =   9
         Top             =   840
         Width           =   1575
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "Число итераций:"
         Height          =   195
         Left            =   240
         TabIndex        =   3
         Top             =   4440
         Width           =   1275
      End
      Begin VB.Label Label2 
         BackStyle       =   0  'Transparent
         Caption         =   "Приближения корня X"
         Height          =   255
         Left            =   120
         TabIndex        =   2
         Top             =   1800
         Width           =   1815
      End
      Begin VB.Label Label1 
         BackStyle       =   0  'Transparent
         Caption         =   "Точность вычисления"
         Height          =   255
         Left            =   120
         TabIndex        =   1
         Top             =   360
         Width           =   1815
      End
   End
   Begin VB.Menu Filemnu 
      Caption         =   "Файл"
      Begin VB.Menu Scetmun 
         Caption         =   "Вычислить"
         Shortcut        =   {F2}
      End
   End
   Begin VB.Menu savemnu 
      Caption         =   "Сохранить"
      Begin VB.Menu Svsmnu 
         Caption         =   "Сохранить статистику"
         Shortcut        =   ^S
      End
      Begin VB.Menu svpmnu 
         Caption         =   "Сохранить рисунок"
         Shortcut        =   ^P
      End
   End
   Begin VB.Menu Clsmnu 
      Caption         =   "Очистить"
   End
   Begin VB.Menu Aboutmnu 
      Caption         =   "О программе"
   End
   Begin VB.Menu Exitmnu 
      Caption         =   "Выход"
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const MaxIterac = 500 ' максимальное число итераций

Private Const BmpFail As String = "Mybmp.bmp"
Rem "внимание, не делайте меньше во избежание зацикливания при вычислении корня"
Private Const MinX As Double = 1 ' минимальное значение X
Private Const MaxX As Double = 5 ' максимальное значение X
Private Const MaxToc As Double = 0.1 ' максимальное значение точности вычисления корня
Private Const MinToc As Double = 0.000001 ' минимальное значение точности вычисления корня
Private Const MinInterval As Double = 0.5 ' минимальное значение отрезка исследованрия функции
Dim tocn As Double

Rem "число разбиений при предварительной табуляции"
Private Const ntt As Long = 100

Rem "значение, сигнализирующее об ошибке"
Private Const BadZnac As Long = -2147483648#

Rem "минимальное и максимальное значения функции на интервале..."
Dim ymin As Double, ymax As Double
Dim xn As Double, xk As Double
Dim Result As Double

Private Sub Aboutmnu_Click()
Form2.Show
End Sub

Private Sub Clsmnu_Click()
ClearCmd_Click ' чистим окно программы от рассчётов через меню программы
End Sub

Private Sub Form_Load()
Text1 = 0.00001
Text4 = 2
Text5 = 4
Rem "данные, которые будут задаваться по умолчанию"
End Sub

Private Sub Exitmnu_Click()
End ' завершаем работу программы (через меню программы)
End Sub

Private Sub Scetmun_Click()
Command1_Click ' вычисляем..........
End Sub
Private Sub ClearCmd_Click()
Picture1.Cls
Text2.Text = ""
Text3.Text = ""
Rem "чистим окно программы от рассчётов"
End Sub

Private Sub Command1_Click()
Dim t As Double  '"шаг предварительной табуляции"
Dim bind As Boolean
Dim sf As String
On Error GoTo HandlerError
ymin = 2147483647: ymax = BadZnac
Rem "очистка элементов управления"
Text2 = "": Text3 = "": Picture1.Cls
tocn = 0
Rem "проверка корректности исходных данных пользователя"
If CheckData = False Then
 MsgBox Prompt:="Некорректны исходные данные", Title:="Решение уравнения"
 Exit Sub
End If
Result = FindZnX(xn, xk)
Rem "вызов процедуры построения графика с автомасштабированием"
Call Grafik(xn, xk)
HandlerError:
If Err <> 0 Then
 Err.Clear
End If
End Sub
Private Sub CmdSaveBitmap_Click()
  Dim s1 As String
  On Error GoTo HandlerError
  
  s1 = InputBox("Введите полное имя файла для сохранения рисунка", App.Title, App.Path + "\График.bmp")
  Rem "Задаём директорию записи рисунка графика функции"
  If s1 = "" Then Exit Sub
    
    SavePicture Picture1.Image, s1
  Exit Sub
HandlerError:
  MsgBox "Ошибка при сохранении графика" + vbLf + Err.Description, vbExclamation, App.Title
  Rem "Ошибка возникла по причине неправильной директории сохранения"
  Err.Clear
End Sub

Private Sub CmdSaveText_Click()
  Dim s1 As String
  On Error GoTo HandlerError
  
  s1 = InputBox("Введите полное имя файла для сохранения решения", App.Title, App.Path + "\Решение.txt")
  Rem "Задаём директорию записи отсчёта по решению уравнения"
  If s1 = "" Then Exit Sub
  Open s1 For Output As #1
  Print #1, Text2
  Close #1
  Exit Sub
HandlerError:
  MsgBox "Ошибка при сохранении отчета" + vbLf + Err.Description, vbExclamation, App.Title
  Rem "Ошибка могла возникнуть из-за неправильной директории сохранения"
  Err.Clear
End Sub


Private Function CheckData() As Boolean
Dim xtmp As Double
On Error GoTo HandlerError
Rem "точность вычисления"
If Text1 = "" Then Exit Function
tocn = CDbl(Text1.Text)
If tocn < MinToc Or tocn > MaxToc Then Exit Function
Rem "крайняя левая точка"
If Text4 = "" Then Exit Function
xn = CDbl(Text4.Text)
If xn < MinX Or xn > MaxX Then Exit Function
Rem "крайняя правая точка"
If Text5 = "" Then Exit Function
xk = CDbl(Text5.Text)
If xk < MinX Or xk > MaxX Then Exit Function
If xk < xn Then
 xtmp = xk: xk = xn: xn = xtmp: Text4 = xn: Text5 = xk
End If
If Abs(xk - xn) < MinInterval Then Exit Function
CheckData = True
HandlerError:
If Err <> 0 Then
 Err.Clear
 CheckData = False
End If
End Function

Private Function FindZnX(xnn As Double, xkk As Double) As Double
Dim j As Long
Dim x0 As Double, x1 As Double, i As Long
On Error GoTo HandlerError
Rem "процедура выполняет поиск корня и вывод результатов на экран"
Text2.Text = Text2.Text _
& "Вычисление корня уравнения 3*x-4*log( x) -5 " & vbCrLf
Rem "реализация метода"
x1 = xkk: x0 = 1  '"отсюда мы входим в цикл"
i = 0
Do While Abs(x1 - x0) >= tocn
 i = i + 1
 x0 = x1
 x1 = XYF_X(x0)
 Text2.Text = Text2.Text & CStr(i) & " приближение корня X" _
 & " = " & Format(x1, "0.000 000 000") & vbCrLf
 If i > MaxIterac Then Exit Do  '"чтобы не было зацикливания"
Loop
Rem "конец реализации"
Text2.Text = Text2.Text & " Итоговое значение корня X" _
& " = " & Format(x1, "0.000 000 000") & vbCrLf
If Text3 = "" Then
 Text3 = i
Else
 Text3 = CStr(CLng(Text3.Text) + i)
End If
FindZnX = x1
HandlerError:
If Err <> 0 Then
 Err.Clear
End If
End Function

Private Function YF_X(argx As Double) As Double
Rem "функция вычисляет Y = F(X)"
On Error GoTo HandlerError
YF_X = 3 * argx - 4 * Log(argx) - 5
HandlerError:
If Err <> 0 Then
 Err.Clear
 YF_X = BadZnac
End If
End Function

Private Function XYF_X(argx As Double) As Double
On Error GoTo HandlerError
XYF_X = -3 * argx + 4 * Log(argx) + 5
HandlerError:
If Err <> 0 Then
 Err.Clear
 XYF_X = BadZnac
End If
End Function


Private Sub Grafik(xmn As Double, xmx As Double)
Dim xmin As Double, xmax As Double
Dim tmpx As Double
Dim xcnt As Double, ycnt As Double      '"центр осей координат"
Dim grpole As Double, vrpole As Double  '"гор. и вер поля."
Dim dzsx As Double, dzsy As Double      '"длины засечек на осях X и Y"
Rem "для шага засечек по осям X и Y"
Dim shagzx As Double
Dim shagzy As Double
Dim idbl As Double

Dim i As Integer
Dim t As Double  '"шаг построения"
Dim x0 As Single, y0 As Single, x1 As Single, y1 As Single
Dim ta As Double
On Error GoTo HandlerError
Picture1.Cls
Rem "приведем в порядок аргументы"
xmin = xmn: xmax = xmx
If xmax < xmin Then
 tmpx = xmax: xmax = xmin: xmin = tmpx: tmpx = 0
End If
Picture1.ScaleWidth = 6: grpole = 0.5: shagzx = 1
xcnt = 0.5
Picture1.ScaleHeight = 4.8: vrpole = 0.4: shagzy = 1
ycnt = Picture1.ScaleHeight / 2
Rem "рисуем вертикальную координатную ось"
Picture1.Line (xcnt, 0)-(xcnt, Picture1.ScaleHeight)
Rem "рисуем горизонтальную координатную ось"
Picture1.Line (0, ycnt)-(Picture1.ScaleWidth, ycnt)
Rem "установка длины засечек на осях координат X и Y"
dzsx = Picture1.ScaleHeight * 0.015
dzsy = Picture1.ScaleWidth * 0.015
Rem "рисуем засечки на горизонтальной оси и подписи..."
i = 0
For idbl = xcnt + shagzx To 0.95 * Picture1.ScaleWidth Step shagzx
 i = i + 1
 Picture1.Line (idbl, ycnt)-(idbl, ycnt - dzsx)
 Picture1.CurrentX = idbl - dzsy: Picture1.CurrentY = ycnt + dzsx / 2
 Picture1.Print i
Next idbl
Picture1.CurrentX = Picture1.ScaleWidth * 0.97
Picture1.CurrentY = ycnt - dzsx * 2
Picture1.Print "X" 'пометим ось X
i = 0
Rem "рисуем засечки на вертикальной оси и подписи..."
i = 3
For idbl = vrpole To 0.95 * Picture1.ScaleHeight Step shagzy
 i = i - 1
 If i <> 0 Then
  Picture1.Line (xcnt, idbl)-(xcnt + dzsy, idbl)
  Picture1.CurrentX = xcnt + 0.02 * Picture1.ScaleWidth
  Picture1.CurrentY = idbl - dzsx
  Picture1.Print i
 End If
Next idbl
Picture1.CurrentX = Picture1.ScaleWidth * 0.11
Picture1.CurrentY = Picture1.ScaleHeight * 0.01
Picture1.Print "Y" 'пометим ось Y
Picture1.CurrentX = 0.25 * Picture1.ScaleWidth
Picture1.CurrentY = 0.005 * Picture1.ScaleHeight
Picture1.Print "График функции  3x-4ln x -5 =0; [" & xmin & ".." & xmax & "]"
Picture1.ForeColor = QBColor(13) ' цвет графика функции
t = (xmax - xmin) / ntt
ta = xmin
x0 = xcnt + xmin
y0 = ycnt - YF_X(ta)
For idbl = xmin + t To xmax Step t
 ta = ta + t
 x1 = x0 + t
 y1 = ycnt - YF_X(ta)
 Picture1.Line (x0, y0)-(x1, y1)
 x0 = x1: y0 = y1
Next idbl
Picture1.ForeColor = QBColor(0)
HandlerError:
If Err <> 0 Then
 Err.Clear
End If
End Sub

Private Sub svpmnu_Click()
  CmdSaveBitmap_Click ' сохраняем график функции через меню программы
End Sub

Private Sub Svsmnu_Click()
  CmdSaveText_Click ' сохраняем отсчёт через меню программы
End Sub