frmmain.frm

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

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdNew_Click()
On Error Resume Next
Dim i As Long
    
    If Not First Then
        If MsgBox("新建层次关系会将当前的所有数据清除。真的要新建层次关系吗？", vbYesNo + vbQuestion, "提示信息") = vbNo Then
            Exit Sub
        End If
    End If
    
    TxtCell.Visible = False
    TxtCell.Text = ""
    
    For i = 1 To TotalGridNum
        Unload TGrid(i)
    Next
    For i = 0 To LayerTree.Nodes.Count
        LayerTree.Nodes.Remove (i)
    Next
    
    Frame1.Enabled = False
    cmdShowResult.Enabled = False
    frmAdd.Show vbModal
    
End Sub
'层次总排序表
Private Sub cmdShowResult_Click()
On Error GoTo errH
Dim i As Long, j As Long

Dim rCol() As TFinalResult
ReDim rCol(1 To UBound(vDecC())) As TFinalResult

Dim FinalPro As TProperty 'FinalGrid的一些重要数值

Dim tPArr() As Double  '层次P的总排序数据

Dim tempTxt As String  '用于frmFinal中文本的输出
Dim tempSRow As String, tempSCol As String, tempStr As String
Dim det As Long
Dim TxtGrid As String '用于保存FinalGrid表格中的数据，以便以保存等操作的实现

det = 6
TxtGrid = ""
'检测判断矩阵是否都已经计算完毕
For i = 1 To TotalGridNum
    With vLayer(i)
        For j = 1 To .Grid.Rows - .Grid.FixedRows
            If Trim(.Grid.TextMatrix(j, .Grid.Cols - .Grid.FixedCols)) = "" Then
                MsgBox "请先完成：判断矩阵" + IIf(.Name = "A", "A-C", .Name + "-P") + "权值的计算！", vbOKOnly + vbInformation, "提示信息"
                Exit Sub
            End If
        Next
    End With
Next

'为rCol数组进行赋值处理
For i = LBound(vDecC()) To UBound(vDecC())
    rCol(i).C = vLayer(1).W(i)
    ReDim rCol(i).P(1 To UBound(vDecP())) As Double
    For j = LBound(vDecP()) To UBound(vDecP())
        If FindPos(vDecP(j).Name, vLayer(i + 1)) = 0 Then
            rCol(i).P(j) = 0
        Else
            rCol(i).P(j) = vLayer(i + 1).W((FindPos(vDecP(j).Name, vLayer(i + 1))))
        End If
    Next
Next

'生成层次P的总排序
ReDim tPArr(LBound(vDecP()) To UBound(vDecP())) As Double

tempTxt = "层次P的总排序W:" + vbCrLf

For i = LBound(vDecP()) To UBound(vDecP())
    tPArr(i) = 0
    For j = LBound(vDecC()) To UBound(vDecC())
        tPArr(i) = tPArr(i) + vLayer(1).W(j) * rCol(j).P(i)
    Next
    tempTxt = tempTxt & Format(tPArr(i), "0.00000") & vbCrLf
Next


'总排序的一致性检验
With FinalPro
    .vCI = 0
    .vRI = 0
    For i = 2 To TotalGridNum
        .vCI = .vCI + vLayer(1).W(i - 1) * vLayer(i).Property.vCI
        .vRI = .vRI + vLayer(1).W(i - 1) * vLayer(i).Property.vRI
    Next
    .vCR = .vCI / IIf(.vRI = 0, 0.00000001, .vRI)
    If .vCR > 0.1 Then
        MsgBox "一次性比率CR:" & Format$(.vCR, "0.00000") & ">0.1，不合要求，请调整输入的数据！", vbOKOnly + vbInformation, "CR不合要求"
        Exit Sub
    End If
    
    tempTxt = tempTxt & "一次性指标CI:      " & Format$(.vCI, "0.00000") & vbCrLf
    tempTxt = tempTxt & "随机一次性指标RI:  " & Format$(.vRI, "0.00") & vbCrLf
    tempTxt = tempTxt & "一次性比率CR:      " & Format$(.vCR, "0.00000") & vbCrLf
