Разработка программы расчета структурной надежности методом
статического моделирования 2.3.1 Разработка расчетной части программы расчета структурной надежности сети Option Explicit Dim A (200, 200) As Single, p As Integer Public maxNnoi As Single, flgstopuser As Boolean
Private Sub firstStepp (A( ) As Single, x( ) As Single) Dim n As Integer Dim i As Integer Dim j As Integer n = 1 For i = 1 To ((FrmSSN.kolvouzlov) - 1) '4 For j = i + 1 To (FrmSSN.kolvouzlov) '5 If A (i, j) > 0 Then If x (n) < A (i, j) Then A (i, j) = 1 Else A (i, j) = 0 End If n = n + 1 End If A (j, i) = A (i, j) Next j Next i End Sub Private Sub VektStrok (Nnew, Imeny As Integer, S( ) As Integer, A( ) As Single) Dim k As Integer Dim j As Integer For k = 1 To (FrmSSN.kolvouzlov) If S (k) > 0 Then For j = 1 To (FrmSSN.kolvouzlov) A (Imeny, j) = A (Imeny, j) + A (k, j) If A (Imeny, j) > 1 Then A (Imeny, j) = 1 End If Next j End If Next k Nnew = 0 End Sub Private Sub SvjazNet (Imeny As Integer, A( ) As Single, p As Integer) Dim j As Integer p = 1 For j = 1 To (FrmSSN.kolvouzlov) If A (Imeny, j) = 0 Then p = 0 Exit Sub End If Next j End Sub Private Sub FinishAnswer (A( ) As Single, PlasResult As Integer, Imeny As Integer, p _ As Integer, S() As Integer, Nnew As Integer) Dim j As Integer Dim Pm (1 To 6) As Integer Dim Nbg As Integer, nUlvekt As Integer If p <> 0 Then PlasResult = PlasResult + 1 Exit Sub End If Nbg = 0 Nnew = 0 nUlvekt = 0 For j = 1 To (FrmSSN.kolvouzlov) If A (Imeny, j) = 1 Then Pm (j) = j Else: nUlvekt = nUlvekt + 1 End If Next j If nUlvekt = (FrmSSN.kolvouzlov) Then Exit Sub End If For j = 1 To (FrmSSN.kolvouzlov) If Pm (j) <> S (j) Then S (j) = Pm (j) Nnew = Nnew + 1 End If Next j End Sub Private Sub FormirNLmassWork ( ) Dim initm As Integer For initm = 1 To FrmSSN.kolvolin FrmSSN.numUZmu initm, FrmSSN.kolvouzlov, 2, na1, na2 A (na1, na2) = FrmSSN.UvmLN (initm) A (na2, na1) = A (na1, na2) Next initm End Sub Public Sub cmdrasch_workmod ( ) Dim i As Integer, j As Integer Dim PlasResult As Integer, e As Integer Dim x( ) As Single, C As Integer Dim Nnoi As Integer Dim PP As Currency, Imeny As Integer Dim S ( ) As Integer Dim Nnew As Integer Dim sngStartWork (1, 1 To 2) As Date Dim sngStartWorkSEC As Single, bar As Integer frmBrWk.PrgBarWSind.Min = 0: frmBrWk.PrgBarWSind.Max = 100 frmBrWk.PrgBarWSind.Visible = False frmBrWk.LblSwrE(1).Caption = 0 PlasResult = 0 ReDim Preserve x (FrmSSN.kolvolin) ReDim Preserve S (FrmSSN.kolvouzlov) Randomize For Nnoi = 1 To maxNnoi DoEvents If MdlWorkSpase.flgstopuser = True Then Exit For If Nnoi = 1 Then sngStartWork(1, 1) = Now sngStartWorkSEC = Timer frmBrWk.LblSwrE(1).Caption = sngStartWork(1, 1) End If For e = 1 To FrmSSN.kolvolin x (e) = Rnd Next e firstStepp A, x'1 Imeny = (((FrmSSN.kolvouzlov) - 1) * Rnd) + 1 S (Imeny) = Imeny For j = 1 To FrmSSN.kolvouzlov If A (Imeny, j) = 1 Then S (j) = j End If Next j VektStr: VektStrok Nnew, Imeny, S, A'2 SvjazNet Imeny, A, p'3 FinishAnswer A, PlasResult, Imeny, p, S, Nnew'4 If Nnew <> 0 Then GoTo VektStr End If For i = 1 To FrmSSN.kolvouzlov S (i) = 0 For j = 1 To FrmSSN.kolvouzlov A (i, j) = 0 Next j Next i bar = Nnoi frmBrWk.PrgBarWSind.Value = ((bar / maxNnoi) * 100) frmBrWk.PrgBarWSind.Visible = True Next Nnoi If MdlWorkSpase.flgstopuser = True Then Exit Sub PP = (PlasResult / maxNnoi) sngStartWorkSEC = (Timer - sngStartWorkSEC) sngStartWork (1, 2) = Now: frmBrWk.LblSwrE(0).Caption = sngStartWork(1, 2) UserFormVorkClosed sngStartWorkSEC, maxNnoi, PP, sngStartWork End Sub Private Sub UserFormVorkClosed (sngStartWorkSEC, maxNnoi, PP, sngStartWork) Dim work As Integer, TimeWork As String Dim bufchench1 As Date, bufchench2 As Currency If sngStartWork (1, 1) <> sngStartWork (1, 2) Then If (sngStartWork (1, 2) - sngStartWork (1, 1)) > sngStartWorkSEC _ And (sngStartWork (1, 2) - sngStartWork (1, 1)) < 1 Then GoTo 12 bufchench1 = (sngStartWork(1, 2) - sngStartWork(1, 1)) TimeWork = Str(bufchench1) Else 12: bufchench2 = sngStartWorkSEC TimeWork = Str (0) & Str (bufchench2) & " секунды" End If work = MsgBox("Расчет структурной надежности закончен !" & vbCrLf & Chr$(13) & "Число испытаний : " & maxNnoi & vbCrLf & "Вероятность связности : " & PP & vbCrLf & "Расчет длился около : " & TimeWork, vbInformation + vbOKOnly, " ") sngStartWork(1, 1) = 0: sngStartWork(1, 2) = 0 sngStartWorkSEC = 0: frmBrWk.PrgBarWSind.Value = 0 Unload frmBrWk End Sub
2.3.2 Разработка интерфейсной части программы расчета структурной надежности сети Интерфейсная часть программы состоит из четырех частей, а именно: · первая, основная часть, располагается в файле формы основного окна “ FrmSSN ”; · следующая часть располагается в файле формы окна расчета структурной надежности “ frmBrWk ”; · третья часть программы находится в файле формы окна конфигурирования координатной сетки “ FrmPrWeb ”; · четвертая, последняя, часть программы – в файле формы окна ввода числовой характеристики выбранной линии “ FrmNwORsZ ”. Приведем листинги данных частей, интерфейсной части программы расчета структурной надежности сети, в этом же порядке.
Первая часть
Option Explicit Public kolvouzlov As Integer, needFRsave As Boolean Public kolvolin As Integer Dim znak As Boolean, zamok As Boolean Dim x1 As Integer, y1 As Integer Dim x2 As Integer, y2 As Integer Dim MasKoLuZv(1 To 200, 1 To 5) As Single Dim keeCH As Boolean Dim deletealluz As Boolean, deletealllinsv As Boolean Dim keeAB As Boolean, testimonial As Boolean Dim testNyn As Boolean, change As Boolean Dim mlinesSV(1 To 400, 1 To 10) As Single, SFALNAME As String Const myORno As String = "sns" Dim zapros As Boolean Public poweb As Boolean Public shwebx As Single, shweby As Single Public bJampWeb As Boolean Private Sub svayzy (x1, x2, y1, y2, iduzla, Index, mlinesSV, kolvolin) Dim i As Integer, j As Integer On Error GoTo metSVx If deletealllinsv = True And kolvolin > 0 Then FrmSSN.Enabled = False FrmSSN.MousePointer = 3 For i = 1 To kolvolin For j = 1 To 10 mlinesSV(i, j) = 0 Next j: Next i kolvolin = 0 Else For i = 1 To kolvolin If mlinesSV(i, 1) = 0 Then mlinesSV(i, 1) = iduzla: mlinesSV(i, 2) = Index mlinesSV(i, 3) = x1: mlinesSV(i, 4) = y1 mlinesSV(i, 5) = x2: mlinesSV(i, 6) = y2 mlinesSV(i, 7) = 0 mlinesSV(i, 8) = 0: mlinesSV(i, 9) = 0 '-номера вершин (новые) mlinesSV(i, 10) = 0 '-вес линии Exit Sub End If Next i End If FrmSSN.Enabled = True FrmSSN.MousePointer = 0 brcoutSVX: Exit Sub metSVx: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutSVX End Sub Private Sub LinColorsv (NuMl As Integer, LcolorS, mlinesSV) On Error GoTo HTYH Select Case mlinesSV(NuMl, 7) Case Is = 0 LcolorS = vbBlue Case Is = 1 LcolorS = vbRed Case Is = 2 LcolorS = RGB(210, 0, 210) End Select HTYH: End Sub Private Sub CmdBk_Click ( ) Dim nnoN As Integer
CmdWORKsch.Enabled = False Cmd1.Visible = True Cmd2.Visible = True keeAB = False For nnoN = 1 To kolvouzlov nnOuzN((MasKoLuZv(nnoN, 1))).Enabled = False Next nnoN CmdFwd.Enabled = False CmdBk.Enabled = False Frame1.Enabled = True Frame1.Caption = ("План сети") End Sub Private Sub CmdFwd_Click ( ) CmdFwd.Enabled = False CmdBk.Enabled = True If keeAB = False Then Frame1.Caption = ("Параметры") Cmd1.Visible = False Cmd2.Visible = False keeAB = True If change = True Or change = False Then TestNet testNyn End Sub Private Sub TestNet (testNyn) '-проверка связанных узлов Dim tuZnSvYnOk As Integer, nuzysy As Integer On Error GoTo metTNx If change = False And kolvouzlov = 0 Then GoTo 101 For tuZnSvYnOk = 1 To kolvouzlov If MasKoLuZv(tuZnSvYnOk, 1) > 0 And MasKoLuZv(tuZnSvYnOk, 4) >= 1 Then nuzysy = nuzysy + 1 End If Next tuZnSvYnOk If nuzysy = kolvouzlov And nuzysy > 1 Then testNyn = True For tuZnSvYnOk = 1 To kolvouzlov If MasKoLuZv(tuZnSvYnOk, 1) > 0 Then nnOuzN(MasKoLuZv(tuZnSvYnOk, 1)).Move (MasKoLuZv(tuZnSvYnOk, 2) – _ (nnOuzN(MasKoLuZv(tuZnSvYnOk, 1)).Width / 2)), (MasKoLuZv(tuZnSvYnOk, 3) – – (nnOuzN(MasKoLuZv(tuZnSvYnOk, 1)).Height / 2)) nnOuzN(MasKoLuZv(tuZnSvYnOk, 1)).Visible = True: nnOuzN(MasKoLuZv(tuZnSvYnOk, 1)).Enabled = True End If Next tuZnSvYnOk change = False Else 101: nuzysy = 0 nuzysy = MsgBox(" ВЫ допустили ошибку. Данная сеть НЕ связна !!! " _ & vbCrLf & vbCr & " Это не позволит вам ввести характеристики сети" _ & vbCrLf & " Для исправления ошибки нажмите : << Назад >>" _ , vbCritical + vbOKOnly, " Проверка связности сети ") Frame1.Enabled = False CmdFwd.Enabled = False End If brcoutTN: Exit Sub metTNx: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutTN End Sub Private Sub CmdWEB_Click ( ) Dim Wsetki As Single, Hsetki As Single Dim i As Integer, j As Integer Dim shag As Boolean, LcolorS As Double Const webxy As Single = 201 On Error GoTo metWEBx If poweb = False Then shwebx = webxy shweby = shwebx End If If bJampWeb = True And keeCH = True Then shag = True: GoTo 7 ElseIf bJampWeb = True And keeCH = False Then shag = False: GoTo 7 End If If keeCH = False Then 8: Picture1.DrawStyle = 2 For Wsetki = (shwebx) To (Picture1.Width) Step (shwebx) Picture1.Line ((Wsetki), 1)-((Wsetki), (Picture1.Height - 1)) Next Wsetki For Hsetki = (shweby) To (Picture1.Height) Step (shweby) Picture1.Line (1, Hsetki)-((Picture1.Width - 1), Hsetki) Next Hsetki keeCH = True Else '*перерисовка линий S-T* 7: Picture1.DrawStyle = 6 Picture1.Cls For i = 1 To kolvolin If mlinesSV(i, 1) <> 0 Then LinColorsv i, LcolorS, mlinesSV '- определение цвета линии Picture1.Line ((mlinesSV(i, 3)), (mlinesSV(i, 4)))-((mlinesSV(i, 5)), _ (mlinesSV(i, 6))), LcolorS End If '*перерисовка линий E-D* Next i If shag = True Then GoTo 8 keeCH = False End If Picture1.DrawStyle = 6 brcoutWEB: Exit Sub metWEBx: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutWEB End Sub Private Sub Cmd1_Click ( ) '-уменьшение узла Dim ti As Integer, tip As Integer On Error GoTo metGGG If Optuzel.Value = False Then Exit Sub: Picture1.AutoRedraw = False: Picture1.Enabled = False For ti = Pct1.lBound To kolvouzlov If (Pct1(0).Width) > 402 Then '-мин размер для индекса=400 If ti > 0 Then tip = MasKoLuZv(ti, 1) Else tip = ti
Pct1(tip).Visible = False Pct1(tip).Width = (Pct1(0).Width - 20)
Pct1(tip).Height = (Pct1(0).Height - 20) If ti <> 0 Then Pct1(tip).Left = (Pct1(tip).Left + 10) Pct1(tip).Top = (Pct1(tip).Top + 10) Pct1(tip).Visible = True End If End If Next ti Picture1.AutoRedraw = True: Picture1.Enabled = True brcoutGGG: Exit Sub metGGG: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutGGG End Sub Private Sub Cmd2_Click ( ) '-увеличение узла Dim i As Integer, pip As Integer On Error GoTo metTYP If Optuzel.Value = False Then Exit Sub: Picture1.AutoRedraw = False: Picture1.Enabled = False For i = 0 To kolvouzlov If (Pct1(0).Width) < 700 Then If i > 0 Then pip = MasKoLuZv(i, 1) Else pip = i
Pct1(pip).Visible = False Pct1(pip).Width = (Pct1(0).Width + 20) Pct1(pip).Height = (Pct1(0).Height + 20) If i <> 0 Then Pct1(pip).Left = (Pct1(pip).Left - 10) Pct1(pip).Top = (Pct1(pip).Top - 10) Pct1(pip).Visible = True End If End If Next i Picture1.AutoRedraw = True: Picture1.Enabled = True brcoutTYP: Exit Sub metTYP: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutTYP End Sub Private Sub CmdWORKsch_Click ( ) Dim parallyn As Integer, zn As Integer Dim zun As Integer Dim ikf As Integer On Error GoTo metBRsy If testimonial = True Then zn = 0 For parallyn = 1 To kolvolin If mlinesSV(parallyn, 10) > 0 And mlinesSV(parallyn, 8) > 0 _ And mlinesSV(parallyn, 9) = 0 Then For ikf = 1 To kolvouzlov If MasKoLuZv(ikf, 1) > 0 And MasKoLuZv(ikf, 1) = mlinesSV(parallyn, 2) Then mlinesSV(parallyn, 9) = MasKoLuZv(ikf, 5) Exit For End If Next ikf ElseIf mlinesSV(parallyn, 10) > 0 And mlinesSV(parallyn, 8) = 0 _ And mlinesSV(parallyn, 9) > 0 Then For ikf = 1 To kolvouzlov If MasKoLuZv(ikf, 1) > 0 And MasKoLuZv(ikf, 1) = mlinesSV(parallyn, 1) Then mlinesSV(parallyn, 8) = MasKoLuZv(ikf, 5) Exit For End If Next ikf ElseIf mlinesSV(parallyn, 10) > 0 And mlinesSV(parallyn, 8) = 0 _ And mlinesSV(parallyn, 9) = 0 Then For ikf = 1 To kolvouzlov If MasKoLuZv(ikf, 1) > 0 And MasKoLuZv(ikf, 1) = mlinesSV(parallyn, 1) Then mlinesSV(parallyn, 8) = MasKoLuZv(ikf, 5) ElseIf MasKoLuZv(ikf, 1) > 0 And MasKoLuZv(ikf, 1) = mlinesSV(parallyn, 2) Then mlinesSV(parallyn, 9) = MasKoLuZv(ikf, 5) End If Next ikf End If If mlinesSV(parallyn, 8) > 0 And mlinesSV(parallyn, 9) > 0 _ And mlinesSV(parallyn, 10) > 0 Then zn = zn + 1 Next parallyn zun = 0 For parallyn = 1 To kolvouzlov If MasKoLuZv(parallyn, 5) <> 0 Then zun = zun + 1 Next parallyn If zn = kolvolin And zun = kolvouzlov Then Load frmBrWk frmBrWk.Show vbModal Exit Sub Else 247: zn = MsgBox(" Вы ввели НЕ все параметры сети. " & vbCrLf & _ " Проверьте ! ВСЕ ЛИ узлы пронумерованы " & vbCrLf & _ " Для ВСЕХ ЛИ линий вы ввели характеристики ?", _ vbCritical + vbOKOnly, _ " Ошибка ввода числовых характеристик сети !") Exit Sub End If Else GoTo 247 End If brcoutZZ: Exit Sub metBRsy: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutZZ End Sub Private Sub Form_Load ( ) On Error GoTo metLFM FrmSSN.MousePointer = vbArrow Picture2.Visible = True keeCH = False bJampWeb = False deletealluz = False deletealllinsv = False CmdFwd.Enabled = False CmdBk.Enabled = False CmdWORKsch.Enabled = False keeAB = False testNyn = False change = False testimonial = False needFRsave = False zapros = False poweb = False
'&&& начальная установка подменю mnuClose.Enabled = False mnuSave.Enabled = False mnuSaveAs.Enabled = False mnuweb.Enabled = False mnuwebYN.Checked = False mnuWBconf.Enabled = False '&&& Picture1.Visible = False: Frame1.Visible = False Cmd1.Visible = False: Cmd2.Visible = False CmdWEB.Enabled = False brcoutLFM: Exit Sub metLFM: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutLFM End Sub Private Sub mnuClose_Click ( ) Dim emss As Integer On Error GoTo metClDf If needFRsave = True Then emss = MsgBox(" Вы хотите сохранить внесенные изменения ?",_ vbExclamation + vbYesNo, " Закрытие файла ") If emss = vbYes Then mnuSave_Click End If SFALNAME = "" Picture2.Visible = True: Picture1.Visible = False Frame1.Visible = False: Cmd1.Visible = False Cmd2.Visible = False: CmdWEB.Visible = False Opt1.Value = True: CmdWORKsch.Enabled = False zapros = False poweb = False mnuOpen.Enabled = True deletealluz = True: deletealllinsv = True Picture1.Cls: svayzy 0, 0, 0, 0, 0, 0, mlinesSV, kolvolin NeWorKorrkolUZ 0, kolvouzlov, 0, 0, 0 LblLN(1).Caption = 0 LbluZ(1).Caption = 0 mnuNew.Enabled = True mnuClose.Enabled = False mnuSave.Enabled = False mnuSaveAs.Enabled = False mnuweb.Enabled = False mnuwebYN.Checked = False keeAB = False testimonial = False needFRsave = False CmdFwd.Enabled = False CmdBk.Enabled = False brcoutDf: Exit Sub metClDf: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcoutDf
End Sub Private Sub mnuExit_Click ( ) Dim emss As Integer If needFRsave = True Then emss = MsgBox(" Вы хотите сохранить внесенные изменения ?", _ vbExclamation + vbYesNo, " Завершение работы с программой ") If emss = vbYes Then mnuSave_Click End If Unload FrmSSN Set FrmSSN = Nothing End Sub Private Sub mnuNew_Click ( ) On Error GoTo metOUTsbA Picture2.Visible = False: Picture1.Visible = True Frame1.Visible = True: Cmd1.Visible = True Cmd2.Visible = True: CmdWEB.Visible = True mnuOpen.Enabled = False mnuNew.Enabled = False mnuClose.Enabled = True mnuSave.Enabled = True mnuSaveAs.Enabled = True mnuweb.Enabled = True deletealluz = False deletealllinsv = False testimonial = False needFRsave = False brcoutA0: Exit Sub metOUTsbA: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", _ vbCritical, "Error" GoTo brcoutA0 End Sub Private Sub mnuOpen_Click ( ) Dim ORnost As String, msNMF As Integer Dim nF As Integer Dim BREDpt As Boolean On Error GoTo metERSSst BREDpt = False mnuNew.Enabled = False mnuweb.Enabled = True deletealluz = False deletealllinsv = False cldfilfunk.Flags = cdlOFNHideReadOnly cldfilfunk.ShowOpen SFALNAME = cldfilfunk.FileName ORnost = Right$(SFALNAME, 4) If Len(SFALNAME) = 0 Then 564:mnuNew.Enabled = True mnuweb.Enabled = False Exit Sub End If If myORno = Right$(SFALNAME, 3) And 46 = Asc(Mid(ORnost, 1, 1)) Then FCnetR BREDpt cldfilfunk.FileName = "" If BREDpt = True Then GoTo 564 netUPload Else msNMF = MsgBox("Данный файл НЕ является файлом приложения SSN", _ vbCritical + vbOKOnly, " Не верный формат файла ") cldfilfunk.FileName = " " mnuNew.Enabled = True mnuweb.Enabled = False Exit Sub End If brcout77: Exit Sub metERSSst: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", _ vbCritical, "Error" GoTo brcout77 End Sub Private Sub netUPload ( ) Dim w As Integer On Error GoTo metERSS03 For w = 1 To kolvouzlov Load nnOuzN(MasKoLuZv(w, 1)) Load Pct1(MasKoLuZv(w, 1)) Pct1(MasKoLuZv(w, 1)).Move MasKoLuZv(w, 2) – – Pct1(MasKoLuZv(w, 1)).Width / 2, _ MasKoLuZv(w, 3) – Pct1(MasKoLuZv(w, 1)).Height / 2 Pct1(MasKoLuZv(w, 1)).Visible = True If MasKoLuZv(w, 1) > 0 Then nnOuzN(MasKoLuZv(w, 1)).Move (MasKoLuZv(w, 2) – – (nnOuzN(MasKoLuZv(w, 1)).Width / 2)), _ (MasKoLuZv(w, 3) – (nnOuzN(MasKoLuZv(w, 1)).Height / 2)) nnOuzN(MasKoLuZv(w, 1)).Visible = True nnOuzN(MasKoLuZv(w, 1)).Enabled = True End If If testimonial = True And MasKoLuZv(w, 5) > 0 Then nnOuzN(MasKoLuZv(w, 1)).Text = MasKoLuZv(w, 5) nnOuzN(MasKoLuZv(w, 1)).BackColor = RGB(0, 250, 243) nnOuzN(MasKoLuZv(w, 1)).Locked = True End If Next w bJampWeb = True CmdWEB_Click bJampWeb = False Picture2.Visible = False: Picture1.Visible = True Frame1.Visible = True: Cmd1.Visible = True Cmd2.Visible = True: CmdWEB.Visible = True mnuClose.Enabled = True mnuSave.Enabled = True mnuSaveAs.Enabled = True mnuOpen.Enabled = False LbluZ(1).Caption = kolvouzlov LblLN(1).Caption = kolvolin If keeAB = True Then Cmd1.Visible = False Cmd2.Visible = False End If brcout3: Exit Sub metERSS03: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout3 End Sub Private Sub FcnetR (Bpt As Boolean) Dim st0 As String, j As Integer Dim nF As Integer, nwwd As Integer Dim clermgs As String, st1 As String Dim stx As String On Error GoTo kasjakmet nF = FreeFile st1 = "777*NSN!& – _ &!SEV_*_ftAC*&&&*015401680161013101470146013600163046014101740162 _ 0174099016801610168011209901700*777" Open SFALNAME For Input As #nF Input #nF, st0 If st0 <> st1 Then clermgs = "Данный файл НЕ является файлом приложения SSN" GoTo 22 End If Input #nF, stx keeAB = CBool(stx) Input #nF, stx testimonial = CBool(stx) Input #nF, stx kolvouzlov = CInt(stx) For nwwd = 1 To kolvouzlov For j = 1 To 5 Input #nF, MasKoLuZv(nwwd, j) 'stx Next j Next nwwd '-конец ввода массива узлов Input #nF, stx Input #nF, stx kolvolin = CInt(stx) For nwwd = 1 To kolvolin For j = 1 To 10 If j = 10 Then Input #nF, mlinesSV(nwwd, j) mlinesSV(nwwd, j) = mlinesSV(nwwd, j) / 1000 Else Input #nF, mlinesSV(nwwd, j) 'stx End If Next j Next nwwd '- конец ввода массива линий 23: Close #nF Exit Sub kasjakmet: Select Case Err Case Is = 76 clermgs = " Путь " & SFALNAME & " НЕ найден " Case Is = 62 GoTo 23 Case Else clermgs = "Данный файл НЕ является файлом приложения SSN" End Select 22: nwwd = MsgBox(clermgs, vbInformation + vbOKOnly, " Ошибка чтения файла") Bpt = True GoTo 23 End Sub Private Sub mnuSave_Click ( ) If SFALNAME <> "" And needFRsave = True And zapros = False Then cldfilfunk.Flags = cdlOFNOverwritePrompt FCnetM ElseIf needFRsave = True Then mnuSaveAs_Click End If End Sub Private Sub mnuSaveAs_Click ( ) cldfilfunk.Flags = cdlOFNOverwritePrompt cldfilfunk.ShowSave SFALNAME = cldfilfunk.FileName If Len(SFALNAME) = 0 Then Exit Sub myNfkorr End Sub Private Function CheckNames (name As String) As Boolean Dim Result As Boolean Result = True If (InStr(name, "\")) Then Result = False If (InStr(name, "/")) Then Result = False If (InStr(name, ":")) Then Result = False If (InStr(name, ";")) Then Result = False If (InStr(name, "*")) Then Result = False If (InStr(name, """")) Then Result = False If (InStr(name, "?")) Then Result = False If (InStr(name, ">")) Then Result = False If (InStr(name, "<")) Then Result = False If (InStr(name, "|")) Then Result = False If (InStr(name, ",")) Then Result = False CheckNames = Result End Function Private Sub myNfkorr ( ) Dim chstras As String, snumpoint As Integer Dim rrr As String On Error GoTo 898 rrr = cldfilfunk.FileTitle If CheckNames(rrr) = False Or Len(rrr) = 0 Then 11:MsgBox " Недопустимое имя файла " zapros = True cldfilfunk.FileName = "" Exit Sub ElseIf 46 = Asc(Mid(rrr, 1, 1)) Then GoTo 11 End If chstras = Right$(SFALNAME, 4) If myORno <> Right$(SFALNAME, 3) And 46 = Asc(Mid(chstras, 1, 1)) Then Mid(SFALNAME, (Len(SFALNAME) - 2), 3) = myORno ElseIf myORno <> Right$(SFALNAME, 3) And 46 <> Asc(Mid(chstras, 1, 1)) Then If InStr(1, SFALNAME, ".") <> 0 Then SFALNAME = Left$(SFALNAME, (InStr(1, SFALNAME, ".") - 1)) SFALNAME = SFALNAME & ".sns" Else SFALNAME = SFALNAME & ".sns" End If End If FCnetM brcout: Exit Sub 898: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout End Sub Private Sub FcnetM ( ) Dim st0 As String, j As Integer Dim nF As Integer, nwwd As Integer Dim clermgs As String
On Error GoTo kasjakmet nF = FreeFile st0 = "777*NSN!& – _ &!SEV_*_ftAC*&&&*015401680161013101470146013600163046014101740162 _ 0174099016801610168011209901700*777" FrmSSN.Enabled = False FrmSSN.MousePointer = 11 Open SFALNAME For Output As #nF Write #nF, st0 Write #nF, CStr(keeAB) Write #nF, CStr(testimonial) Print #nF, CStr(kolvouzlov), For nwwd = 1 To kolvouzlov If MasKoLuZv(nwwd, 1) > 0 Then Write #nF, For j = 1 To 5 Print #nF, MasKoLuZv(nwwd, j), Next j End If Next nwwd '-конец ввода массива узлов Write #nF, Write #nF, Print #nF, CStr(kolvolin), For nwwd = 1 To kolvolin If mlinesSV(nwwd, 1) > 0 Then Write #nF, For j = 1 To 10 If j = 10 Then Print #nF, (mlinesSV(nwwd, j) * 1000), Else Print #nF, mlinesSV(nwwd, j), End If Next j End If Next nwwd '- конец ввода массива линий Write #nF, needFRsave = False 23: Close #nF FrmSSN.Enabled = True FrmSSN.MousePointer = 0 Exit Sub kasjakmet: Select Case Err Case Is = 76 clermgs = " Путь " & SFALNAME & " НЕ найден " SFALNAME = "" Case Is = 62 GoTo 23 Case Is = 53 clermgs = " Требуемый файл был удален или перемещен " clermgs = clermgs & vbCrLf & " Используйте меню " & " Файл \ Сохранить как..." Case Else MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo 23 End Select nwwd = MsgBox(clermgs, vbInformation + vbOKOnly, _ " Ошибка сохранения файла") cldfilfunk.FileName = "" GoTo 23 End Sub Public Sub ZAPWEB ( ) If keeCH = False Then CmdWEB_Click Else CmdWEB_Click keeCH = False CmdWEB_Click End If End Sub Private Sub mnuWBconf_Click ( ) On Error GoTo 1111 Load FrmPrWeb FrmPrWeb.Show vbModal brt1: Exit Sub 1111: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brt1 End Sub Private Sub mnuwebYN_Click ( ) '-активизация/де активизация сетки Static webyes As Integer On Error GoTo metERSS01 webyes = webyes + 1 If webyes = 1 Then mnuwebYN.Checked = True: CmdWEB.Enabled = True mnuWBconf.Enabled = True Else webyes = 0 mnuwebYN.Checked = False: CmdWEB.Enabled = False mnuWBconf.Enabled = False End If brcout1: Exit Sub metERSS01: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout1 End Sub Private Sub nnOuzN_GotFocus (Index As Integer) nnOuzN(Index).SelStart = 0 nnOuzN(Index).SelLength = 3 End Sub Private Sub nnOuzN_KeyPress (Index As Integer, KeyAscii As Integer) Dim messege0 As Integer, zapMuzElin As Integer On Error GoTo metERSS1 If Optlinswyazi.Value = True Or Opt1.Value = True Then Exit Sub If KeyAscii = 13 Then If KeyAscii = 13 And nnOuzN(Index).Locked = True Then Exit Sub If Val(nnOuzN(Index).Text) = 0 Or Not IsNumeric(nnOuzN(Index)) Then messege0 = MsgBox("Данный параметр НЕ может содержать буквенные или нулевые значения ", vbCritical + vbOKOnly, " Ошибка пользовательского ввода !!! ") Exit Sub Else nnOuzN(Index).Text = Val(nnOuzN(Index).Text) nnOuzN(Index).BackColor = RGB(0, 250, 243) nnOuzN(Index).Locked = True: nnOuzN(Index).Locked = True '- код присвоения нового номера узлу < и в м линий > For zapMuzElin = 1 To kolvouzlov If MasKoLuZv(zapMuzElin, 1) = Index Then MasKoLuZv(zapMuzElin, 5) = Val(nnOuzN(Index).Text) End If Next zapMuzElin For zapMuzElin = 1 To kolvolin If mlinesSV(zapMuzElin, 1) > 0 Then If mlinesSV(zapMuzElin, 1) = Index Then mlinesSV(zapMuzElin, 8) = Val(nnOuzN(Index).Text) ElseIf mlinesSV(zapMuzElin, 2) = Index Then mlinesSV(zapMuzElin, 9) = Val(nnOuzN(Index).Text) End If End If Next zapMuzElin '-присвоение нового номера узлу<и в м линий> needFRsave = True testimonial = True End If Else If nnOuzN(Index).Locked = True Then messege0 = MsgBox("Вы хотите изменить номер выбранного узла : " _ & nnOuzN(Index).Text , vbQuestion + vbYesNo, " Изменение номера узла ") If messege0 = vbYes Then nnOuzN(Index).BackColor = vbGreen nnOuzN(Index).Locked = False Exit Sub End If End If End If brcout10: Exit Sub metERSS1: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout10 End Sub Private Sub Opt1_Click ( ) Opt1.Value = True If keeAB = False Then CmdFwd.Enabled = True End Sub Private Sub Opt1_GotFocus ( ) Opt1.DownPicture = LoadPicture(App.Path & "\Arrow_1.cur") If keeAB = False Then CmdFwd.Enabled = True Else CmdFwd.Enabled = False CmdWORKsch.Enabled = True CmdBk.Enabled = True End If End Sub Private Sub Opt1_LostFocus ( ) Opt1.Picture = LoadPicture(App.Path & "\Busy_m.cur") End Sub Private Sub Optlinswyazi_Click ( ) CmdFwd.Enabled = False CmdBk.Enabled = False Optlinswyazi.Value = True Opt1.Picture = LoadPicture(App.Path & "\Busy_m.cur") Picture1.MousePointer = vbArrow End Sub Private Sub Optuzel_Click ( ) CmdFwd.Enabled = False CmdBk.Enabled = False Optuzel.Value = True Opt1.Picture = LoadPicture(App.Path & "\Busy_m.cur") Picture1.MousePointer = 2 End Sub Private Sub svjaziuz (idsuz1 As Integer, idsuz2 As Integer, MasKoLuZv, kolvouzlov) Dim nomuz As Integer On Error GoTo metERSS2 For nomuz = 1 To kolvouzlov If MasKoLuZv(nomuz, 1) > 0 And MasKoLuZv(nomuz, 1) = _ idsuz1 Or MasKoLuZv(nomuz, 1) = idsuz2 Then MasKoLuZv(nomuz, 4) = MasKoLuZv(nomuz, 4) + 1 End If Next nomuz brcout20: Exit Sub metERSS2: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout20 End Sub Private Sub Pct1_GotFocus(Index As Integer) Pct1(Index).MousePointer = vbArrow End Sub Private Sub testlSN (tochka1 As Integer, tochka2 As Integer, SVLT( ) As Single, _ zkk As Boolean) Dim mnl As Integer, msSVsp As Integer On Error GoTo metERSS3 FrmSSN.Enabled = False FrmSSN.MousePointer = 11 FrmSSN.Picture1.MousePointer = 11 For mnl = 1 To kolvolin If SVLT(mnl, 1) > 0 Then If SVLT(mnl, 1) = tochka1 And SVLT(mnl, 2) = tochka2 Or SVLT(mnl, 2) = _ tochka1 And SVLT(mnl, 1) = tochka2 Then msSVsp = MsgBox(" Выбранная вами пара узлов уже соединена ", _ vbInformation + vbOKOnly, " Ограничение ввода ") zkk = True FrmSSN.Enabled = True FrmSSN.MousePointer = 0 Exit Sub End If End If Next mnl zkk = False FrmSSN.Enabled = True FrmSSN.MousePointer = 0 FrmSSN.Picture1.MousePointer = 1 brcout30: Exit Sub metERSS3: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout30 End Sub Private Sub Pct1_MouseDown (Index As Integer, Button As Integer, Shift As Integer, _ x As Single, Y As Single) Static iduzla As Integer, i As Integer Dim nResult As Integer, niduzla As Integer Dim nPredeL1 As Integer On Error GoTo metERSS4 If Optlinswyazi.Value = True And Button <> vbRightButton Then If keeAB = True Then Exit Sub Pct1(Index).BackColor = vbBlack If znak = True Then x1 = Pct1(Index).Left + ((Pct1(Index).Width) / 2) y1 = Pct1(Index).Top + (Pct1(Index).Height / 2) iduzla = Index znak = False Else: If iduzla = Index Then Exit Sub x2 = Pct1(Index).Left + (Pct1(Index).Width / 2) y2 = Pct1(Index).Top + (Pct1(Index).Height / 2) nResult = MsgBox(" Соединить узлы ? ", vbYesNo + vbExclamation, _ " Соединение выбранных узлов !") If nResult = vbYes Then zamok = False Pct1(iduzla).BackColor = vbBlue: Pct1(Index).BackColor = vbBlue svjaziuz iduzla, Index, MasKoLuZv, kolvouzlov testlSN iduzla, Index, mlinesSV, zamok If zamok = True Then GoTo 2 kolvolin = kolvolin + 1 LblLN(1).Caption = Str(kolvolin) If kolvolin > 400 Then nPredeL1 = MsgBox(" количество линий = 400 ! ", vbOKOnly, _ " предел количества линий ") If nPredeL1 = vbOK Then GoTo 2 End If svayzy x1, x2, y1, y2, iduzla, Index, mlinesSV, kolvolin needFRsave = True change = True Picture1_GotFocus Else: 2: x1 = 0 x2 = 0 y1 = 0 y2 = 0 znak = True Pct1(iduzla).BackColor = vbBlue: Pct1(Index).BackColor = vbBlue End If End If ElseIf Button = vbRightButton And Optuzel.Value = True Then If keeAB = True Then Exit Sub Pct1_deluzel Index, Button, Shift, x, Y '- удаление узла и его линий Exit Sub End If brcout40: Exit Sub metERSS4: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout40 End Sub Private Sub Pct1_deluzel (Index As Integer, Button As Integer, Shift As Integer, _ x As Single, Y As Single) Dim nResult As Integer, eraseslin As Integer Dim i As Integer, j As Integer Dim o As Integer On Error GoTo metERSS5 Pct1(Index).BackColor = vbRed nResult = MsgBox(" Удалить узел ?", vbYesNo + vbExclamation, _ " Удаление выбранного узла ! ") If nResult = vbYes Then NeWorKorrkolUZ Index, kolvouzlov, x, Y, 0 '-коррекция числа узлов kolvouzlov = kolvouzlov - 1 LbluZ(1).Caption = Str(kolvouzlov) Unload nnOuzN(Index) Unload Pct1(Index) needFRsave = True change = True eraseslin = 0 '- удаление связанных с узлом линий If kolvolin > 0 Then FrmSSN.Frame1.Enabled = False FrmSSN.Picture1.MousePointer = 11 For i = 1 To kolvolin If mlinesSV(i, 1) = Index Or mlinesSV(i, 2) = Index Then mlinesSV(i, 1) = 0: mlinesSV(i, 2) = 0: mlinesSV(i, 3) = 0 mlinesSV(i, 4) = 0: mlinesSV(i, 5) = 0: mlinesSV(i, 6) = 0 mlinesSV(i, 7) = 0: mlinesSV(i, 8) = 0: mlinesSV(i, 9) = 0: mlinesSV(i, 10) = 0 eraseslin = eraseslin + 1 End If Next i FrmSSN.Frame1.Enabled = True FrmSSN.Picture1.MousePointer = 0 korrmlinesSV mlinesSV, kolvolin, eraseslin bJampWeb = True CmdWEB_Click bJampWeb = False End If Else: Pct1(Index).BackColor = vbBlue: End If brcout50: Exit Sub metERSS5: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout50
End Sub Private Sub korrmlinesSV (mlinesSV, kolvolin, eraseslin) Dim masslinesSV() As Single, fth As Integer Dim i As Integer, j As Integer FrmSSN.Frame1.Enabled = False FrmSSN.Picture1.MousePointer = 11 On Error GoTo metERSS6 ReDim Preserve masslinesSV((kolvolin - eraseslin), 10) fth = 0 For i = 1 To kolvolin If mlinesSV(i, 1) > 0 Then fth = fth + 1 If fth <= (kolvolin - eraseslin) Then For j = 1 To 10 masslinesSV(fth, j) = mlinesSV(i, j): mlinesSV(i, j) = 0 Next j End If End If Next i For i = 1 To (kolvolin - eraseslin) For j = 1 To 10 mlinesSV(i, j) = masslinesSV(i, j) masslinesSV(i, j) = 0 Next j Next i: kolvolin = kolvolin - eraseslin LblLN(1).Caption = Str(kolvolin) FrmSSN.Frame1.Enabled = True FrmSSN.Picture1.MousePointer = 1 brcout60: Exit Sub metERSS6: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout60 End Sub Private Sub Picture1_GotFocus ( ) If Optlinswyazi.Value = True And x1 <> 0 And y2 <> 0 And y1 <> 0 Or x2 <> 0 Then Picture1.DrawStyle = 6 Picture1.Line (x1, y1)-(x2, y2), vbBlue x1 = 0 x2 = 0 y1 = 0 y2 = 0 znak = True End If Picture1.DrawStyle = 6 End Sub Private Sub Picture1_MouseDown (Button As Integer, Shift As Integer, x As Single, _ Y As Single) Dim i As Integer, txtid As Integer On Error GoTo metERSS7 Picture1.DrawStyle = 6 i = Pct1.UBound txtid = nnOuzN.UBound Pct1(i).MousePointer = vbArrow If Optuzel.Value = True And kolvouzlov <= 200 Then If keeAB = True Then Exit Sub If x < (Pct1(i).Width / 2) Or ((Picture1.Width) - x) < (Pct1(i).Width / 2) Or _ Y < (Pct1(i).Height / 2) Or ((Picture1.Height) - Y) < (Pct1(i).Height / 2) Then Exit Sub Load nnOuzN (txtid + 1) Load Pct1(i + 1) Pct1(i + 1).Move x - Pct1(i + 1).Width / 2, Y - Pct1(i + 1).Height / 2 Pct1(i + 1).Visible = True znak = True kolvouzlov = kolvouzlov + 1 NeWorKorrkolUZ 0, kolvouzlov, x, Y, i '- запись новых узлов LbluZ(1).Caption = Str(kolvouzlov) needFRsave = True change = True Else If Optlinswyazi.Value = True And Button = vbRightButton Then SVPprln mlinesSV, x, Y End If End If brcout70: Exit Sub metERSS7: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout70 End Sub Private Sub svjasiUZdel (numlinBRC As Integer, allUZsee As Integer) Dim UNz As Integer On Error GoTo metERSS8 FrmSSN.Frame1.Enabled = False FrmSSN.Picture1.MousePointer = 11 For UNz = 1 To allUZsee If MasKoLuZv(UNz, 1) > 0 Then If MasKoLuZv(UNz, 1) = mlinesSV(numlinBRC, 1) Or MasKoLuZv(UNz, 1) = _ mlinesSV(numlinBRC, 2) Then MasKoLuZv(UNz, 4) = MasKoLuZv(UNz, 4) - 1 End If End If Next UNz FrmSSN.Frame1.Enabled = True FrmSSN.Picture1.MousePointer = 1 brcout80: Exit Sub metERSS8: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout80 End Sub Private Sub SVPprln (mlinesSV, x, Y) Dim l As Integer, yyy As Double Dim xxx As Double, nSovpad As Integer Dim StrLinsV As Integer, DelAscK As Integer Dim flagsovp As Boolean, raznostimin() As Double Dim nuy As Integer, whatlin( ) As Integer On Error GoTo metERSS9 FrmSSN.Frame1.Enabled = False FrmSSN.Picture1.MousePointer = 11 nSovpad = 0 For l = 1 To kolvolin If mlinesSV(l, 3) >= mlinesSV(l, 5) And mlinesSV(l, 3) - mlinesSV(l, 5) <= 15 Then GoTo 73 If mlinesSV(l, 3) <= mlinesSV(l, 5) And mlinesSV(l, 5) - mlinesSV(l, 3) <= 15 Then
73:Select Case x Case Is >= mlinesSV(l, 3) If x - mlinesSV(l, 3) <= 17 Then GoTo 77 Case Is <= mlinesSV(l, 3) If mlinesSV(l, 3) - x <= 17 Then GoTo 77 Case Is >= mlinesSV(l, 5) If x - mlinesSV(l, 5) <= 17 Then GoTo 77 Case Is <= mlinesSV(l, 5) If mlinesSV(l, 5) - x <= 17 Then 77:StrLinsV = l FlinEd raznostimin, whatlin, x, Y, StrLinsV, mlinesSV, nSovpad, StrLinsV If StrLinsV <> 0 Then nSovpad = 1 GoTo 78 End If End If End Select Else If mlinesSV(l, 4) >= mlinesSV(l, 6) And mlinesSV(l, 4) - mlinesSV(l, 6) <= 15 Then GoTo 74 If mlinesSV(l, 4) <= mlinesSV(l, 6) And mlinesSV(l, 6) - mlinesSV(l, 4) <= 15 Then 74: Select Case Y Case Is >= mlinesSV(l, 4) If Y - mlinesSV(l, 4) <= 17 Then GoTo 77 Case Is <= mlinesSV(l, 4) If mlinesSV(l, 4) - Y <= 17 Then GoTo 77 Case Is >= mlinesSV(l, 6) If Y - mlinesSV(l, 6) <= 17 Then GoTo 77 Case Is <= mlinesSV(l, 6) If mlinesSV(l, 6) - Y <= 17 Then GoTo 77 End Select End If End If Next l For l = 1 To kolvolin If mlinesSV(l, 6) = mlinesSV(l, 4) Then mlinesSV(l, 6) = (mlinesSV(l, 6) + 2) If mlinesSV(l, 5) = mlinesSV(l, 3) Then mlinesSV(l, 5) = (mlinesSV(l, 5) + 2) yyy = ((Y - mlinesSV(l, 4)) / (mlinesSV(l, 6) - mlinesSV(l, 4))) xxx = ((x - mlinesSV(l, 3)) / (mlinesSV(l, 5) - mlinesSV(l, 3))) If xxx < 0 Then xxx = (xxx * (-1)) If yyy < 0 Then yyy = (yyy * (-1)) If xxx = 0 Or yyy = 0 Then GoTo 36 If yyy >= xxx And (yyy - xxx) < 0.554 Then 36: nuy = nuy + 1 ReDim Preserve raznostimin(nuy) raznostimin(nuy) = (yyy - xxx): GoTo 32 ElseIf yyy <= xxx And (xxx - yyy) < 0.554 Then nuy = nuy + 1 ReDim Preserve raznostimin(nuy) raznostimin(nuy) = (xxx - yyy) 32: nSovpad = nSovpad + 1: StrLinsV = l ReDim Preserve whatlin(1, nSovpad) whatlin(1, nSovpad) = l FlinEd raznostimin, whatlin, x, Y, StrLinsV, mlinesSV, nSovpad, StrLinsV End If yyy = 0: xxx = 0 Next l If nSovpad > 1 Then flagsovp = False lIniTiS whatlin, nSovpad, StrLinsV, raznostimin( ), flagsovp If flagsovp = True Then nSovpad = 1 End If 78: FrmSSN.Frame1.Enabled = True FrmSSN.Picture1.MousePointer = 1 If nSovpad = 1 And StrLinsV <> 0 Then mlinesSV(StrLinsV, 7) = 1 bJampWeb = True CmdWEB_Click bJampWeb = False If keeAB = True Then GoTo 179 DelAscK = MsgBox("Удалить линию ? ", vbExclamation + vbYesNo, _ " Удаление выбранной линии ") If DelAscK = vbYes Then bJampWeb = True svjasiUZdel StrLinsV, kolvouzlov mlinesSV(StrLinsV, 1) = 0: mlinesSV(StrLinsV, 2) = 0: mlinesSV(StrLinsV, 3) = 0 mlinesSV(StrLinsV, 4) = 0: mlinesSV(StrLinsV, 5) = 0: mlinesSV(StrLinsV, 6) = 0 mlinesSV(StrLinsV, 7) = 0: mlinesSV(StrLinsV, 8) = 0: mlinesSV(StrLinsV, 9) = 0 mlinesSV(StrLinsV, 10) = 0 korrmlinesSV mlinesSV, kolvolin, nSovpad needFRsave = True change = True CmdWEB_Click bJampWeb = False Else mlinesSV(StrLinsV, 7) = 0 176: bJampWeb = True CmdWEB_Click bJampWeb = False End If End If Exit Sub 179: Load FrmNwORsZ FrmNwORsZ.TxtOzN(0).Text = mlinesSV(StrLinsV, 10) FrmNwORsZ.TxtOzN(0).Locked = True FrmNwORsZ.Show vbModal If Len(FrmNwORsZ.TxtOzN(1).Text) <> 0 Then mlinesSV(StrLinsV, 10) = Val(FrmNwORsZ.TxtOzN(1).Text) Unload FrmNwORsZ mlinesSV(StrLinsV, 7) = 2 needFRsave = True testimonial = True GoTo 176 ElseIf mlinesSV(StrLinsV, 10) <> 0 Then mlinesSV(StrLinsV, 7) = 2 GoTo 176 Else mlinesSV(StrLinsV, 7) = 0 GoTo 176 End If brcout90: Exit Sub metERSS9: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout90 End Sub Private Sub NeWorKorrkolUZ (deliduz, kolvouzlov, x, Y, ci) Dim iuz As Integer, juz As Integer Dim UZkorR() As Integer, ff As Integer Dim kkk As Integer On Error GoTo metERSS10 If deletealluz = True And kolvouzlov > 0 Then FrmSSN.Enabled = False FrmSSN.MousePointer = 11 For iuz = 1 To kolvouzlov If MasKoLuZv(iuz, 1) <> 0 Then Unload nnOuzN(MasKoLuZv(iuz, 1)) Unload Pct1(MasKoLuZv(iuz, 1)) End If For juz = 1 To 5 MasKoLuZv(iuz, juz) = 0 Next juz Next iuz kolvouzlov = 0 Else FrmSSN.Enabled = True FrmSSN.MousePointer = 0 If deliduz = 0 Then For iuz = 1 To kolvouzlov If MasKoLuZv(iuz, 1) = 0 Then MasKoLuZv(iuz, 1) = ci + 1: MasKoLuZv(iuz, 2) = x MasKoLuZv(iuz, 3) = Y: MasKoLuZv(iuz, 4) = 0 MasKoLuZv(iuz, 5) = 0 End If Next iuz Else FrmSSN.Enabled = False FrmSSN.MousePointer = 11 If kolvouzlov = 1 Then kkk = kolvouzlov Else kkk = kolvouzlov - 1 ReDim Preserve UZkorR(kkk, 5) For iuz = 1 To kolvouzlov If deliduz = MasKoLuZv(iuz, 1) Then MasKoLuZv(iuz, 1) = 0: MasKoLuZv(iuz, 2) = 0: MasKoLuZv(iuz, 3) = 0 MasKoLuZv(iuz, 4) = 0: MasKoLuZv(iuz, 5) = 0 End If Next iuz For iuz = 1 To kolvouzlov If MasKoLuZv(iuz, 1) <> 0 Then ff = ff + 1 For juz = 1 To 5 UZkorR(ff, juz) = MasKoLuZv(iuz, juz): MasKoLuZv(iuz, juz) = 0 Next juz End If Next iuz For iuz = 1 To kolvouzlov - 1 For juz = 1 To 5 MasKoLuZv(iuz, juz) = UZkorR(iuz, juz) Next juz: Next iuz End If End If FrmSSN.Enabled = True FrmSSN.MousePointer = 0 brcout100: Exit Sub metERSS10: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout100 End Sub Private Sub lIniTiS (whatlin, nSovpad, StrLinsV, raznostimin() As Double, _ sovp As Boolean) Dim ar As Integer, perehod As Boolean Dim vib As Integer, arda As Integer Dim prraznmin(1) As Double, wtlpr() As Integer ReDim Preserve wtlpr(1, nSovpad) On Error GoTo metERSS11 For arda = 1 To nSovpad '- 1 For ar = 1 To nSovpad - 1 If raznostimin(ar) = 0 And raznostimin(ar + 1) > 0 Then raznostimin(ar) = raznostimin(ar + 1): raznostimin(ar + 1) = 0 whatlin(1, ar) = whatlin(1, ar + 1): whatlin(1, ar + 1) = 0 ElseIf raznostimin(ar) > raznostimin(ar + 1) And raznostimin(ar + 1) <> 0 Then prraznmin(1) = raznostimin(ar): wtlpr(1, ar) = whatlin(1, ar) raznostimin(ar) = raznostimin(ar + 1): whatlin(1, ar) = whatlin(1, ar + 1) raznostimin(ar + 1) = prraznmin(1): whatlin(1, ar + 1) = wtlpr(1, ar) End If Next ar Next arda ar = 0: arda = 0 For ar = 1 To nSovpad If raznostimin(ar) > 0 Then StrLinsV = whatlin(1, ar): whatlin(1, ar) = 0 sovp = True Exit For End If Next ar ar = 0 brcout110: Exit Sub metERSS11: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout110 End Sub Private Sub FlinEd (rzn( ) As Double, wlinw( ) As Integer, x, Y, StrLV, mlSV, _ SVPD As Integer, StrLinsV) On Error GoTo metERSS12 If mlSV(StrLV, 3) < x And x > mlSV(StrLV, 5) Then GoTo 977 If mlSV(StrLV, 3) > x And x < mlSV(StrLV, 5) Then GoTo 977 If mlSV(StrLV, 4) < Y And Y > mlSV(StrLV, 6) Then GoTo 977 If mlSV(StrLV, 4) > Y And Y < mlSV(StrLV, 6) Then 977: If SVPD <> 0 Then rzn(SVPD) = 0 StrLinsV = 0 Else If mlSV(StrLV, 3) = x And x <> mlSV(StrLV, 5) Then Select Case x Case Is > mlSV(StrLV, 5) If x - mlSV(StrLV, 5) > 17 Then GoTo 977 Case Is < mlSV(StrLV, 5) If mlSV(StrLV, 5) - x > 17 Then GoTo 977 End Select End If If mlSV(StrLV, 3) <> x And x = mlSV(StrLV, 5) Then Select Case x Case Is > mlSV(StrLV, 3) If x - mlSV(StrLV, 3) > 17 Then GoTo 977 Case Is < mlSV(StrLV, 3) If mlSV(StrLV, 3) - x > 17 Then GoTo 977 End Select End If
If mlSV(StrLV, 4) = Y And Y <> mlSV(StrLV, 6) Then Select Case Y Case Is > mlSV(StrLV, 6) If Y - mlSV(StrLV, 6) > 17 Then GoTo 977 Case Is < mlSV(StrLV, 6) If mlSV(StrLV, 6) - Y > 17 Then GoTo 977 End Select End If If mlSV(StrLV, 4) <> Y And Y = mlSV(StrLV, 6) Then Select Case Y Case Is > mlSV(StrLV, 4) If Y - mlSV(StrLV, 4) > 17 Then GoTo 977 Case Is < mlSV(StrLV, 4) If mlSV(StrLV, 4) - Y > 17 Then GoTo 977 End Select End If End If brcout120: Exit Sub metERSS12: MsgBox "Error № " & Err.Number & " " & " (" & Err.Description & ") occured.", vbCritical, "Error" GoTo brcout120
End Sub Public Sub numUZmu (LN As Integer, MKUN As Integer, a12 As Integer, na1, na2) Dim t As Integer Dim td As Integer
For td = 1 To a12 For t = 1 To MKUN If MasKoLuZv(t, 1) = mlinesSV(LN, td) Then If td = 1 Then na1 = t Exit For ElseIf td = 2 Then na2 = t Exit For End If End If Next t Next td End Sub Public Property Get UvmLN (LNmSV As Integer) As Single UvmLN = mlinesSV(LNmSV, 10) End Property Public Property Get webchS (NWMW As Integer) As Single Select Case NWMW Case Is = 1 webchS = shwebx Case Is = 2 webchS = shweby End Select End Property Вторая часть Dim flagnext As Boolean, flaghehe As Boolean Private Sub CmdNOWer_Click ( ) Unload frmBrWk End Sub Private Sub CmdOKWer_Click ( ) Dim msg As Integer If frmBrWk.FramNsInf.Caption = "Расчет" Then Exit Sub If TextMNI.Locked = True Then Exit Sub If Val(TextMNI.Text) = 0 Or Not IsNumeric(TextMNI) Then msg = MsgBox("Данный параметр НЕ может содержать буквенные или _ нулевые значения " & vbCrLf & _ " Значением параметра может быть только целое число !!! " _ , vbCritical + vbOKOnly, " Ошибка пользовательского ввода !!! ") Exit Sub Else MdlWorkSpase.maxNnoi = Val(TextMNI.Text) TextMNI.BackColor = RGB(0, 250, 243) TextMNI.Locked = True: TextMNI.Locked = True needFRsave = True flagnext = True End If End Sub Private Sub CmmEd_Click ( ) Dim edms As Integer If flaghehe = True Then Exit Sub MdlWorkSpase.flgstopuser = True edms = MsgBox(" Прервано пользователем !", vbInformation + vbOKOnly, _ " Останов расчета структурной надежности") frmBrWk.PrgBarWSind.Value = 0 frmBrWk.FramNsInf.Enabled = True flaghehe = True End Sub Private Sub CmmSt_Click ( ) Dim hehe As Integer If flagnext = False Then hehe = MsgBox(" Невозможно начать расчет Немея числа испытаний !!!", _ vbCritical + vbOKOnly, " Ошибка пользовательского ввода ") flaghehe = True Exit Sub End If frmBrWk.FramNsInf.Enabled = False MdlWorkSpase.flgstopuser = False flaghehe = False MdlWorkSpase.cmdrasch_workmod End Sub Private Sub Form_Load ( ) frmBrWk.FramNsInf.ZOrder 0 flagnext = False frmBrWk.FramNsInf.Enabled = True End Sub Private Sub TbSW_Click ( ) Dim ntemp As Integer ntemp = TbSW.SelectedItem.Index If ntemp = 2 Then frmBrWk.FramNsInf.ZOrder 1 frmBrWk.FramWorkStart.ZOrder 0 ElseIf ntemp = 1 Then frmBrWk.FramNsInf.ZOrder 0 frmBrWk.FramWorkStart.ZOrder 1 End If End Sub Private Sub TextMNI_KeyPress (KeyAscii As Integer) Dim m2sg As Integer If frmBrWk.FramNsInf.Caption = "Расчет" Then Exit Sub If TextMNI.Locked = True Then msg = MsgBox("Вы хотите изменить число испытаний ? : " & TextMNI.Text _ , vbQuestion + vbYesNo, " Новое число испытаний ") If msg = vbYes Then TextMNI.BackColor = vbGreen TextMNI.Locked = False Exit Sub End If End If End Sub Третья часть
Популярное: Почему двоичная система счисления так распространена?: Каждая цифра должна быть как-то представлена на физическом носителе... Как распознать напряжение: Говоря о мышечном напряжении, мы в первую очередь имеем в виду мускулы, прикрепленные к костям ... Как выбрать специалиста по управлению гостиницей: Понятно, что управление гостиницей невозможно без специальных знаний. Соответственно, важна квалификация... Почему человек чувствует себя несчастным?: Для начала определим, что такое несчастье. Несчастьем мы будем считать психологическое состояние... ©2015-2024 megaobuchalka.ru Все материалы представленные на сайте исключительно с целью ознакомления читателями и не преследуют коммерческих целей или нарушение авторских прав. (181)
|
Почему 1285321 студент выбрали МегаОбучалку... Система поиска информации Мобильная версия сайта Удобная навигация Нет шокирующей рекламы |