frmriver.frm

水质模糊综合评价系统 水质模糊综合评价系统 水质模糊综合评价系统

MsgBox "请把数据输入完整！"
Else
'水质评价并把评价结果添加到数据库中
Label18.Caption = Date '获取当前系统日期
Dim a(1 To 5) As Single, b(1 To 5) As Single, c(1 To 5) As Single, d(1 To 5) As Single, e(1 To 50) As Single, f(1 To 5) As Single, g(1 To 5) As Single
Dim x As Single, Y As Single, z As Single, q As Single, p As Single
Dim j As Integer
Dim m As Single
Dim r(1 To 5) As Single
x = Val(Text1.Text)
Y = Val(Text2.Text)
z = Val(Text3.Text)
q = Val(Text4.Text)
p = Val(Text5.Text)
f(1) = Val(Text6.Text)
f(2) = Val(Text7.Text)
f(3) = Val(Text8.Text)
f(4) = Val(Text9.Text)
f(5) = Val(Text10.Text)
'得到隶属度矩阵
If x <= 5 Then
   a(1) = 0
   ElseIf x > 5 And x < 7 Then
    a(1) = 1 / 2 * (x - 5)
   Else
     a(1) = 1
   End If
If x > 3 And x < 5 Then
    a(2) = 1 / 2 * (x - 3)
   ElseIf x >= 5 And x < 7 Then
    a(2) = -1 / 2 * (x - 7)
   Else
    a(2) = 0
    End If
If x > 2 And x < 3 Then
    a(3) = x - 2
   ElseIf x > 3 And x < 5 Then
      a(3) = -1 / 2 * (x - 5)
   Else
    a(3) = 0
    End If
If x > 1 And x < 2 Then
    a(4) = x - 1
   ElseIf x > 2 And x < 3 Then
    a(4) = -(x - 3)
  Else
    a(4) = 0
    End If
If x <= 1 Then
    a(5) = 1
    ElseIf x > 1 And x < 2 Then
      a(5) = 2 - x
    Else
      a(5) = 0
    End If
If Y > 2 Then
     b(1) = 0
    ElseIf Y > 1.5 And Y < 2 Then
      b(1) = -2 * (Y - 2)
    Else
      b(1) = 1
    End If
 If Y > 2 And Y < 3 Then
    b(2) = 3 - Y
    ElseIf Y > 1.5 And Y < 2 Then
      b(2) = 2 * (Y - 1.5)
    Else
      b(2) = 0
    End If
If Y > 2 And Y < 3 Then
    b(3) = Y - 2
   ElseIf Y > 3 And Y < 5 Then
      b(3) = -1 / 2 * (Y - 5)
    Else
     b(3) = 0
End If
If Y > 5 And Y < 8 Then
    b(4) = 1 / 3 * (8 - Y)
   ElseIf Y > 3 And Y <= 5 Then
    b(4) = 1 / 2 * (Y - 3)
   Else
    b(4) = 0
    End If

If Y >= 8 Then
    b(5) = 1
    ElseIf Y > 5 And Y < 8 Then
      b(5) = 1 / 3 * (Y - 5)
    Else
    b(5) = 0
    End If
If z >= 3 Then
    c(1) = 0
    ElseIf z > 2 And z < 3 Then
    c(1) = 3 - z
    Else
     c(1) = 1
     End If
 If z > 3 And z < 5 Then
    c(2) = -1 / 2 * (z - 5)
    ElseIf z > 2 And z < 3 Then
    c(2) = z - 2
    Else
    c(2) = 0
    End If
If z > 3 And z < 5 Then
    c(3) = 1 / 2 * (z - 3)
   ElseIf z > 5 And z < 8 Then
    c(3) = -1 / 3 * (z - 8)
   Else
    c(3) = 0
    End If
If z > 5 And z < 8 Then
    c(4) = 1 / 3 * (z - 5)
    ElseIf z > 8 And z < 10 Then
    c(4) = -1 / 2 * (z - 10)
    Else
    c(4) = 0
    End If
    
