最近插入法（Nearest Insertion）VB源码
Dim SubNode() As Double '子回路，二维数组
Dim RemainNode() As Double '剩余回路，二维数组
Dim SelectNode As Long
Dim LDistance As Double '剩余点与当前点的距离数组
Dim LastNonEmpty As Long
Dim TempNode() As Double
Dim SelectedNodeFromSub As Integer
Dim savemin As Double
Dim tempsubroute() As Double
Dim dis1 As Double
Dim distance As Double
Dim temp As Double
Dim min As Double
ReDim SubNode(1 To Nodes, 1 To 3)
ReDim RemainNode(1 To Nodes - 1, 1 To 3)
'把第一点当作计算的第一点
SubNode(1, 1) = IniNode(1, 1) '把这个点赋给输出结果的第一个点
SubNode(1, 2) = IniNode(1, 2)
SubNode(1, 3) = IniNode(1, 3)
If Nodes = 1 Then GoTo Step1
LastNonEmpty = 0
For j = 2 To Nodes
LastNonEmpty = LastNonEmpty + 1
RemainNode(LastNonEmpty, 1) = IniNode(j, 1)
RemainNode(LastNonEmpty, 2) = IniNode(j, 2)
RemainNode(LastNonEmpty, 3) = IniNode(j, 3)
Next j
For k = 2 To Nodes 'k表示子回路的节点数
'获取第二点
If StopFlag = True Then GoTo CancelCalc
DoEvents
min = 100000000
For i = 1 To Nodes - k + 1 '计算剩余的点到子回路的最近点
For j = 1 To k - 1
LDistance = Sqr((RemainNode(i, 2) - SubNode(j, 2)) ^ 2 + (RemainNode(i, 3) - SubNode(j, 3)) ^ 2)
If LDistance < min Then
min = LDistance
SelectNode = i
End If
Next j
Next i
If k = 2 Then '如果k=2，也就是说子回路只有一点，那么直接把求得的第二点当作子回路的第二点
SubNode(2, 1) = RemainNode(SelectNode, 1)
SubNode(2, 2) = RemainNode(SelectNode, 2)
SubNode(2, 3) = RemainNode(SelectNode, 3)
LastNonEmpty = 0
ReDim TempNode(1 To Nodes - 2, 1 To 3)
For j = 1 To Nodes - 1
If RemainNode(j, 1) <> RemainNode(SelectNode, 1) Then
LastNonEmpty = LastNonEmpty + 1
TempNode(LastNonEmpty, 1) = RemainNode(j, 1)
TempNode(LastNonEmpty, 2) = RemainNode(j, 2)
TempNode(LastNonEmpty, 3) = RemainNode(j, 3)
End If
Next j
ReDim RemainNode(1 To Nodes - 2, 1 To 3)
For i = 1 To Nodes - 2
RemainNode(i, 1) = TempNode(i, 1)
RemainNode(i, 2) = TempNode(i, 2)
RemainNode(i, 3) = TempNode(i, 3)
Next
Else '如果不是第一点，计算得到的点到子回路的最小节省距离
'************************************************'剩下最后一点，直接赋值
If k = Nodes Then
ReDim TempNode(1 To Nodes, 1 To 3)
For j = 1 To Nodes - 1
TempNode(j, 1) = SubNode(j, 1)
TempNode(j, 2) = SubNode(j, 2)
TempNode(j, 3) = SubNode(j, 3)
Next j
ReDim SubNode(1 To Nodes, 1 To 3)
For i = 1 To Nodes - 1
SubNode(i, 1) = TempNode(i, 1)
SubNode(i, 2) = TempNode(i, 2)
SubNode(i, 3) = TempNode(i, 3)
Next i
SubNode(Nodes, 1) = RemainNode(1, 1)
SubNode(Nodes, 2) = RemainNode(1, 2)
SubNode(Nodes, 3) = RemainNode(1, 3)
GoTo Step1
End If
'************************************************
For i = 1 To k - 2
savemin = 100000000
LDistance = Sqr((SubNode(i, 2) - RemainNode(SelectNode, 2)) ^ 2 + (SubNode(i, 3) - RemainNode(SelectNode, 3)) ^ 2) _
+ Sqr((SubNode(i + 1, 2) - RemainNode(SelectNode, 2)) ^ 2 + (SubNode(i + 1, 3) - RemainNode(SelectNode, 3)) ^ 2) _
- Sqr((SubNode(i, 2) - SubNode(i + 1, 2)) ^ 2 + (SubNode(i, 3) - SubNode(i + 1, 3)) ^ 2)
If LDistance < savemin Then
savemin = LDistance
SelectedNodeFromSub = i
End If
Next i
'************************将选中的点插入到子回路中
ReDim TempNode(1 To k, 1 To 3)
TempNode(SelectedNodeFromSub + 1, 1) = RemainNode(SelectNode, 1)
TempNode(SelectedNodeFromSub + 1, 2) = RemainNode(SelectNode, 2)
TempNode(SelectedNodeFromSub + 1, 3) = RemainNode(SelectNode, 3)
For i = 1 To SelectedNodeFromSub
TempNode(i, 1) = SubNode(i, 1)
TempNode(i, 2) = SubNode(i, 2)
TempNode(i, 3) = SubNode(i, 3)
Next i
For i = SelectedNodeFromSub + 2 To k
TempNode(i, 1) = SubNode(i - 1, 1)
TempNode(i, 2) = SubNode(i - 1, 2)
TempNode(i, 3) = SubNode(i - 1, 3)
Next i
ReDim SubNode(1 To k, 1 To 3)
For i = 1 To k
SubNode(i, 1) = TempNode(i, 1)
SubNode(i, 2) = TempNode(i, 2)
SubNode(i, 3) = TempNode(i, 3)
Next i
'************************************************重新构造剩余的点
LastNonEmpty = 0
ReDim TempNode(1 To Nodes - k, 1 To 3)
For j = 1 To Nodes - k + 1
If RemainNode(j, 1) <> RemainNode(SelectNode, 1) Then
LastNonEmpty = LastNonEmpty + 1
TempNode(LastNonEmpty, 1) = RemainNode(j, 1)
TempNode(LastNonEmpty, 2) = RemainNode(j, 2)
TempNode(LastNonEmpty, 3) = RemainNode(j, 3)
End If
Next j
ReDim RemainNode(1 To Nodes - k, 1 To 3)
For i = 1 To Nodes - k
RemainNode(i, 1) = TempNode(i, 1)
RemainNode(i, 2) = TempNode(i, 2)
RemainNode(i, 3) = TempNode(i, 3)
Next
End If
Next k
Step1:
For i = 1 To Nodes
Debug.Print SubNode(i, 1) & "," & SubNode(i, 2) & "," & SubNode(i, 3)
Next
Picture1.Cls
DoEvents
For i = 1 To Nodes
Picture1.Circle (SubNode(i, 2), SubNode(i, 3)), 40, RGB(0, 0, 255)
Next
For i = 1 To Nodes - 1
Picture1.Line (SubNode(i, 2), SubNode(i, 3))-(SubNode(i + 1, 2), SubNode(i + 1, 3)), RGB(0, 0, 255)
Next
