1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
| Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim xn As Double, xk As Double
Dim tocn As Double
Private Const MaxIterac As Long = 200
Private Const resfile As String = "Result.txt"
Private Const Bmpfile As String = "Bitmap.bmp"
Dim mitr() As Double
Dim idmitr As Boolean
Dim Result As Double
Private Sub Form_Load()
Text1 = 0.001
Text4 = 1
Text5 = 3
End Sub
Rem "кнопки"
Private Sub CmdScet_Click()
Reshenie
End Sub
Private Sub Picture1_Click()
End Sub
Private Sub SaveBitmap_Click()
SaveGrafik
End Sub
Private Sub SaveResult_Click()
SaveResultat
End Sub
Private Sub CmdClear_Click()
ClearForm
End Sub
Rem "меню"
Private Sub MnuScet_Click()
Reshenie
End Sub
Private Sub MnuSave_Click()
SaveResultat
End Sub
Private Sub MnuBitmap_Click()
SaveGrafik
End Sub
Private Sub MnuClear_Click()
ClearForm
End Sub
Private Sub MnuExit_Click()
Unload Me
End Sub
Private Sub MnuAbout_Click()
Form2.Show vbModal, Me
End Sub
Private Sub Reshenie()
Dim xpl As Double
Dim yn As Double, yk As Double
Dim x As Double, j As Long
On Error GoTo HandlerError
ClearForm
Erase mitr: idmitr = False: Result = -1
If Proverka = False Then Exit Sub
Text2.Text = Text2.Text _
& "Решение уравнения sin(lnx)-cos(lnx)+2lnx=0" & vbCrLf _
& "методом половинного деления" & vbCrLf _
& "Задан интервал " & xn & ".." & xk & vbCrLf
xpl = (xn + xk) / 2: x = 1: j = 0
yn = 10 * tocn: yk = 10 * tocn
Do While (Abs(yn) > tocn) And (Abs(yk) > tocn)
j = j + 1
If j > MaxIterac Then
ShowGrafik
Exit Sub
End If
yn = Sin(Log(xn)) - Cos(Log(xn)) + 2 * Log(xn)
yk = Sin(Log(xpl)) - Cos(Log(xpl)) + 2 * Log(xpl)
Rem "визуализация вычислений"
If Abs(yn) < Abs(yk) Then
x = xn
Else
x = xpl
End If
Text2.Text = Text2.Text & CStr(j) & " приближение корня X = " _
& Format(x, "0.00000000") & vbCrLf
Text3 = j
Select Case idmitr
Case False
ReDim mitr(0): idmitr = True
Case True
ReDim Preserve mitr(UBound(mitr) + 1)
End Select
mitr(UBound(mitr)) = x
If Abs(yn) <= tocn Or Abs(yk) <= tocn Then Exit Do
If (yn * yk) < 0 Then
xk = xpl: xpl = (xn + xk) / 2
Else
xn = xpl: xpl = (xn + xk) / 2
End If
Loop
If Abs(yn) < Abs(yk) Then
x = xn
Else
x = xpl
End If
Result = x
Text2.Text = Text2.Text & " Итоговое значение корня X = " _
& Format(x, "0.00000000") & vbCrLf
Text3 = j
ShowGrafik
HandlerError:
If Err <> 0 Then Err.Clear
End Sub
Private Sub SaveResultat()
Dim sf As String
On Error GoTo HandlerError
sf = InputBox(Prompt:="Введите имя файла", Title:="Сохранение результата", _
Default:=App.Path & "" & resfile)
Open sf For Output As #1
Print #1, Text2.Text;
Close #1
HandlerError:
If Err <> 0 Then
Err.Clear
End If
End Sub
Private Sub ClearForm()
Text2 = "": Picture1.Cls
End Sub
Private Sub SaveGrafik()
Dim sf As String
On Error GoTo HandlerError
sf = InputBox(Prompt:="Введите имя файла", Title:="Сохранение результата", _
Default:=App.Path & "" & Bmpfile)
SavePicture Picture1.Image, sf
HandlerError:
If Err <> 0 Then
Err.Clear
End If
End Sub
Private Sub ShowGrafik()
Dim i As Double
Dim t As Double '"шаг построения"
Dim ta As Double '"текущий аргумент"
Dim x0 As Single, y0 As Single, x1 As Single, y1 As Single
Dim xcnt As Double, ycnt As Double, vpole As Double, gpole As Double
Dim shag As Double
Dim dzsy As Double, dzsx As Double
Dim xnn As Double, xkk As Double
Dim k As Long
On Error GoTo HandlerError
Picture1.Cls
Rem "масштаб"
Picture1.ScaleWidth = 4.8
Picture1.ScaleHeight = 9.6
dzsy = Picture1.ScaleHeight * 0.01
dzsx = Picture1.ScaleWidth * 0.01
vpole = 0.8: gpole = 0.4: shag = 1
xcnt = 0.4: ycnt = 6.8
Rem "линии осей координат"
Picture1.Line (0, ycnt)-(Picture1.ScaleWidth, ycnt)
Picture1.Line (xcnt, 0)-(xcnt, Picture1.ScaleHeight)
Rem "метки на осях"
For i = gpole + shag To Picture1.ScaleWidth - 0.9 * gpole Step shag
Picture1.Line (i, ycnt)-(i, ycnt - dzsy)
Picture1.CurrentX = i - dzsx: Picture1.CurrentY = ycnt + dzsy
Picture1.Print i - gpole
Next i
Picture1.CurrentX = Picture1.ScaleWidth * 0.96
Picture1.CurrentY = ycnt - Picture1.ScaleHeight * 0.03
Picture1.Print "X"
For i = vpole To Picture1.ScaleHeight - 0.9 * vpole Step shag
If Abs(i - ycnt) > 0.1 Then
Picture1.Line (xcnt, i)-(xcnt + dzsx, i)
Picture1.CurrentX = xcnt + dzsx
Picture1.CurrentY = i - 0.01 * Picture1.ScaleHeight
Picture1.Print 6 - i + vpole
End If
Next i
Picture1.CurrentX = xcnt + dzsx
Picture1.CurrentY = 0.01 * Picture1.ScaleHeight
Picture1.Print "Y"
Picture1.DrawWidth = 1.5
Picture1.ForeColor = QBColor(12)
xnn = CDbl(Text4): xkk = CDbl(Text5)
t = 0.01: x0 = xcnt + xnn: ta = xnn
y0 = ycnt - (Sin(Log(ta)) - Cos(Log(ta)) + 2 * Log(ta))
Do While ta <= xkk
x1 = x0 + t: ta = ta + t
If ta > xkk Then Exit Do
y1 = ycnt - (Sin(Log(ta)) - Cos(Log(ta)) + 2 * Log(ta))
Picture1.Line (x0, y0)-(x1, y1)
x0 = x1: y0 = y1
Loop
Picture1.DrawWidth = 1
Picture1.ForeColor = QBColor(0)
Picture1.CurrentX = 0.6
Picture1.CurrentY = 0.01 * Picture1.ScaleHeight
Picture1.Print "График функции sin(lnx)-cos(lnx)+2lnx=0;"
Picture1.CurrentX = 0.6
Picture1.Print "[" & xnn & ".." & xkk & "]"
Rem "рисование приближений"
Picture1.ForeColor = QBColor(9)
y0 = ycnt: y1 = ycnt - dzsx * 6
For k = LBound(mitr) To UBound(mitr)
If Not (xn > 1.8) Then
DoEvents
Sleep 1000
End If
x0 = xcnt + mitr(k): x1 = x0
Picture1.Line (x0, y0)-(x1, y1)
Text2.Text = Text2.Text & CStr(k + 1) & " приближение корня X = " _
& Format(mitr(k), "0.00000000") & vbCrLf
Text3 = k + 1
Next k
y0 = ycnt: y1 = ycnt - dzsx * 10
x0 = xcnt + Result: x1 = x0
Picture1.Line (x0, y0)-(x1, y1)
Picture1.CurrentX = x0 - 0.03 * Picture1.ScaleWidth
Picture1.CurrentY = ycnt - 0.08 * Picture1.ScaleHeight
Picture1.Print Format(Result, "0.000")
Text2.Text = Text2.Text & " Итоговое значение корня X = " _
& Format(Result, "0.00000000") & vbCrLf
Rem "конец рисования приближений"
HandlerError:
If Err <> 0 Then
Err.Clear
End If
End Sub
Private Function Proverka() As Boolean
Dim tmp As Double
On Error GoTo HandlerError
xn = CDbl(Text4)
If xn < 0 Or xn = 0 Then
Text2.Text = Text2.Text _
& " Ошибка!!!Аргумент логарифмической " & vbCrLf _
& " функции должен быть положительным" & vbCrLf
Exit Function
End If
xk = CDbl(Text5)
If xk < 0 Or xk = 0 Then
Text2.Text = Text2.Text _
& " Ошибка!!!Аргумент логарифмической " & vbCrLf _
& " функции должен быть положительным" & vbCrLf
Exit Function
End If
If Abs(xk - xn) < 0.5 Then
Text2.Text = Text2.Text _
& " Интервал слишком мал," & vbCrLf _
& "рекомендую принять (xk-xn)>0.5" & vbCrLf
Exit Function
End If
If xk < xn Then
tmp = xk: xk = xn: xn = tmp
Text4 = xn: Text5 = xk
End If
tocn = CDbl(Text1.Text)
If tocn > 0.1 Or tocn < 0.00000001 Then
MsgBox Prompt:="Точность дб 0,00000001..0,1", Title:="Проверка данных"
Exit Function
End If
Proverka = True
HandlerError:
If Err <> 0 Then
Err.Clear
Text2.Text = Text2.Text _
& " Интервал слишком мал," & vbCrLf _
& "рекомендую принять (xk-xn)>0.5" & vbCrLf
End If
End Function |
(
