modtool.bas

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

Attribute VB_Name = "modTool"
Option Explicit
Dim tRow As Long, tCol As Long
Dim SumCol As Double, SumRow As Double, SumW As Double, SumV As Double, SumAw As Double

'返回DStr中SChar字符的个数
Public Function CharNum(ByVal DStr As String, ByVal SChar As String) As Integer
Dim i As Integer
Dim n As Integer
n = 0
For i = 1 To Len(DStr)
    If Mid$(DStr, i, 1) = SChar Then
        n = n + 1
    End If
Next
CharNum = n
End Function
'得到对应矩阵的行列数
Sub GetVarInitVal(tArr() As Double)
    tRow = UBound(tArr(), 1)
    tCol = UBound(tArr(), 2)
End Sub
'方根法
Sub SqrtMethod(tArr() As Double, tW() As Double, tPro As TProperty)
Dim r As Long, C As Long
Dim B() As Double, V() As Double

'GetVarInitVal tArr()

ReDim B(1 To tRow, 1 To tCol) As Double
ReDim V(1 To tRow) As Double
ReDim tW(1 To tRow) As Double

For r = 1 To tRow
    V(r) = 1
    For C = 1 To tCol
        V(r) = tArr(r, C) * V(r)
    Next
    V(r) = V(r) ^ (1 / tRow)
Next

SumV = 0
For r = 1 To tRow
    SumV = SumV + V(r)
Next

'求ω
For r = 1 To tRow
    tW(r) = V(r) / SumV
Next

'下面求Aw
ReDim Aw(1 To tRow) As Double

For r = 1 To tRow
    Aw(r) = 0
    For C = 1 To tCol
        Aw(r) = Aw(r) + tArr(r, C) * tW(C)
    Next
Next

SumAw = 0
For r = 1 To tRow
    SumAw = SumW + Aw(r)
Next

NMax = 0
For r = 1 To tRow
    NMax = NMax + Aw(r) / tW(r)
Next
NMax = NMax / tRow
tPro.vNmax = NMax '最大特征值λmax
End Sub
'幂法
Sub PowerMethod(tArr() As Double, tW() As Double, tPro As TProperty)
Dim i As Long, j As Long, r As Long, C As Long
Dim U() As Double, V() As Double
Dim cycleTimes As Long '幂法循环次数
Dim tmpMax As Double

'GetVarInitVal tArr()

ReDim U(1 To tRow) As Double
ReDim V(1 To tRow) As Double
ReDim tW(1 To tRow) As Double

cycleTimes = 20

For i = 1 To tRow
    U(i) = 1
    V(i) = 1
Next
         
For i = 1 To cycleTimes '幂法循环体
    For r = 1 To tRow
       SumCol = 0
       For C = 1 To tCol
          SumCol = SumCol + tArr(r, C) * U(C) '按行求和
       Next
       V(r) = SumCol
    Next

    '找出v()中的最大值
    tmpMax = 0
    For j = 1 To tRow
       If tmpMax < Abs(V(j)) Then tmpMax = Abs(V(j))
    Next
    
    'u()中每一个元素除以最大值
    For j = 1 To tRow
      U(j) = V(j) / tmpMax
    Next
Next
       
'按列归一化
SumCol = 0
For r = 1 To tRow
  SumCol = SumCol + U(r)
Next
          
'求ω
For r = 1 To tRow
    tW(r) = U(r) / SumCol
Next
       
NMax = 0   '最大特征值，向量组V中的最大值
For i = 1 To tRow
   If NMax < Abs(V(i)) Then NMax = Abs(V(i))
Next
tPro.vNmax = NMax '最大特征值λmax
End Sub
'和积法
Sub SumMethod(tArr() As Double, tW() As Double, tPro As TProperty)
Dim r As Long, C As Long
Dim B() As Double, V() As Double

'GetVarInitVal tArr()

ReDim B(1 To tRow, 1 To tCol) As Double
ReDim V(1 To tRow) As Double
ReDim tW(1 To tRow) As Double

'按列归一化
For C = 1 To tCol
    SumCol = 0
    For r = 1 To tRow
        SumCol = SumCol + tArr(r, C)
    Next

    For r = 1 To tRow
        B(r, C) = tArr(r, C) / SumCol
    Next
Next
'到这里,B就作完了  B是tArr的按列归一化

'下面是按行求和 V
For r = 1 To tRow
    V(r) = 0
    For C = 1 To tCol
        V(r) = V(r) + B(r, C)
    Next
Next

SumW = 0
For r = 1 To tRow
    SumW = SumW + V(r)
Next

' 求ω
For r = 1 To tRow
    tW(r) = V(r) / SumW
Next

'下面求Aw
ReDim Aw(1 To tRow) As Double
For r = 1 To tRow
    Aw(r) = 0
    For C = 1 To tCol
        Aw(r) = Aw(r) + tArr(r, C) * tW(C)
    Next
Next

NMax = 0
For r = 1 To tRow
    NMax = NMax + Aw(r) / tW(r)
Next
NMax = NMax / tRow

tPro.vNmax = NMax '最大特征值λmax

End Sub
'计算当前表格的一系列数值
Sub Calculate(tArr() As Double, tW() As Double, tPro As TProperty, ByVal optInd As Long)
On Error GoTo errH
GetVarInitVal tArr()
'根据不同的方法来算
Select Case optInd
    Case 0  '幂法
        PowerMethod tArr(), tW(), tPro
    Case 1 '方根法
        SqrtMethod tArr(), tW(), tPro
    Case 2 '和积法
        SumMethod tArr(), tW(), tPro
End Select  '已经由以上三种方法求出了最大特征值Nmax

CI = (NMax - tRow) / (tRow - 1)
CR = CI / IIf(RI(tRow) = 0, 0.0000001, RI(tRow))
With tPro
    .vCI = CI
    .vCR = CR
    .vRI = RI(tRow)
    '.vNmax = NMax
End With
Exit Sub
errH:
    ShowUnknownErr
End Sub
'找到P＊在各判断矩阵中的位置
Public Function FindPos(ByVal tP As String, tLayC As TLayer) As Long
Dim i As Long
Dim tS() As String, n As Long

FindPos = 0
n = 0
With tLayC
    tS() = Split(.ContainObj, vbTab)
    For i = LBound(tS()) To UBound(tS())
        If Trim(tS(i)) <> "" Then
            n = n + 1
            If Trim(tS(i)) = tP Then
                FindPos = n
                Exit Function
            End If
        End If
    Next
End With
End Function
'取得文件扩展名
Function GetFileExtendName(ByVal FileName As String) As String
Dim i As Integer
Dim temp As String

For i = 1 To Len(FileName)
    If InStr(1, Right$(FileName, i), ".") <> 0 Then
        temp = Right$(FileName, i - 1)
        Exit For
    Else
        temp = ""
    End If
Next
GetFileExtendName = temp
End Function
'判断文件名是否有效
Public Function AvailFile(ByVal s As String) As Boolean
On Error GoTo errH
Dim Flag As Boolean
Dim fn As Integer
    If Dir$(s) <> "" Then
        AvailFile = True
        Exit Function
    Else
        fn = FreeFile()
        Open s For Append As fn
        Close fn
        AvailFile = True
        Kill s
        Exit Function
    End If
errH:
    AvailFile = False
End Function