frmadd.frm

系统工程-层次分析法VB版

        .Name = "C" + Trim(Str(i - 1))
        .ContainObj = ""
        .Style = LayerC
        .txtInf = ""
        .Finished = False
    End With
Next

initDec '初始化准则与方案的说明信息

CanNext = True
BtnState
Exit Sub

errH:
    ShowUnknownErr
End Sub
'说明信息初始化
Sub initDec()
Dim i As Long

EnableDec True

With DecC
    .Text = ""
    For i = 1 To cLCount
        .Text = .Text + "C" + Trim(Str(i)) + ":" + vbCrLf
    Next
End With

With DecP
    .Text = ""
    For i = 1 To pLCount
        .Text = .Text + "P" + Trim(Str(i)) + ":" + vbCrLf
    Next
End With
End Sub
Sub EnableDec(ByVal B As Boolean)
    DecC.Enabled = B
    DecP.Enabled = B
End Sub
'初始化窗体变量
Sub initFormVar()
    CanFinished = False
    CanLast = False
    CanNext = False
    
    BtnState
    
    EnableDec False
    
    pBox(0).Visible = True
    pBox(1).Visible = False
    
End Sub
'改变按钮状态
Sub BtnState()
    cmdLastStep.Enabled = CanLast
    cmdNextStep.Enabled = CanNext
    cmdFinish.Enabled = CanFinished
End Sub

Private Sub cmdFinish_Click()
    If Not CheckRelation Then
        MsgBox "关联字符串格式不对，或是输入有错误!", vbOKOnly + vbInformation, "提示信息"
        Exit Sub
    End If
    
    initGrid
    initTree frmMain.LayerTree
    frmMain.First = False
    frmMain.Frame1.Enabled = True
    Unload Me
End Sub
'初始化树开列表
Sub initTree(tTree As TreeView)
Dim tNode As Node
Dim tStr() As String

tTree.ImageList = frmMain.ImageList1

'生成根目录(目标层)
Set tNode = tTree.Nodes.Add()
tNode.Text = "目标层" + vLayer(1).Name
tNode.Image = "root"
tNode.Tag = "A"

Dim i As Long, j As Long, k As Long
Dim tS As String

Dim tempNodeC As Node, tempNodeP As Node
'生成各准则层
For i = 1 To cLCount
    Set tempNodeC = tTree.Nodes.Add(tNode.Index, tvwChild)
    tempNodeC.Text = vDecC(i).Dec
    tempNodeC.Image = "close"
    tempNodeC.Tag = vDecC(i).Name
    tStr() = Split(vLayer(i + 1).ContainObj, vbTab)
    '生成各方案层
    For j = LBound(tStr) To UBound(tStr)
        If Trim(tStr(j)) <> "" Then
            Set tempNodeP = tTree.Nodes.Add(tempNodeC.Index, tvwChild)
            tS = Trim(tStr(j))
            For k = 1 To pLCount
                If Trim(tStr(j)) = vDecP(k).Name Then
                    tS = vDecP(k).Dec
                    Exit For
                End If
            Next
            tempNodeP.Text = tS
            tempNodeP.Image = "file"
            tempNodeP.Tag = Trim(tStr(j))
        End If
    Next
Next

End Sub
'初始化表格
Sub initGrid()
Dim i As Long
    '生成目标层表格
    With vLayer(1)
        Load frmMain.TGrid(1)
        Set .Grid = frmMain.TGrid(1)
        CreateGrid .Name, .ContainObj, .Grid
    End With
    '生成各准则层表格
    For i = 2 To TotalGridNum
        With vLayer(i)
            Load frmMain.TGrid(i)
            Set .Grid = frmMain.TGrid(i)
            CreateGrid .Name, .ContainObj, .Grid
        End With
    Next
End Sub
'生成表
Sub CreateGrid(ByVal lName As String, ByVal lContain As String, tempG As MSFlexGrid)
Dim lDim As Long
Dim tStr() As String
Dim tempSRow As String, tempSCol As String, tempS As String
Dim i As Long, j As Long
Dim tS As String
Dim det As Long

det = 6

tempSRow = ""
tempSCol = lName

lDim = CharNum(lContain, vbTab)
tStr() = Split(lContain, vbTab)
'取得表头信息
For i = LBound(tStr) To UBound(tStr)
    If Trim(tStr(i) <> "") Then
        tempSRow = tempSRow + "|" + Trim(tStr(i)) + Space(det)
        tempSCol = tempSCol + "|" + Trim(tStr(i))
    End If
Next
tempSRow = tempSRow + "|^权值" + Space(det + 3)
tempS = tempSRow + ";" + tempSCol

