optimumpath.bas

本程序是一个用prim算法寻找最小生成树的小程序。

Attribute VB_Name = "Module1"
Option Explicit
Public n As Long
Public servername As String * 200
Public tindex As Integer, aindex As Integer, nv As Integer, na As Integer, nac As Integer
Public cn As New Connection
Public rs As New ADODB.Recordset
Public Type vertextype
 id As Integer
 px As Integer
 py As Integer
 tex As String
End Type
Public Type arctype
  id As Integer
  sid As Integer
  eid As Integer
  ilink As Integer
End Type
Public Type pat
 fid As Integer
 sid As Integer
 value As Integer
 f As Integer
 End Type
Public pa() As pat   ''''
Public ver() As vertextype
Public arc() As arctype
Public oparc() As arctype
Public koparc() As arctype
Public path() As Integer
Declare Function getcomputername Lib "kernel32" _
   Alias "GetComputerNameA" (ByVal lpbuffer As String, nsize As Long) As Long
Public Function Getsname() As String
Dim i As Integer
n = getcomputername(servername, 512)
Getsname = ""
For i = 1 To 512
  If Mid(servername, i, 1) = vbNullChar Then Exit For
  Getsname = Getsname & Mid(servername, i, 1)
Next i
End Function
Public Function rslen(ByVal rs As Recordset) As Integer
rslen = 0
If rs.EOF And rs.BOF Then Exit Function
While Not rs.EOF
 rslen = rslen + 1
 rs.MoveNext
Wend
rs.MoveFirst
End Function

Public Function loada(ByRef arc() As arctype, ByVal tname As String) As Integer
rs.Open "select * from " & Trim(tname), cn, adOpenKeyset, adLockPessimistic
Dim rl As Integer
rl = rslen(rs)
ReDim arc(rl)
If rl <= 0 Then rs.Close: Exit Function
nac = rl
Dim i As Integer
For i = 1 To rl
 With arc(i)
 .id = rs("id").value
 .eid = rs("eid").value
 .sid = rs("sid").value
 .ilink = rs("ilink").value
 End With
 rs.MoveNext
 Next i
 rs.Close
 loada = rl
End Function
Public Function loadv(ByRef ver() As vertextype, ByVal tname As String) As Integer
rs.Open "select * from  " & Trim(tname), cn, adOpenKeyset, adLockPessimistic
Dim i As Integer, rl As Integer
rl = rslen(rs)
If rl = 0 Then Exit Function
nv = rl
ReDim ver(rl)
For i = 1 To rl
With ver(rs("id").value)
   .id = rs("id").value
   .tex = Str(rs("id").value)
   .px = rs("xp").value
   .py = rs("yp").value
   End With
   rs.MoveNext
 Next i
 rs.Close
loadv = rl
End Function