|
以下程序是32位的,在64位机器上运行不了,不知道怎么更改,求大师帮忙,程序是12年吕布版主帮忙做的。
Option Explicit
' 要求引用Microsoft Scripting Runtime
Const SIGN_START As String = "【"
Const SIGN_END As String = "】"
Const SIGN_DELIMITER As String = "|"
Function RoadLength(FromA As String, ToB As String, LinesPoints, LinesLength, Optional OP As Integer = 0)
Dim arr, arrLength, arrPathPoints
Dim dic As New Dictionary
Dim dblLength As Double
Dim i As Long
Dim arrResult(1 To 2, 1 To 1)
If FromA = ToB Then
arrResult(1, 1) = FromA & "→" & ToB
arrResult(2, 1) = 0
Else
arr = LinesPoints
For i = LBound(arr) To UBound(arr)
If Not dic(arr(i, 1)) Like "*" & SIGN_START & arr(i, 2) & SIGN_END & "*" Then
dic(arr(i, 1)) = dic(arr(i, 1)) & SIGN_DELIMITER & SIGN_START & arr(i, 2) & SIGN_END
End If
If Not dic(arr(i, 2)) Like "*" & arr(i, 1) & SIGN_END & "*" Then
dic(arr(i, 2)) = dic(arr(i, 2)) & SIGN_DELIMITER & SIGN_START & arr(i, 1) & SIGN_END
End If
Next i
arrResult(1, 1) = Road(FromA, ToB, dic, False)
If Len(arrResult(1, 1)) > 0 And Right(arrResult(1, 1), 1) = "→" Then arrResult(1, 1) = ""
If Len(arrResult(1, 1)) > 0 Then
dic.RemoveAll
arrLength = LinesLength
For i = LBound(arr) To UBound(arr)
dic(arr(i, 2) & "→" & arr(i, 1)) = arrLength(i, 1)
dic(arr(i, 1) & "→" & arr(i, 2)) = arrLength(i, 1)
Next i
arrPathPoints = VBA.Split(arrResult(1, 1), "→")
For i = LBound(arrPathPoints) To UBound(arrPathPoints) - 1
dblLength = dblLength + dic(arrPathPoints(i) & "→" & arrPathPoints(i + 1))
Next i
arrResult(2, 1) = dblLength
Else
arrResult(2, 1) = 0
End If
End If
Select Case OP
Case 0
RoadLength = arrResult
Case 1
RoadLength = arrResult(1, 1)
Case Else
RoadLength = arrResult(2, 1)
End Select
End Function
Private Function Road(ByVal FromA As String, ByVal ToB As String, dicChild As Dictionary, ByRef bStop As Boolean)
Dim vArr As Variant
Dim arrTmp
Dim arrConPoints
Dim i As Long, j As Long, lCount As Long
Dim vDicKey, vDicItem, vItem
Dim dic As Dictionary
Dim vArrElement
If Not bStop Then
Set dic = New Dictionary
For Each vDicKey In dicChild
If Not (vDicKey = FromA) Then
vDicItem = dicChild(vDicKey)
vDicItem = VBA.Replace(vDicItem, SIGN_DELIMITER & SIGN_START & FromA & SIGN_END, "")
If Len(vDicItem) > 0 Then dic.Add vDicKey, vDicItem
End If
Next vDicKey
vArr = VBA.Split(Mid(dicChild(FromA), 2), SIGN_DELIMITER)
For i = LBound(vArr) To UBound(vArr)
vArrElement = vArr(i)
vArrElement = VBA.Replace(vArrElement, SIGN_START, "")
vArrElement = VBA.Replace(vArrElement, SIGN_END, "")
If vArrElement = ToB Then
Road = FromA & "→" & ToB
bStop = True
Exit For
Else
arrConPoints = VBA.Split(Mid(dicChild(vArrElement), 2), SIGN_DELIMITER)
If IsArray(arrConPoints) Then
If UBound(arrConPoints) = LBound(arrConPoints) Then
ElseIf UBound(arrConPoints) > LBound(arrConPoints) Then
If Not bStop Then Road = FromA & "→" & Road(vArrElement, ToB, dic, bStop)
End If
End If
End If
If bStop Then Exit For
Next i
End If
End Function
|
|