With tempG
    .FormatString = tempS '设置表头信息
    .AllowUserResizing = flexResizeColumns
    .ScrollBars = flexScrollBarBoth
    .FixedCols = 1
    .FixedRows = 1
    .BackColor = &H80000005
    .BackColorBkg = vbWhite
    .BackColorFixed = &H8000000A
    .BackColorSel = &H8000000D
    .Visible = False
    
    For i = 1 To lDim
        .TextMatrix(i, i) = 1 '对角线初始化为1
    Next
End With

End Sub
'进行关系的初步检查
Function CheckRelation() As Boolean
Dim i As Long, j As Long, k As Long, l As Long
Dim tStr() As String, tStrP() As String
Dim TempC As String, tempP As String
Dim Flag As Boolean '是否为准则层C中的元素
Dim FlagInP As Boolean '是否在方案P的集合中

CheckRelation = False

tStr() = Split(Replace(UCase(AssumeText.Text), " ", ""), vbCrLf)

For i = LBound(tStr) To UBound(tStr)
    If Trim(tStr(i)) <> "" Then
        If InStr(1, tStr(i), "]=") <> 0 Then
            TempC = Trim(Mid(tStr(i), InStr(1, tStr(i), "[") + 1, InStr(1, tStr(i), "]=") - InStr(1, tStr(i), "[") - 1))
            Flag = False
            For j = 2 To TotalGridNum
                If vLayer(j).Name = TempC Then
                    Flag = True
                    tempP = Trim(Mid(tStr(i), InStr(1, tStr(i), "]=") + 2, Len(tStr(i)) - (InStr(1, tStr(i), "]=") + 2) + 1))
                    
                    tStrP() = Split(tempP, ",")
                    tempP = ""
                    For k = LBound(tStrP) To UBound(tStrP)
                        FlagInP = False
                        If Trim(tStrP(k)) <> "" Then
                            For l = 1 To pLCount
                                If Trim(tStrP(k)) = vDecP(l).Name Then
                                    FlagInP = True
                                    Exit For
                                End If
                            Next
                            If FlagInP Then
                                tempP = tempP + Trim(tStrP(k)) + vbTab
                            Else
                                Exit Function
                            End If
                        End If
                    Next
                    If tempP <> "" Then
                        If CharNum(tempP, vbTab) < 2 Then
                            MsgBox "每个准则C至少要有2个方案P才行：O!", vbOKOnly + vbInformation, "出错了啦：O"
                            Exit Function
                        End If
                        vLayer(j).ContainObj = tempP
                    Else
                        Exit Function
                    End If
                End If
            Next
            If Not Flag Then
                Exit Function
            End If
        Else
            Exit Function
        End If
    End If
Next

CheckRelation = True

End Function
Private Sub cmdLastStep_Click()
    pBox(1).Visible = False
    pBox(0).Visible = True
    CanNext = True
    CanLast = False
    BtnState
End Sub
Private Sub cmdNextStep_Click()
    
    GetDeclares
    
    pBox(0).Visible = False
    pBox(1).Visible = True
    CanNext = False
    CanLast = True
    CanFinished = True
    BtnState
    AssumeText.Text = GetAssumeText '传递关系字符串
    
End Sub
'得到关系字符串
Function GetAssumeText()
Dim i As Long
Dim s As String
s = ""
For i = 1 To cLCount
    s = s + "[C" + Trim(Str(i)) + "]=" + vbCrLf
Next
GetAssumeText = s
End Function
'得到说明信息
Sub GetDeclares()
Dim i As Long, j As Long
Dim TStrArr() As String

'得到各准则C的说明信息
TStrArr() = Split(DecC.Text, vbCrLf)
For i = 1 To cLCount
    vDecC(i).Name = "C" + Trim(Str(i))
    vDecC(i).Dec = vDecC(i).Name
    For j = LBound(TStrArr) To UBound(TStrArr)
        If InStr(1, TStrArr(j), "C" + Trim(Str(i)) + ":") <> 0 Or _
        (i = j And Trim(TStrArr(i)) <> "") Then
            vDecC(i).Dec = TStrArr(j)
            Exit For
        End If
    Next
Next

'得到各方案P的说明信息
TStrArr() = Split(DecP.Text, vbCrLf)
For i = 1 To pLCount
    vDecP(i).Name = "P" + Trim(Str(i))
    vDecP(i).Dec = vDecP(i).Name
    For j = LBound(TStrArr) To UBound(TStrArr)
        If InStr(1, TStrArr(j), "P" + Trim(Str(i)) + ":") <> 0 Or _
        (i = j And Trim(TStrArr(i)) <> "") Then
            vDecP(i).Dec = TStrArr(j)
            Exit For
        End If
    Next
Next
End Sub
Private Sub Form_Load()
    initFormVar
End Sub
Private Sub valC_Change()
    EnableDec False
End Sub
Private Sub valP_Change()
    EnableDec False
End Sub