### Author Topic: Find the possible route and calculate route length between 2 blocks  (Read 4193 times)

0 Members and 1 Guest are viewing this topic.

#### qdzung

• Guest
##### Find the possible route and calculate route length between 2 blocks
« on: August 15, 2012, 08:25:19 AM »
Hi everybody,

I took a few days to find from Internet but has not answer. I hope some friends would like to help me.

I want to write VBA app for my job. This tool will take out many cables length run through trays.

For example : has 1 tray system, and many cables run between blocks. So how can the Tool can find the possible route and "run" through it.

Can advise me some code to calculate the length from

Block A to Block 1

Block A to Block 2

Block B to Block 1

Block B to Block 2
...

I also send the sample drawing.

Many thanks,

#### dgorsman

• Water Moccasin
• Posts: 2408
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #1 on: August 15, 2012, 10:41:01 AM »
Sounds like the Travelling Salesman problem - one of the classic classroom assignments for algorithm development.
If you are going to fly by the seat of your pants, expect friction burns.

try {GreatPower;}
catch (notResponsible)
finally
{MasterBasics;}

#### qdzung

• Guest
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #2 on: August 15, 2012, 10:53:59 AM »
thank you guy
But now I don't know how to "Find the way from A to 1", while they are connected by many lines, which has many cross point. After found some ways, we can calculate the length throuth lines
So could you advise me some example code

#### Lee Mac

• Seagull
• Posts: 12351
• London, England
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #3 on: August 15, 2012, 11:32:05 AM »
Consider using Dijkstra's algorithm, where the 'weights' for each path would be the length of the line segment.

#### qdzung

• Guest
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #4 on: August 15, 2012, 11:41:32 AM »
Thank you very much Lee I will try

#### qdzung

• Guest
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #5 on: August 16, 2012, 04:11:16 AM »
I found code from Mr CAB, could anybody help me to "translate it" to VBA
http://www.theswamp.org/index.php?topic=1749.msg22949#msg22949
Code: [Select]
`;;  ***************************************************************;;   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...;;;;;;  ***************************************************************;;===================================;;      -=<  Sub Routines  >=-       ;;===================================;;  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 elist  ss     ssres  i      e      e2                    found  ent    ent2   ok     start  end    start2 end2                    fuzz   layer  ssex   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          ;;========================`

#### fixo

• Guest
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #6 on: August 20, 2012, 07:11:01 AM »
Try this one, assuming this will work with straight segments only,
not treated on your drawing, just I've grab them from my old codes
Code: [Select]
`Option Explicit''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''Public Sub blockPath()Dim oSset As AcadSelectionSetDim pt As VariantDim blk1 As AcadBlockReferenceDim blk2 As AcadBlockReferenceDim ent As AcadEntity, ent1 As AcadEntity, ent2 As AcadEntityDim ft(0) As IntegerDim fd(0) As Variantft(0) = 0: fd(0) = "lwpolyline"ThisDrawing.Utility.GetEntity ent1, pt, vbCrLf & "Select First Block:"If Not TypeOf ent1 Is AcadBlockReference ThenExit SubEnd IfSet blk1 = ent1Dim verts1() As Doubleverts1 = BoundingBoxTest(ent1)Dim PointsList1(0 To 11) As DoubleDim cnt, icnt = 0For 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 + 3NextThisDrawing.Utility.GetEntity ent2, pt, vbCrLf & "Select Second Block:"If Not TypeOf ent2 Is AcadBlockReference ThenExit SubEnd IfSet blk2 = ent2Dim verts2() As Doubleverts2 = BoundingBoxTest(ent2)Dim PointsList2(0 To 11) As Doublecnt = 0For 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 + 3NextThisDrawing.Utility.GetEntity ent, pt, vbCrLf & "Select main polyline:"If Not TypeOf ent Is AcadLWPolyline ThenExit SubEnd IfDim mpoly As AcadLWPolylineSet mpoly = ent               With ThisDrawing.SelectionSets               While .Count > 0                    .Item(0).Delete               Wend          End With     With ThisDrawing.SelectionSets          Set oSset = .Add("\$PolySet\$")     End WithDim mode As Integermode = acSelectionSetCrossingPolygonoSset.SelectByPolygon mode, PointsList1, ft, fdDim pline1 As AcadLWPolylineSet 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 WithoSset.SelectByPolygon mode, PointsList2, ft, fdDim pline2 As AcadLWPolylineSet ent = oSset.Item(0)Set pline2 = entDim intpts1 As VariantDim jintpts1 = pline1.IntersectWith(mpoly, acExtendNone)Dim inspt1(0 To 2) As DoubleIf 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 IfDim intpts2 As Variantintpts2 = pline2.IntersectWith(mpoly, acExtendNone)j = 0Dim inspt2(0 To 2) As DoubleIf 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 IfDim leg As Doubleleg = Distance(inspt1, inspt2)MsgBox "Common Length: " & vbCr & CStr(leg + pline1.Length + pline2.Length)End SubPrivate Function BoundingBoxTest(oEnt As AcadEntity) As Double()Dim MaxPoint As VariantDim MinPoint As VariantDim Vertices(0 To 3, 0 To 2) As DoubleoEnt.GetBoundingBox MinPoint, MaxPointVertices(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 = VerticesEnd FunctionPrivate 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 = cDistEnd Function''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''`
~'J'~

#### qdzung

• Guest
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #7 on: August 23, 2012, 01:35:53 AM »
thank you, Sir

#### fixo

• Guest
##### Re: Find the possible route and calculate route length between 2 blocks
« Reply #8 on: August 29, 2012, 04:06:59 PM »
You're welcome,
Cheers

~'J'~