If z >= 10 Then
    c(5) = 1
    ElseIf z > 8 And z < 10 Then
     c(5) = 1 / 2 * (z - 8)
    Else
    c(5) = 0
    End If
If q >= 0.005 Then
    d(1) = 0
    ElseIf q > 0.002 And q < 0.005 Then
    d(1) = 1 / 0.003 * (0.005 - q)
    Else
     d(1) = 1
   End If
If q > 0.002 And q < 0.005 Then
    d(2) = 1 / 0.003 * (q - 0.002)
    ElseIf q <= 0.002 Or q >= 0.01 Then
    d(2) = 0
    Else
    d(2) = -1 / 0.005 * (q - 0.01)
    End If
If q > 0.005 And q < 0.01 Then
        d(3) = 1 / 0.005 * (q - 0.005)
     ElseIf q >= 0.01 And q < 0.02 Then
        d(3) = -1 / 0.01 * (q - 0.02)
     Else
        d(3) = 0
    End If
If q > 0.01 And q < 0.02 Then
       d(4) = 1 / 0.01 * (q - 0.01)
    ElseIf q >= 0.02 And q < 0.03 Then
       d(4) = -1 / 0.01 * (q - 0.03)
    Else
       d(4) = 0
End If
If q >= 0.03 Then
       d(5) = 1
    ElseIf x > 0.02 And x < 0.03 Then
      d(5) = 1 / 0.01 * (q - 0.02)
   Else
      d(5) = 0
   End If

If p >= 0.002 Then
      e(1) = 0
    ElseIf p > 0.001 And p < 0.002 Then
      e(1) = -1 / 0.001 * (p - 0.002)
    Else
      e(1) = 1
     End If
If p > 0.001 And p < 0.002 Then
       e(2) = 1 / 0.001 * (p - 0.001)
    ElseIf p >= 0.002 And p < 0.005 Then
        e(2) = -1 / 0.003 * (p - 0.005)
    Else
       e(2) = 0
   End If
If p > 0.002 And p < 0.005 Then
       e(3) = 1 / 0.003 * (p - 0.002)
    ElseIf p >= 0.005 And p < 0.01 Then
      e(3) = -1 / 0.005 * (p - 0.01)
   Else
      e(3) = 0
    End If
If p > 0.005 And p < 0.01 Then
         e(4) = 1 / 0.005 * (p - 0.005)
     ElseIf p >= 0.01 And p < 0.02 Then
        e(4) = -1 / 0.01 * (p - 0.02)
   Else
       e(4) = 0
    End If
If p >= 0.02 Then
      e(5) = 1
   ElseIf p > 0.01 And p < 0.02 Then
      e(5) = 1 / 0.01 * (p - 0.01)
   Else
      e(5) = 0
End If
m = f(1) + f(2) + f(3) + f(4) + f(5) '判断输入权重值的合理性
If m < 1 Or m > 1 Then
MsgBox "输入数据不合法，请重新输入！", vbOKOnly, "警告信息！"
Text6 = ""
Text7 = ""
Text8 = ""
Text9 = ""
Text10 = ""
Exit Sub
Else

'权重矩阵与隶属度矩阵相乘得出综合评价结果向量(r1,r2,r3,r4，r5）