End With


Load frmFinal
frmFinal.txtOut.Text = tempTxt

'为FinalGrid填写数据
With frmFinal
    tempSRow = ""
    tempSCol = "层次P\层次C"
    
    TxtGrid = tempSCol + vbTab
    
    For i = LBound(vDecC()) To UBound(vDecC())
        tempSRow = tempSRow + "|" + Trim(vDecC(i).Name) + ":" + IIf(Left(Trim(Format$(rCol(i).C, "0.000")), 1) = ".", "0" + Trim(Format$(rCol(i).C, "0.000")), Trim(Format$(rCol(i).C, "0.000")))
        TxtGrid = TxtGrid + Trim(vDecC(i).Name) + ":" + IIf(Left(Trim(Format$(rCol(i).C, "0.000")), 1) = ".", "0" + Trim(Format$(rCol(i).C, "0.000")) + Space(det), Trim(Format$(rCol(i).C, "0.000")) + Space(det)) + vbTab
    Next
        
    For i = LBound(vDecP()) To UBound(vDecP())
        tempSCol = tempSCol + "|" + Trim(vDecP(i).Name)
    Next
    
    tempSRow = tempSRow + "|^层次P的总排序"
    tempStr = tempSRow + ";" + tempSCol
    TxtGrid = TxtGrid + "层次P的总排序" + vbCrLf
    With .FinalGrid
        .FormatString = tempStr
        .AllowUserResizing = flexResizeColumns
        .ScrollBars = flexScrollBarBoth
        .FixedCols = 1
        .FixedRows = 1
        .BackColor = &H80000005
        .BackColorBkg = vbWhite
        .BackColorFixed = &H8000000A
        .BackColorSel = &H8000000D
        '向表格(文本变量)传送数据
        For j = LBound(vDecP()) To UBound(vDecP())
            TxtGrid = TxtGrid + Trim(vDecP(j).Name) + Space(det) + vbTab
            For i = LBound(vDecC()) To UBound(vDecC())
                .TextMatrix(j, i) = Format$(rCol(i).P(j), "0.0000")
                TxtGrid = TxtGrid + .TextMatrix(j, i) + Space(det) + vbTab
            Next
            .TextMatrix(j, .Cols - .FixedCols) = Format$(tPArr(j), "0.0000")
            TxtGrid = TxtGrid + .TextMatrix(j, .Cols - .FixedCols) + Space(det) + vbCrLf
        Next
    End With
End With

frmFinal.txtResult = TxtGrid
frmFinal.Show vbModal
Exit Sub

errH:
    MsgBox "显示层次总排序表时出现错误！", vbOKOnly + vbInformation, "出错了啦：O"
End Sub

Private Sub Command2_Click()
    frmAbout.Show vbModal
End Sub

Private Sub Form_Load()
    initForm
End Sub
'初始化窗体
Sub initForm()
    With txtOutPut
        .Width = pBox.ScaleWidth
    End With
    CurGridIndex = 0
    Option1(0).Value = True
    First = True
    cmdShowResult.Enabled = False
    Frame1.Enabled = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

'单击层次树
Private Sub LayerTree_Click()
On Error GoTo errH
Dim i As Long, j As Long

TGrid_LeaveCell 0

'非P层的表格均认为不可视
If Left(LayerTree.SelectedItem.Tag, 1) <> "P" Then
    For i = 1 To TotalGridNum
        vLayer(i).Grid.Visible = False
    Next
End If

'根据不同的层来显示不同的表格
Select Case Left(LayerTree.SelectedItem.Tag, 1)
    Case "A" '目标层
        vLayer(1).Grid.Visible = True
        CurGridIndex = 1
        txtOutPut.Text = vLayer(1).txtInf
    Case "C" '准则层
        For i = 1 To cLCount
            If LayerTree.SelectedItem.Tag = vLayer(i + 1).Name Then
                vLayer(i + 1).Grid.Visible = True
                CurGridIndex = i + 1
                txtOutPut.Text = vLayer(i + 1).txtInf
                Exit For
            End If
        Next
    Case "P" '方案层
    
End Select

