Приведем рисунок алгоритма программы интерфейса.
2.3 Разработка программы расчета структурной надежности методом
статического моделирования
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
