Author Topic: Help Finding Block Route  (Read 15095 times)

0 Members and 1 Guest are viewing this topic.

Logan

  • Newt
  • Posts: 41
« Last Edit: June 25, 2015, 06:02:42 PM by Kerry »

jvillarreal

  • Bull Frog
  • Posts: 327
Re: Help Finding Block Route
« Reply #46 on: November 05, 2015, 03:06:15 PM »
Gotta thank you again for this excellent routine Ron and YMG..This routine has saved me dozens of hours as well as clicks. I'm using it today to record distances for 1200 runs..Thank you immensely!

ronjonp

  • Needs a day job
  • Posts: 7327
Re: Help Finding Block Route
« Reply #47 on: November 05, 2015, 04:24:20 PM »
Gotta thank you again for this excellent routine Ron and YMG..This routine has saved me dozens of hours as well as clicks. I'm using it today to record distances for 1200 runs..Thank you immensely!
Glad it has helped you out so much!  :)

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

ymg

  • Swamp Rat
  • Posts: 725
Re: Help Finding Block Route
« Reply #48 on: November 05, 2015, 07:10:49 PM »
jvillarreal,

Enhorabuena!,  Glad I could help some.

ymg

thanhduan2407

  • Mosquito
  • Posts: 5
Re: Help Finding Block Route
« Reply #49 on: June 14, 2017, 01:44:53 AM »
I use by ID for Point! However! It is as a little slower
Code: [Select]
(defun C:MinLength (/ ID1 ID2 IDEND IDSTART LISTPOINT LTSID LTSIDFIL LTSIDPNT
     LTSID_EDGE LTSLINE LTSPATH LTSPNT LTSPNTALL OLMODE P1 P2
     PNTEND PNTSTART SSLINE X
    )
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (defun *error* (msg)
    (if Olmode
      (setvar 'osmode Olmode)
    )
    (if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar 'osmode))
  (Alert
    "Qu\U+00E9t ch\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng l\U+00E0 LINE: "
  )
  (setq ssLine (ssget "_:L" (list (cons 0 "LINE"))))
  (if ssLine
    (Progn
      (setvar 'osmode 1)
      (setq PntStart
     (getpoint
       "\nCh\U+1ECDn \U+0111i\U+1EC3m xu\U+1EA5t ph\U+00E1t:  "
     )
      )
      (setq
PntEnd (getpoint
"\nCh\U+1ECDn \U+0111i\U+1EC3m \U+0111\U+1EBFn:  "
       )
      )
      (setq LtsLine (LM:ss->ent ssLine))
      (setq LtsPntAll (list))
      (foreach eLine LtsLine
(setq
  LtsPntAll (append LtsPntAll
    (list (cdr (assoc 10 (entget eLine)))
  (cdr (assoc 11 (entget eLine)))
    )
    )
)
      )
      (setq LtsPnt (SortAB (LM:UniqueFuzz LtsPntAll 1e-6)))
      (setq LtsIDPnt
     (mapcar '(lambda (x) (list (vl-position x LtsPnt) x))
     LtsPnt
     )
      )
      (setq LtsID
     (mapcar '(lambda (x) (vl-position x LtsPnt))
     LtsPnt
     )
      )
      (setq IDStart
     (caar (vl-remove-if-not
     (function
       (lambda (x) (equal PntStart (cadr x) 1e-6))
     )
     LtsIDPnt
   )
     )
      )
      (setq IDEnd
     (caar
       (vl-remove-if-not
(function (lambda (x) (equal PntEnd (cadr x) 1e-6)))
LtsIDPnt
       )
     )
      )
      (setq LtsID_Edge (list))
      (foreach e LtsLine
(setq P1 (cdr (assoc 10 (entget e))))
(setq P2 (cdr (assoc 11 (entget e))))
(setq
  ID1
   (caar (vl-remove-if-not
   (function (lambda (x) (equal P1 (cadr x) 1e-6)))
   LtsIDPnt
)
   )
)
(setq
  ID2
   (caar (vl-remove-if-not
   (function (lambda (x) (equal P2 (cadr x) 1e-6)))
   LtsIDPnt
)
   )
)
(setq LtsID_Edge
       (append
LtsID_Edge
(list
   (list ID1
ID2
(distance (nth ID1 LtsPnt)
   (nth ID2 LtsPnt)
)
   )
)
       )
)
      )
      (setq LtsIDFil (RemoveIDDup LtsID_Edge))
      (setq LtsPath (minpath1 IDStart IDEnd LtsID LtsIDFil))
      (setq listpoint
     (mapcar '(lambda (x) (nth (car x) LtsPnt)) LtsPath)
      )
      (make3dpl listpoint)
    )
    (Alert "Qu\U+00E9t ch\U+1ECDn ch\U+01B0a c\U+00F3 LINE ")
  )
  (setvar 'osmode Olmode)
  (princ)
)



(defun SortAB (lstPnt /)
  (setq
    Lts-Sort (vl-sort
       (vl-sort lstPnt
'(lambda (e1 e2) (< (cadr e1) (cadr e2)))
       )
       '(lambda (e1 e2) (< (car e1) (car e2)))
     )
  )
  Lts-Sort
)
(defun LM:UniqueFuzz (l f)
  (if l
    (cons (car l)
  (LM:UniqueFuzz
    (vl-remove-if
      (function (lambda (x) (equal x (car l) f)))
      (cdr l)
    )
    f
  )
    )
  )
)
;;; (setq L1 (RemoveIDDup (list '(2 4) '(3 4) '(4 2) '(5  2) '(4 3) )))
(defun RemoveIDDup (l)
  (if l
    (cons (car l)
  (RemoveIDDup
    (vl-remove-if
      (function (lambda (x)
  (or (and (= (car x) (car (car l)))
   (= (cadr x) (cadr (car l)))
      )
      (and (= (car x) (cadr (car l)))
   (= (cadr x) (car (car l)))
      )
  )
)
      )
      (cdr l)
    )
  )
    )
  )
)


(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)




(defun make3dpl (ptlst)
  (entmake
    (list
      '(0 . "POLYLINE")
      '(100 . "AcDbEntity")
      '(100
.
"AcDb3dPolyline"
       )
      '(66 . 1)
      '(62 . 3)
      '(10 0.0 0.0 0.0)
      '(70 . 8)
      '(210 0.0 0.0 1.0)
    )
  )
  (foreach pt ptlst
    (entmake
      (list
'(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbVertex")
'(100 . "AcDb3dPolylineVertex")
(cons 10 pt)
'(70 . 32)
      )
    )
  )
  (entmake
    (list
      '(0 . "SEQEND")
      '(100 . "AcDbEntity")
    )
  )
)

(defun minpath1 (g f nodes edges / BRNAME CLNODES CLOSEDL NEW NODNAME
OLD OLDPOS OPENL TOTDIST
)
  (setq nodes (vl-remove g nodes))
  (setq openl (list (list g 0 nil)))
  (setq closedl nil)

  (foreach n nodes
    (setq nodes (subst (list n 0 nil) n nodes))
  )
  (while (not (= (caar closedl) f))
    (setq nodname (caar openl))
    (setq totdist (cadar openl))
    (setq closedl (cons (car openl) closedl))
    (setq openl (cdr openl))
    (setq clnodes (mapcar 'car closedl))
    (foreach e edges
      (progn
(setq brname nil)
(if (= (car e) nodname)
  (setq brname (cadr e))
)
(if (= (cadr e) nodname)
  (setq brname (car e))
)
      )
      (if brname
(progn
  (setq new (list brname (+ (caddr e) totdist) nodname))
  (cond
    ((member brname clnodes))
    ((setq oldpos (vl-position brname (mapcar 'car openl)))
     (setq old (nth oldpos openl))
     (if (< (cadr new) (cadr old))
       (setq openl (subst new old openl))
     )
    )
    (t (setq openl (cons new openl)))
  )
  (setq edges (vl-remove e edges))
)
      )
    )
    (setq
      openl (vl-sort openl
     (function (lambda (a b) (< (cadr a) (cadr b))))
    )
    )
  )
  (setq minpath (list (car closedl)))
  (foreach n closedl
    (if (= (car n) (caddr (car minpath)))
      (setq minpath (cons n minpath))
    )
  )
  minpath
)


[Code]
« Last Edit: June 14, 2017, 02:05:05 AM by thanhduan2407 »