Exit Sub
errH:
    'ShowUnknownErr
End Sub
Private Sub LayerTree_LostFocus()
    TGrid_LeaveCell 0
End Sub
Private Sub Option1_Click(Index As Integer)
    OptIndex = Index
End Sub
'单击当前表格
Private Sub TGrid_Click(Index As Integer)
    TxtCell.Text = ""
    With TGrid(Index)
        CurRow = .Row
        CurCol = .Col
        
        '进行可写入定位操作(人工摸拟的)
        If CurRow <> CurCol And CurCol <> (.Cols - .FixedCols) Then
            '定位
            TxtCell.Top = .Top + .CellTop
            TxtCell.Left = .Left + .CellLeft
            TxtCell.Width = .CellWidth
            TxtCell.Height = .CellHeight
            '写入
            TxtCell.Text = .TextMatrix(CurRow, CurCol)
            TxtCell.SelStart = 0
            TxtCell.SelLength = Len(TxtCell.Text)
            TxtCell.Visible = True
            TxtCell.SetFocus
        Else
            Exit Sub
        End If
    End With
    CurGridIndex = Index
End Sub
'离开当前表格
Private Sub TGrid_LeaveCell(Index As Integer)
On Error GoTo errH
    TxtCell.Visible = False
    TxtCell.Left = -200
    '处理离开表格时的操作
    With TGrid(Index)
        If CurRow <> CurCol And CurCol <> (.Cols - .FixedCols) Then
            .TextMatrix(CurRow, CurCol) = TxtCell.Text
            AutoFill CurRow, CurCol '自动进行数据填写
        Else
            Exit Sub
        End If
    End With
    TxtCell.Text = ""
    CurGridIndex = Index
Exit Sub

errH:
    
End Sub
Private Sub TGrid_RowColChange(Index As Integer)
    With TGrid(Index)
        TxtCell.Top = .Top + .CellTop
        TxtCell.Left = .Left + .CellLeft
        TxtCell.Width = .CellWidth
        TxtCell.Height = .CellHeight
    End With
    CurGridIndex = Index
End Sub
'检验输入数据的合法性
Function CheckData(ByVal r As Long, ByVal C As Long) As Boolean
On Error GoTo errH
Dim temp As Double

CheckData = True
With TGrid(CurGridIndex)
    If Trim(.TextMatrix(r, C)) <> "" Then
        temp = Val(XoYoMathXP.GetExpressionValue(TGrid(CurGridIndex).TextMatrix(r, C)))
        If ((temp < 1 / 9) Or (temp > 9)) Then
            MsgBox "输入的数据错误或超出范围([1/9,9])！", vbOKOnly + vbInformation, "数据输入不合要求"
            .TextMatrix(r, C) = ""
            CheckData = False
            Exit Function
        End If
    End If
End With
Exit Function

errH:
    MsgBox "输入的数据错误或超出范围([1/9,9])！", vbOKOnly + vbInformation, "数据输入不合要求"
    CheckData = False
End Function
'自动填写
Sub AutoFill(ByVal r As Long, ByVal C As Long)
On Error GoTo errH
Dim temp As String

With TGrid(CurGridIndex)
    If CheckData(r, C) Then '数据合法
        If Trim(.TextMatrix(r, C)) <> "" Then
            temp = XoYoMathXP.GetExpressionValue(.TextMatrix(r, C))
            If Val(temp) > 1 Then
                .TextMatrix(r, C) = Trim(Str(Int(Val(temp))))
                .TextMatrix(C, r) = IIf(.TextMatrix(r, C) = "1", "1", "1/" + .TextMatrix(r, C))
            Else
                .TextMatrix(C, r) = Trim(Str(Int(Val(XoYoMathXP.GetExpressionValue("1/(" + .TextMatrix(r, C) + ")")))))
                .TextMatrix(r, C) = IIf(.TextMatrix(C, r) = "1", "1", "1/" + .TextMatrix(C, r))
            End If
        End If
    End If
End With
Exit Sub

errH:
    MsgBox "输入的数据错误或超出范围([1/9,9])！", vbOKOnly + vbInformation, "数据输入不合要求"
End Sub