找到可能的路线并计算2个街区之间的路线长度
大家好，我花了几天时间从网上找到了答案，但还没有答案。我希望一些朋友能帮助我。我想为我的工作编写VBA应用程序。该工具将取出穿过电缆槽的许多电缆长度
例如：有一个电缆槽系统，许多电缆在模块之间运行。那么，该工具如何才能找到可能的路线和；运行“；通过它
可以建议我一些代码来计算从块A到块1的长度，我还发送了示例图
非常感谢，
**** Hidden Message ***** 听起来像是旅行推销员问题——算法开发的经典课堂作业之一。 谢谢你，伙计，但现在我不'；“我不知道怎么做”；找到从A到1的路；，而它们由许多线连接，这些线有许多交叉点。找到一些方法后，我们可以通过直线计算长度；你能给我一些示例代码吗 考虑使用Dijkstra'；s算法，其中'；重量#039；每条路径都是线段的长度。 非常感谢李，我会尽力的 我从CAB先生那里找到了代码，有人能帮我吗；翻译它“；到VBAhttp://www.theswamp.org/index.php?topic=1749.msg22949#msg22949;;***************************************************************
;; pline path finder.lsp
;; Charles Alan Butler 07/08/2004
;; Modified routine to find a path from picked start entity
;; to picked end entity.
;;
;; Returns the first path if it exist else nil, not the shortest path
;; Selects & highlites the path also
;;***************************************************************
;shortcut
(defun c:plp () (c:PlinePath))
;;;***************************************************************
;;; Original Routine
;;;
;;;;; based on Inline.lsp by John Uhden
;;;;; modified Joe Burke 5/15/03
;;;;; pick a line, arc or lwpline
;;;;; creates a selection set of objects which meet end to end
;;;;; only selects objects on the same layer as picked object
;;;;; pass selection set to pedit join...
;;;
;;;***************************************************************
;;===================================
;; -==-
;;===================================
;;Return (ename Startpt Endpt)
(defun @arc (ent / e rp r ba ea p1 p2)
(setq e(cdr (assoc -1 ent))
rp (cdr (assoc 10 ent))
r(cdr (assoc 40 ent))
ba (cdr (assoc 50 ent))
ea (cdr (assoc 51 ent))
p1 (trans (polar rp ba r) e 0)
p2 (trans (polar rp ea r) e 0)
)
(list e p1 p2)
) ;end
;;Return (ename Startpt Endpt)
(defun @line (ent)
(list
(cdr (assoc -1 ent))
(cdr (assoc 10 ent))
(cdr (assoc 11 ent))
)
) ;end
;;Return (ename Startpt Endpt)
(defun @pline (ent / e)
(setq e (cdr (assoc -1 ent)))
(list
e
(car (getends e))
(cadr (getends e))
)
) ;end
;;Add ent-> (ename Startpt Endpt) to list
(defun @list (e / ent)
(setq ent (entget e))
(cond
((= (cdr (assoc 0 ent)) "LINE")
(setq sslist (cons (@line ent) sslist))
)
((= (cdr (assoc 0 ent)) "ARC")
(setq sslist (cons (@arc ent) sslist))
)
((= (cdr (assoc 0 ent)) "LWPOLYLINE")
(setq sslist (cons (@pline ent) sslist))
)
)
) ;end
;;argument: an ename - returns: Start and End points as a list
(defun getends (vobj / name stpt endpt)
(if (= (type vobj) 'ename)
(setq vobj (vlax-ename->vla-object vobj))
)
(and
(setq name (vla-get-objectname vobj))
(cond
((vl-position
name
'("AcDbArc" "AcDbLine" "AcDbEllipse"
"AcDbSpline" "AcDbPolyline" "AcDb2dPolyline"
"AcDb3dPolyline"
)
)
(setq stpt (vlax-curve-getstartpoint vobj))
(setq endpt (vlax-curve-getendpoint vobj))
)
) ;cond
) ;and
(list stpt endpt)
) ;end
;; get list of (ename startpt endpt) for picked ent
(defun get:elst(ent)
(cond
((= (cdr (assoc 0 ent)) "ARC")
(setq ent (@arc ent))
)
((= (cdr (assoc 0 ent)) "LINE")
(setq ent (@line ent))
)
((= (cdr (assoc 0 ent)) "LWPOLYLINE")
(setq ent (@pline ent))
)
)
ent
); end defun
;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
;; main function
;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
(defun c:plinepath (/ sslist elistss ssresi e e2
foundent ent2 ok startend start2 end2
fuzz layerssex typlst
)
;; Get the start object
(if ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
(and
(cadr (ssgetfirst)) ;objects are selected
;;at least one arc, line or pline
(setq ssex (ssget "i" (list (cons 0 "LINE,ARC,LWPOLYLINE"))))
) ;and
;; ======then=============
(setq e (ssname ssex 0))
;; ======else=============
(progn
(sssetfirst)
(setq typlst '("LINE" "ARC" "LWPOLYLINE"))
(while
(or
(not (setq e (car (entsel "\nSelect Starting line, pline or arc: "))))
(not (member (cdr (assoc 0 (entget e))) typlst))
)
(princ "\nMissed pick or wrong object type: ")
) ;while
) ;progn
) ;if^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
;;Get the End object added by CAB
(setq typlst '("LINE" "ARC" "LWPOLYLINE"))
(while
(or
(not (setq e2 (car (entsel "\nSelect Ending line, pline or arc: "))))
(not (member (cdr (assoc 0 (entget e2))) typlst))
)
(princ "\nMissed pick or wrong object type: ")
) ;while
(and
(setq ok 1
fuzz 1e-8 ; 0.00000001
)
(setq ent (entget e)) ; first or picked ent
(setq ent2 (entget e2)) ; second picked ent, CAB
(setq layer (cdr (assoc 8 ent))) ; layer to match
(= layer (cdr (assoc 8 ent2))) ; layers match
(setq ent (get:elst ent)
elist'()
start(cadr ent)
end (caddr ent)
ent2 (get:elst ent2); CAB
start2 (cadr ent2)
end2 (caddr ent2)
)
(setq ss ; get all objects that matched picked
(ssget "X" (list '(0 . "LINE,ARC,LWPOLYLINE") (cons 8 layer)))
)
(ssdel e ss) ; remove picked start from selection set
;;make a list of all from ss((ename startpt endpt) ....)
(setq i 0)
(repeat (sslength ss)
(@list (ssname ss i))
(setq i (1+ i))
) ;repeat
;;CAB revised from here down
;;find attached items, does not test all branches
(@ckpoint start ent sslist)
(if (not found)
(@ckpoint end ent sslist)
)
) ;and
(if found
(progn
(setq elist (cons ent elist))
(setq ssres (ssadd))
(foreach x elist ; creat a selection set of the list
(ssadd (car x) ssres)
)
(prompt "\n*-* Done *-*\n")
(cadr(sssetfirst nil ssres)) ; display the selected items
); progn
(prompt "\n*-* Path not found *-*")
)
) ;end
;; -------------------------------
;;@ckPoint by CAB
;;check the list for matching points
;;p point to match
;;elst (ename startpt endpt) of pt
;;|List list pf remaining elst
(defun @ckpoint( p elst |list / entx ex p1 p2 idx res)
(setq idx (length |List))
(while (and (not found) (>= (setq idx (1- idx)) 0))
(setq entx (nth idx |List)
ex(car entx)
p1(cadr entx)
p2(caddr entx)
)
(cond ; test point match with fuzz factor
((equal p start2 fuzz) ; text for target
(setq found 1)
(setq elist (cons ent2 elist))
)
((equal p end2 fuzz) ; text for target
(setq found 1)
(setq elist (cons ent2 elist))
)
((equal p p1 fuzz) ; test for next branch
(setq res (@ckpoint p2 entx (vl-remove entx |List)))
(if found ; we are backing out collecting the path
(setq elist (cons entx elist))
)
)
((equal p p2 fuzz) ; test for next branch
(setq res (@ckpoint p1 entx (vl-remove entx |List)))
(if found; we are backing out collecting the path
(setq elist (cons entx elist))
)
)
)
); while
T ; return to satisfy AND
); defun
;;========================
;; End Of File
;;========================
试试这个，假设它只适用于直线段；在你的画上没有处理，只有我'；我从我的旧代码中获取它们
Option Explicit
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Public Sub blockPath()
Dim oSset As AcadSelectionSet
Dim pt As Variant
Dim blk1 As AcadBlockReference
Dim blk2 As AcadBlockReference
Dim ent As AcadEntity, ent1 As AcadEntity, ent2 As AcadEntity
Dim ft(0) As Integer
Dim fd(0) As Variant
ft(0) = 0: fd(0) = "lwpolyline"
ThisDrawing.Utility.GetEntity ent1, pt, vbCrLf & "Select First Block:"
If Not TypeOf ent1 Is AcadBlockReference Then
Exit Sub
End If
Set blk1 = ent1
Dim verts1() As Double
verts1 = BoundingBoxTest(ent1)
Dim PointsList1(0 To 11) As Double
Dim cnt, i
cnt = 0
For i = 0 To UBound(verts1, 1)
PointsList1(cnt) = verts1(i, 0)
PointsList1(cnt + 1) = verts1(i, 1)
PointsList1(cnt + 2) = verts1(i, 2)
cnt = cnt + 3
Next
ThisDrawing.Utility.GetEntity ent2, pt, vbCrLf & "Select Second Block:"
If Not TypeOf ent2 Is AcadBlockReference Then
Exit Sub
End If
Set blk2 = ent2
Dim verts2() As Double
verts2 = BoundingBoxTest(ent2)
Dim PointsList2(0 To 11) As Double
cnt = 0
For i = 0 To UBound(verts2, 1)
PointsList2(cnt) = verts2(i, 0)
PointsList2(cnt + 1) = verts2(i, 1)
PointsList2(cnt + 2) = verts2(i, 2)
cnt = cnt + 3
Next
ThisDrawing.Utility.GetEntity ent, pt, vbCrLf & "Select main polyline:"
If Not TypeOf ent Is AcadLWPolyline Then
Exit Sub
End If
Dim mpoly As AcadLWPolyline
Set mpoly = ent
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
End With
With ThisDrawing.SelectionSets
Set oSset = .Add("$PolySet$")
End With
Dim mode As Integer
mode = acSelectionSetCrossingPolygon
oSset.SelectByPolygon mode, PointsList1, ft, fd
Dim pline1 As AcadLWPolyline
Set ent = oSset.Item(0)
Set pline1 = ent
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
End With
With ThisDrawing.SelectionSets
Set oSset = .Add("$PolySet$")
End With
oSset.SelectByPolygon mode, PointsList2, ft, fd
Dim pline2 As AcadLWPolyline
Set ent = oSset.Item(0)
Set pline2 = ent
Dim intpts1 As Variant
Dim j
intpts1 = pline1.IntersectWith(mpoly, acExtendNone)
Dim inspt1(0 To 2) As Double
If VarType(intpts1)vbEmpty Then
For i = LBound(intpts1) To UBound(intpts1)
inspt1(0) = intpts1(j): inspt1(1) = intpts1(j + 1): inspt1(2) = intpts1(j + 2)
i = i + 2
j = j + 3
Next
End If
Dim intpts2 As Variant
intpts2 = pline2.IntersectWith(mpoly, acExtendNone)
j = 0
Dim inspt2(0 To 2) As Double
If VarType(intpts2)vbEmpty Then
For i = LBound(intpts2) To UBound(intpts2)
inspt2(0) = intpts2(j): inspt2(1) = intpts2(j + 1): inspt2(2) = intpts2(j + 2)
i = i + 2
j = j + 3
Next
End If
Dim leg As Double
leg = Distance(inspt1, inspt2)
MsgBox "Common Length: " & vbCr & CStr(leg + pline1.Length + pline2.Length)
End Sub
Private Function BoundingBoxTest(oEnt As AcadEntity) As Double()
Dim MaxPoint As Variant
Dim MinPoint As Variant
Dim Vertices(0 To 3, 0 To 2) As Double
oEnt.GetBoundingBox MinPoint, MaxPoint
Vertices(0, 0) = MinPoint(0)
Vertices(0, 1) = MinPoint(1)
Vertices(0, 2) = MinPoint(2)
Vertices(1, 0) = MaxPoint(0)
Vertices(1, 1) = MinPoint(1)
Vertices(1, 2) = MinPoint(2)
Vertices(2, 0) = MaxPoint(0)
Vertices(2, 1) = MaxPoint(1)
Vertices(2, 2) = MinPoint(2)
Vertices(3, 0) = MinPoint(0)
Vertices(3, 1) = MaxPoint(1)
Vertices(3, 2) = MinPoint(2)
BoundingBoxTest = Vertices
End Function
Private Function Distance(fPoint As Variant, sPoint As Variant) As Double
Dim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double
Dim z1 As Double, z2 As Double
Dim cDist As Double
x1 = sPoint(0): x2 = fPoint(0)
y1 = sPoint(1): y2 = fPoint(1)
z1 = sPoint(2): z2 = fPoint(2)
cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Distance = cDist
End Function
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
~&039；J#039~ 谢谢，先生
你'；再次欢迎，干杯
~'；J#039~
页:
[1]