module4.bas

用XML做专家系统的一个编译器,有说明书,使用简单,有模板

Attribute VB_Name = "Module4"
'层次分析模块
Public Layer As Integer                                   '层数
Const max = 50                                            '常数
Const LayerMax = 6                                        '层次最大值
Public ConnectNum As Integer                              '异层次间元素联系数目
Public LayerNum(1 To LayerMax), CurrentLayer As Integer   '各层的元素个数,当前层层号
Public LayerValue(1 To LayerMax, 1 To 10) As String       '层次名及对应的元素名

Public Type LayerConnection                               '描述层次间联系的结构
    CurLayer As Integer
    FatherLayerPos As Integer
    ChildLayerPos As Integer
End Type
Public AllConnection(1 To max) As LayerConnection         '存放层次间联系的数组

Public MatrixB(1 To 10, 1 To 10) As Double                   '判断矩阵数组
Public Wi(1 To 10), Ai(1 To LayerMax, 1 To 10) As Double     '层次单排序的特征向量，层次总排序的结果
Public MatrixTotal(1 To LayerMax - 1, 1 To 10, 1 To 10) As Double
Public CITotal(1 To 10), RI(1 To 9), CI, nums As Double      '记录当前层内所有的CI值,RI值,当前判断矩阵的CI值, 判断矩阵的大小
Dim frmmatrix1 As New frmMatrix

Public quitErr As Boolean
              
Public Sub AHP()
Dim i As Integer
                                       
For i = 1 To Layer - 1                 '初始化计算矩阵
For j = 1 To 10
For k = 1 To 10
    MatrixTotal(i, j, k) = 0
Next
Next
Next

For i = 1 To Layer - 1
CurrentLayer = i + 1

If quitErr = True Then                   '非正常退出
    Exit Sub
End If

tan (i)
Next

GetResult
End Sub

Sub tan(ByRef i As Integer)
Dim j, k, N, p As Integer
For k = 1 To LayerNum(i)                               '每层判断矩阵的数目
N = 0
frmmatrix1.MSFlexGrid1.TextMatrix(0, 0) = LayerValue(i, k)
For j = 1 To ConnectNum                                         '
    If AllConnection(j).CurLayer = i And AllConnection(j).FatherLayerPos = k Then
        N = N + 1
    End If
Next
nums = N
frmmatrix1.MSFlexGrid1.Cols = N + 2
frmmatrix1.MSFlexGrid1.Rows = N + 1

N = 0
For j = 1 To ConnectNum                                         '
    If AllConnection(j).CurLayer = i And AllConnection(j).FatherLayerPos = k Then
        N = N + 1
        frmmatrix1.MSFlexGrid1.TextMatrix(0, N) = LayerValue(i + 1, AllConnection(j).ChildLayerPos)
        frmmatrix1.MSFlexGrid1.TextMatrix(N, 0) = LayerValue(i + 1, AllConnection(j).ChildLayerPos)
    End If
Next
nums = N
frmmatrix1.MSFlexGrid1.TextMatrix(0, N + 1) = "特征向量"
For j = 1 To N
    frmmatrix1.MSFlexGrid1.TextMatrix(j, j) = 1
Next                                                        '上面都是构造判断矩阵
If i = Layer - 1 And k = LayerNum(i) Then
    frmmatrix1.CommandCon.Caption = "完成"
End If
frmmatrix1.Show vbModal                  '弹出判断矩阵对话框
CITotal(k) = CI
p = 1
For j = 1 To ConnectNum
    If AllConnection(j).CurLayer = i And AllConnection(j).FatherLayerPos = k Then
        MatrixTotal(i, AllConnection(j).ChildLayerPos, AllConnection(j).FatherLayerPos) = Wi(p)
        p = p + 1
    End If
Next
Next

If i >= 1 Then
Consistency_Check_Total (i)      '层次总排序的一致性检验
End If
End Sub

Sub GetRoot()                    '判断矩阵求最大特征根和特征向量
Dim Mi(10), total As Double
Dim i, j, N As Integer
N = nums
For i = 1 To N
    Mi(i) = 1
    For j = 1 To N
        Mi(i) = Mi(i) * MatrixB(i, j)
    Next
    Mi(i) = Exp(1 / N * Log(Mi(i)))
Next
total = 0
For i = 1 To N
    total = total + Mi(i)
Next
For i = 1 To 10
    Wi(i) = 0
Next
For i = 1 To N
    Wi(i) = Mi(i) / total
Next
For i = 1 To N
    frmmatrix1.MSFlexGrid1.TextMatrix(i, N + 1) = FormatNumber(Wi(i), 4, vbTrue, vbTrue, vbFalse) '格式化数值
Next
frmmatrix1.MSFlexGrid1.Refresh
End Sub

Function LoadData() As Boolean             '从frmmatrix1中将数据读入到判断矩阵中
Dim i As Integer
Dim j As Integer
For i = 1 To frmmatrix1.MSFlexGrid1.Rows - 1            '数据不完整将不进行计算
    For j = 1 To frmmatrix1.MSFlexGrid1.Rows - 1
        If frmmatrix1.MSFlexGrid1.TextMatrix(i, j) = "" Then
        LoadData = False
        Exit Function
        End If
    Next
