check_net.bas

一个动态调度的软件

Attribute VB_Name = "checknet"
'检查是不是连通图，返回false表示非连通图，返回true表示连通图
Public Function check_net(ByRef adjoin As Variant) As Boolean
'On Error GoTo errorhandle

u1 = UBound(adjoin, 1)
u2 = UBound(adjoin, 2)

Dim tmp() As Integer
ReDim tmp(0 To u1)
For y = 0 To u1
   tmp(y) = -1
Next

Dim b As Boolean
b = False

Dim k As Integer
k = 0


For j = 0 To u2
    If adjoin(0, j) > 0 And not_in_tmp(j, tmp) = True Then
        tmp(k) = j
        k = k + 1
    End If
Next

   
For L = 0 To u1
  If tmp(L) > 0 Then
     For v = 0 To u2
       If adjoin(tmp(L), v) > 0 And not_in_tmp(v, tmp) = True Then
          tmp(k) = v
          k = k + 1
       End If
     Next
  End If
Next
   
Dim sum As Integer
sum = 0

For n = 0 To u1
   If tmp(n) <> -1 Then
      sum = sum + 1
   End If
Next

If sum < u1 + 1 Then
   check_net = False
Else
   check_net = True
End If
   
Exit Function

errorhandle:
   MsgBox "检查网络图错误:" + Err.Description
   
End Function

'将一个矩阵变成对称矩阵
Public Function make_symmetry(ByRef adjoin As Variant) As Boolean
On Error GoTo errorhandle

u1 = UBound(adjoin, 1)
u2 = UBound(adjoin, 2)

For i = 0 To u1
   For j = i + 1 To u2
      If adjoin(i, j) <> adjoin(j, i) Then
         If adjoin(i, j) > 0 Then
             adjoin(j, i) = adjoin(i, j)
         Else
             adjoin(i, j) = adjoin(j, i)
         End If
      End If
    Next
Next

make_symmetry = True
Exit Function

errorhandle:
   make_symmetry = False
   'MsgBox "生成对称矩阵错误:" + Err.Description

   
End Function


'判断j是否在数组tmp中
Public Function not_in_tmp(ByVal j As Integer, ByRef tmp() As Integer) As Boolean
  u = UBound(tmp, 1)
  
  For i = 0 To u
     If tmp(i) = j Then
       not_in_tmp = False
       Exit Function
     End If
  Next
  
  not_in_tmp = True
  
End Function

'把路径表中的路径读出，放入邻接矩阵中，我删掉了route表中的两个名称字段，因为没有必要，增加入库的负担，
'如果需要查询的话，完全可以建立视图,我已经建立了这个视图 route_node
'读出路径信息，放到邻接矩阵，并把邻接矩阵变成对称矩阵后返回
'函数执行失败返回false,执行成功返回true

Public Function Read_Route_to_Adjoin(ByRef adjoin As Variant) As Boolean

On Error GoTo errorhandle

   Dim route_rs As ADODB.Recordset  '路径信息记录集
   
   Dim sql As String
   '读出状态可用的路径
   sql = "select route_startid,route_endid,route_dis from route where route_state =1"
   
   Call run_sql_needRS(sql, route_rs)
   
   If route_rs.RecordCount = 0 Then
     Read_Route_to_Adjoin = False
     MsgBox "没有路径信息"
     Exit Function
   End If
   
   '读出nodes表中最大的节点编号
   Dim bound As Integer  '存放节点的数量
   Dim node_rs As ADODB.Recordset
   Call run_sql_needRS("select max(nodes_id) max from nodes", node_rs)
   
   If node_rs.RecordCount = 0 Then
     Read_Route_to_Adjoin = False
     Exit Function
   Else
     bound = Val(node_rs!Max)
   End If
   

   '重定义二维数组,存放邻接矩阵
   ReDim adjoin(0 To bound, 0 To bound)

   '初始化adjoin数组,把每个元素都初始化为-1
   For i = 0 To bound
      For j = 0 To bound
         adjoin(i, j) = -1
      Next
   Next
   
   '将路进信息记录集的值覆盖进adjoin
   Dim start, endd, dis As Integer
   Do While Not route_rs.EOF
      start = Val(route_rs!route_startid)  '起点
      endd = Val(route_rs!route_endid)     '终点
      dis = Val(route_rs!route_dis)        '距离
 
      adjoin(start, endd) = dis '覆盖掉原来的-1
      route_rs.MoveNext
   Loop
   
   '将adjoin数组变成对称的
   If make_symmetry(adjoin) = False Then
      Read_Route_to_Adjoin = False
      Exit Function
   End If
   
   Read_Route_to_Adjoin = True
   
   Exit Function
   
    
   
errorhandle:
   Read_Route_to_Adjoin = False
   
End Function