Text11.Text = f(1) * a(1) + f(2) * b(1) + f(3) * c(1) + f(4) * d(1) + f(5) * e(1)
Text12.Text = f(1) * a(2) + f(2) * b(2) + f(3) * c(2) + f(4) * d(2) + f(5) * e(2)
Text13.Text = f(1) * a(3) + f(2) * b(3) + f(3) * c(3) + f(4) * d(3) + f(5) * e(3)
Text14.Text = f(1) * a(4) + f(2) * b(4) + f(3) * c(4) + f(4) * d(4) + f(5) * e(4)
Text15.Text = f(1) * a(5) + f(2) * b(5) + f(3) * c(5) + f(4) * d(5) + f(5) * e(5)
'格式化存入数据库的数据
r1 = Format(Val(Text11.Text), "0.0000")
r2 = Format(Val(Text12.Text), "0.0000")
r3 = Format(Val(Text13.Text), "0.0000")
r4 = Format(Val(Text14.Text), "0.0000")
r5 = Format(Val(Text15.Text), "0.0000")
'比较得到模糊综合评价结果
If r1 >= r2 And r1 >= r3 And r1 >= r4 And r1 >= r5 Then
    Label17.Caption = "此水质一级隶属度最大，所以接近水质优！"
    Label19.Caption = "水质优"
    ElseIf r2 >= r1 And r2 >= r3 And r2 >= r4 And r2 >= r5 Then
     Label17.Caption = "此水质二级隶属度最大，所以接近水质良！"
      Label19.Caption = "水质良"
    ElseIf r3 >= r1 And r3 >= r2 And r3 >= r4 And r3 >= r5 Then
     Label17.Caption = "此水质三级隶属度最大，所以接近水质中！"
      Label19.Caption = "水质中"
    ElseIf r4 >= r1 And r4 >= r2 And r4 >= r3 And r4 >= r5 Then
    Label17.Caption = "此水质四级隶属度最大，所以接近水质差！"
     Label19.Caption = "水质差"
    ElseIf r5 >= r1 And r5 >= r2 And r5 >= r3 And r5 >= r4 Then
    Label17.Caption = "此水质五级隶属度最大，所以接近水质很差！"
     Label19.Caption = "水质很差"
End If
'把结果存入到数据库
Dim db As Connection
Set db = New Connection
db.CursorLocation = adUseClient
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & App.Path & "\db1.mdb;" & "Persist Security Info=False;"
Set rs = New Recordset
rs.Open "select * from 河口水评价结果表", db, adOpenStatic, adLockOptimistic
 rs.AddNew
rs("采样地点") = Combo1.Text
rs("采样日期") = Label18.Caption
rs("一级") = r1
rs("二级") = r2
rs("三级") = r3
rs("四级") = r4
rs("五级") = r5
rs("评价结果") = Label19.Caption
rs.Update
rs.Close
End If
End If
End Sub


Private Sub Command3_Click()
'退出本窗体
Dim Msg, Style, Title, response, mystring
Msg = "你确实要取消吗？"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "信息确认！"
response = MsgBox(Msg, Style, Title)
If response = vbYes Then
 mystring = "yes"
FrmRiver.Visible = False
Else
 mystring = "no"
FrmRiver.Visible = True
 End If
End Sub

Private Sub Command2_Click()
'数据清空
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text11.Text = ""
Text12.Text = ""
Text13.Text = ""
Text14.Text = ""
Text15.Text = ""
Label19.Caption = ""
End Sub
Private Sub BackG(f As Form, pic As PictureBox)
'设置背景图片
For i = 0 To (f.ScaleWidth \ pic.Width)
   For j = 0 To (f.ScaleHeight \ pic.Height)
      PaintPicture pic.Picture, i * pic.Width, j * pic.Height
       Next
    Next
End Sub
Private Sub Command4_Click()
FrmRiverCx.Show
End Sub
Private Sub Form_Load()
Label19.Visible = False
Me.AutoRedraw = True
Pic1.Visible = False
Pic1.BorderStyle = 0
Pic1.AutoSize = True
Pic1.Picture = LoadPicture(App.Path + "\03.gif")
BackG Me, Pic1
Label16.Caption = "请选择水体类型："
End Sub
Private Sub Form_resize()
BackG Me, Pic1
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
'用回车键控制输入到相邻文本框
If KeyAscii = 13 Then
Text2.SetFocus
End If
End Sub
Private Sub Text16_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text1.SetFocus
End If
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text3.SetFocus
End If
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text4.SetFocus
End If
End Sub
Private Sub Text4_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text5.SetFocus
End If
End Sub
Private Sub Text5_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text6.SetFocus
End If
End Sub
Private Sub Text6_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text7.SetFocus
End If
End Sub
Private Sub Text7_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text8.SetFocus
End If
End Sub
Private Sub Text8_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text9.SetFocus
End If
End Sub
Private Sub Text9_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text10.SetFocus
End If
End Sub