Next
LoadData = True
For i = 1 To frmmatrix1.MSFlexGrid1.Rows - 1
    For j = 1 To frmmatrix1.MSFlexGrid1.Rows - 1
        MatrixB(i, j) = CDbl(frmmatrix1.MSFlexGrid1.TextMatrix(i, j))
    Next
Next
End Function

Sub GetResult()                       '方案评价结果
Dim i, j, k As Integer
Dim temp(LayerMax, 10) As Double
Dim m_string As String
Dim max, maxj As Double

m_string = ""
temp(1, 1) = 1
For i = 1 To Layer - 1
    For j = 1 To LayerNum(i + 1)
        temp(i + 1, j) = 0
        For k = 1 To LayerNum(i)
            temp(i + 1, j) = temp(i + 1, j) + MatrixTotal(i, j, k) * temp(i, k)
            Ai(i + 1, j) = temp(i + 1, j)
        Next
    Next
Next
For j = 1 To LayerNum(Layer)
    m_string = m_string + LayerValue(Layer, j) + " :  " + CStr(FormatNumber(Ai(Layer, j), 4, vbTrue, vbTrue, vbFalse)) + "         " + vbCrLf + vbCrLf
Next

'比较方案结果
max = 0
For j = 1 To LayerNum(Layer)
    If (Ai(Layer, j) > max) Then
        max = Ai(Layer, j)
        maxj = j
    End If
Next

m_string = m_string + "第" + CStr(maxj) + "种方案最佳" + vbCrLf
MsgBox "评价结果: " + vbCrLf + vbCrLf + m_string, vbApplicationModal, "Dest3.0"
End Sub

Sub Consistency_Check()        '层次单排序一致性检验
Dim i, j, N As Integer
Dim DELTAmax, CR As Double     '矩阵的最大特征根，矩阵的一致性比例系数
Dim AW(10) As Double
RI(1) = 0
RI(2) = 0
RI(3) = 0.58
RI(4) = 0.9
RI(5) = 1.12
RI(6) = 1.24
RI(7) = 1.32
RI(8) = 1.41
RI(9) = 1.45
N = nums
If (N < 3) Then
    MsgBox vbCrLf + "1、2阶矩阵总具有完全满足一致性   " + vbCrLf, vbApplicationModal + vbInformation, "Dest3.0层次单排序-" + "第" + CStr(CurrentLayer) + "层"
    Exit Sub
End If
For i = 1 To N
    AW(i) = 0
    For j = 1 To N
        AW(i) = AW(i) + MatrixB(i, j) * Wi(j)
    Next
Next
DELTAmax = 0
For i = 1 To N
DELTAmax = DELTAmax + AW(i) / N / Wi(i)
Next
CI = (DELTAmax - N) / (N - 1)
CR = CI / RI(N)
CR = FormatNumber(CR, 4, vbTrue, vbTrue, vbFalse)
If (CR < 0.1) Then
MsgBox vbCrLf + "CR= " + CStr(CR) + " < 0.1" + vbCrLf + vbCrLf + "满足一致性   " + vbCrLf, vbApplicationModal + vbInformation, "Dest3.0层次单排序-" + "第" + CStr(CurrentLayer) + "层"
Else
MsgBox vbCrLf + "CR= " + CStr(CR) + " > 0.1" + vbCrLf + vbCrLf + "不满足一致性,请调整判断矩阵的元素取值   " + vbCrLf, vbApplicationModal + vbExclamation, "Dest3.0层次单排序-" + "第" + CStr(CurrentLayer) + "层"
End If
End Sub

Sub Consistency_Check_Total(ByRef i As Integer)   '层次总排序一致性检验
Dim fenzi, fenmu As Double
Dim CR As Integer
Dim j, k, m, l As Integer
m = LayerNum(i)
fenzi = 0
fenmu = 0
Ai(1, 1) = 1
For l = 2 To i
    For j = 1 To LayerNum(l + 1)
        Ai(l, j) = 0
        For k = 1 To LayerNum(l)
            Ai(l, j) = Ai(l, j) + MatrixTotal(l, j, k) * Ai(l - 1, k)
        Next
    Next
Next
For j = 1 To m
    fenzi = fenzi + Ai(i, j) * CITotal(j)
    fenmu = fenmu + Ai(i, j) * RI(LayerNum(i + 1))
Next
'非正常退出
If fenmu = 0 Then
    quitErr = True
    Exit Sub
End If
CR = fenzi / fenmu
CR = FormatNumber(CR, 4, vbTrue, vbTrue, vbFalse)
If (CR < 0.1) Then
MsgBox vbCrLf + "CR= " + CStr(CR) + " < 0.1" + vbCrLf + vbCrLf + "满足一致性   " + vbCrLf, vbApplicationModal + vbInformation, "Dest3.0层次总排序-" + "第" + CStr(i + 1) + "层"
Else
MsgBox vbCrLf + "CR= " + CStr(CR) + " > 0.1" + vbCrLf + vbCrLf + "不满足一致性,请调整判断矩阵的元素取值   " + vbCrLf, vbApplicationModal + vbExclamation, "Dest3.0层次总排序-" + "第" + CStr(i + 1) + "层"
End If
End Sub