Topic: How to insert these set of dimensions?

[HasanCAD]

Hi all
I am working on a Roads project.
The task is adding these dimesions
I tried several times to code this lisp but can not
Option one there is itermediate iland and another one is no itermediate island

attached a sample file

Thanks in advance

[Tharwat]

Hi,
This should get you started and would sort the list of coordinates according to the shortest distance to point one ( variable 'p1' ) then you can iterate the coordinates and create the dimensions based on that.

Code - Auto/Visual Lisp: [Select]

1. (and (setq p1 (getpoint "\nSpecify first point :"))
2.      (setq p2 (getpoint "\nNext point :" p1))
3.      (setq ss (ssget "_C" p1 p2 '((0 . "LINE"))))
4.      (repeat (setq i (sslength ss))
5.        (setq pts (cons (vlax-curve-getclosestpointto (ssname ss (setq i (1- i))) p1) pts))
6.      )
7.      (setq pts (vl-sort pts '(lambda (a b) (< (distance p1 a) (distance p1 b))))
8.      )
9. )

[HasanCAD]

This What i ened up to
Created a cad file has a set of dimentions as  3 blocks then insert the block related to number of selected lines
the lisp working good for first selection of lines but the second
Attached the cad file and a screenshoot for the error

Thanks in advance

Code - Auto/Visual Lisp: [Select]

1. (DEFUN C:RoadDimensionInsert ( / ANG BN BOBJ CLYR CNT DIS DISS DOC DTLST LST N1 OBJS OBJVL OSNP P1 P1N P2 PNTS-LST PNTS-LST-1 PNTS-LSTR PNTS-LSTS SPC SSLNGTH X )
2.  
3.     (setq *acad (cond (*acad) ((vlax-get-acad-object))))
4.   (setq doc (vla-get-ActiveDocument (setq *acad (vlax-get-Acad-Object)))
5.         spc (if (zerop (vla-get-activespace doc))
6.               (if (= (vla-get-mspace doc) :vlax-true)
7.                 (vla-get-modelspace doc) (vla-get-paperspace doc))
8.               (vla-get-modelspace doc)))
9.  
10.   (setq uFlag (not (vla-StartUndoMark doc)))
11.   (setq osnp (getvar "osmode"))         (setvar "osmode" 0)
12.   (setq clyr (getvar "CLAYER"))
13.   (setq diss nil)
14.   (setq dtlst nil)
15.  
16.   (if (MakeLayer "TEMP" 8 "Continuous" 0.01 nil 0 "TEMP LAYER")
17.     (progn
18.       (setq clyr (getvar "CLAYER"))
19.       (setvar "CLAYER" "TEMP"))
20.     (setvar "CLAYER" "Defpoints"))
21.   (if (and
22.         (vl-cmdf "_.-insert" "C:/RoadDimension/RoadDimension.dwg" "0,0,0" "1" "1" "0")          ; inser blocks
23.         (tblsearch "BLOCK" "RoadDimension"))
24.     (progn
25.       (vl-cmdf "_.erase" "last" "")
26.       (vl-cmdf "_.-purge" "blocks" "RoadDimension" "n")
27.  
28.       (while (and
29.                (setq p1 (getpoint"\nPick Dimension Point at left side of road "))
30.                ;(setvar "osmode" 128)
31.                (setq p2 (getpoint p1 "\nPick Dimension Point at right side of road")))
32.  
33.       (setq objs (ssget "_C" p1 p2 ))
34.         (cond ( (= 10 (setq SSLngth (sslength objs))) (HSN:10lines)     )
35.               ( (= 8  (setq SSLngth (sslength objs))) (HSN:8lines)      )
36.               ( (= 6  (setq SSLngth (sslength objs))) (HSN:6lines)      )
37.               ( T (alert "\nNo lines selected \nTry to isolate road lines then reuse the lisp"))
38.               )
39.         (setvar "osmode" osnp)
40.         (setvar "CLAYER" clyr)
41.         (setq uFlag (vla-EndUndoMark doc))
42.         ))))
43.  
44. (defun *error* (msg) (and uFlag (vla-EndUndoMark doc)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **")))
45.   (setvar "osmode"      osnp )
46.   (setvar "cmdecho"     cmd )
47.   (princ)
48. )
49.  
50. (defun HSN:10lines ( / )
51.   (repeat (setq cnt (sslength objs))
52.     (setq objVL (vlax-ename->vla-object (ssname objs (setq cnt (1- cnt)))))
53.     (setq p1n (vlax-curve-getclosestpointto objVL p1))
54.     (setq dtlst (cons p1n dtlst))
55.     (setq dis (distance p1 p1n ))
56.     (setq diss (cons dis diss))
57.     )
58.   (setq lst (gc:sort diss <))
59.   (setq n1 (nth 0 lst))
60.   (setq lst (mapcar '(lambda (x) (- x n1)) lst))
61.   (setq lst (vl-remove (nth 0 lst) lst))
62.  
63.   (setq pnts-lst (SortPointList 'XYZ 1e-3 < < < dtlst))
64.   (setq pnts-lstS (vl-remove (nth 0 pnts-lst) pnts-lst))
65.   (setq pnts-lstR (reverse  pnts-lst))
66.   (setq pnts-lst-1 (nth 0 pnts-lst ))
67.   (setq ang (angle pnts-lst-1  (nth 0 pnts-lstR )))
68.   (setq bn (strcat "RoadDim-" (itoa SSLngth)))
69.   (vl-catch-all-error-p (setq bobj (vl-catch-all-apply (function vla-InsertBlock) (list spc (vlax-3D-point pnts-lst-1) bn 1.0 1.0 1.0 ang))))
70.   (LM:setdynprops
71.     bobj
72.     (list (cons "0" (nth 0 lst))
73.           (cons "1" (nth 1 lst))
74.           (cons "2" (nth 2 lst))
75.           (cons "3" (nth 3 lst))
76.           (cons "4" (nth 4 lst))
77.           (cons "5" (nth 5 lst))
78.           (cons "6" (nth 6 lst))
79.           (cons "7" (nth 7 lst))
80.           (cons "8" (nth 8 lst))
81.           )
82.     )
83.   (command "_.EXPLODE" "Last")
84.   )
85.  
86. (defun HSN:8lines ( / )
87.   (repeat (setq cnt (sslength objs))
88.     (setq objVL (vlax-ename->vla-object (ssname objs (setq cnt (1- cnt)))))
89.     (setq p1n (vlax-curve-getclosestpointto objVL p1))
90.     (setq dtlst (cons p1n dtlst))
91.     (setq dis (distance p1 p1n ))
92.     (setq diss (cons dis diss))
93.     )
94.   (setq lst (gc:sort diss <))
95.   (setq n1 (nth 0 lst))
96.   (setq lst (mapcar '(lambda (x) (- x n1)) lst))
97.   (setq lst (vl-remove (nth 0 lst) lst))
98.  
99.   (setq pnts-lst (SortPointList 'XYZ 1e-3 < < < dtlst))
100.   (setq pnts-lstS (vl-remove (nth 0 pnts-lst) pnts-lst))
101.   (setq pnts-lstR (reverse  pnts-lst))
102.   (setq pnts-lst-1 (nth 0 pnts-lst ))
103.   (setq ang (angle pnts-lst-1  (nth 0 pnts-lstR )))
104.   (setq bn (strcat "RoadDim-0" (itoa SSLngth)))
105.   (vl-catch-all-error-p (setq bobj (vl-catch-all-apply (function vla-InsertBlock) (list spc (vlax-3D-point pnts-lst-1) bn 1.0 1.0 1.0 ang))))
106.   (LM:setdynprops
107.     bobj
108.     (list (cons "0" (nth 0 lst))
109.           (cons "1" (nth 1 lst))
110.           (cons "2" (nth 2 lst))
111.           (cons "3" (nth 3 lst))
112.           (cons "4" (nth 4 lst))
113.           (cons "5" (nth 5 lst))
114.           (cons "6" (nth 6 lst))
115.           )
116.     )
117.   (command "_.EXPLODE" "Last")
118.   )
119. (defun HSN:6lines ( / )
120.   (repeat (setq cnt (sslength objs))
121.     (setq objVL (vlax-ename->vla-object (ssname objs (setq cnt (1- cnt)))))
122.     (setq p1n (vlax-curve-getclosestpointto objVL p1))
123.     (setq dtlst (cons p1n dtlst))
124.     (setq dis (distance p1 p1n ))
125.     (setq diss (cons dis diss))
126.     )
127.   (setq lst (gc:sort diss <))
128.   (setq n1 (nth 0 lst))
129.   (setq lst (mapcar '(lambda (x) (- x n1)) lst))
130.   (setq lst (vl-remove (nth 0 lst) lst))
131.  
132.   (setq pnts-lst (SortPointList 'XYZ 1e-3 < < < dtlst))
133.   (setq pnts-lstS (vl-remove (nth 0 pnts-lst) pnts-lst))
134.   (setq pnts-lstR (reverse  pnts-lst))
135.   (setq pnts-lst-1 (nth 0 pnts-lst ))
136.   (setq ang (angle pnts-lst-1  (nth 0 pnts-lstR )))
137.   (setq bn (strcat "RoadDim-0" (itoa SSLngth)))
138.   (vl-catch-all-error-p (setq bobj (vl-catch-all-apply (function vla-InsertBlock) (list spc (vlax-3D-point pnts-lst-1) bn 1.0 1.0 1.0 ang))))
139.   (LM:setdynprops
140.     bobj
141.     (list (cons "0" (nth 0 lst))
142.           (cons "1" (nth 1 lst))
143.           (cons "2" (nth 2 lst))
144.           (cons "3" (nth 3 lst))
145.           (cons "4" (nth 4 lst))
146.           )
147.     )
148.   (command "_.EXPLODE" "Last")
149.   )
150.  
151. ;; Set Dynamic Block Properties  -  Lee Mac
152. ;; Modifies values of Dynamic Block properties using a supplied association list.
153. ;; blk - [vla] VLA Dynamic Block Reference object
154. ;; lst - [lst] Association list of ((<Property> . <Value>) ... )
155. ;; Returns: nil
156. (defun LM:setdynprops (blk lst / itm x)
157.   (setq lst (mapcar '(lambda (x) (cons (strcase (car x)) (cdr x))) lst))
158.   (foreach x (vlax-invoke blk 'getdynamicblockproperties)
159.     (if (setq itm (assoc (strcase (vla-get-propertyname x)) lst))
160.       (vla-put-value
161.         x
162.         (vlax-make-variant
163.           (cdr itm)
164.           (vlax-variant-type (vla-get-value x)) )      )    )  ))
165. ; END DEFUN - LM:setdynprops
166.  
167. (defun SortPointList (fA fz dx dy dz pL / fp f)
168.   (if
169.     (and
170.       (setq fp
171.              (cadr
172.                (assoc fA
173.                       (list
174.                         (list 'XYZ
175.                               (lambda (a b c)
176.                                 (if a
177.                                   (if b
178.                                     (if c
179.                                       (dz z1 z2)
180.                                       (dz z1 z2)                                    )
181.                                     (dy y1 y2)                            )
182.                                   (dx x1 x2)                            )                             )                 )
183.                         (list 'XZY
184.                               (lambda (a b c)
185.                                 (if a
186.                                   (if c
187.                                     (if b
188.                                       (dy y1 y2)
189.                                       (dy y1 y2)                                    )
190.                                     (dz z1 z2)                            )
191.                                   (dx x1 x2)    )       )                       )
192.                         (list 'YXZ
193.                               (lambda (a b c)
194.                                 (if b
195.                                   (if a
196.                                     (if c
197.                                       (dz z1 z2)
198.                                       (dz z1 z2)                                    )
199.                                     (dx x1 x2)                            )
200.                                   (dy y1 y2)    )      )                        )
201.                         (list 'YZX
202.                               (lambda (a b c)
203.                                 (if b
204.                                   (if c
205.                                     (if a
206.                                       (dx x1 x2)
207.                                       (dx x1 x2)                                    )
208.                                     (dz z1 z2)                            )
209.                                   (dy y1 y2)    )       )                       )
210.                         (list 'ZXY
211.                               (lambda (a b c)
212.                                 (if c
213.                                   (if a
214.                                     (if b
215.                                       (dy y1 y2)
216.                                       (dy y1 y2)                                    )
217.                                     (dx x1 x2)                            )
218.                                   (dz z1 z2)    )       ) )
219.                         (list 'ZYX
220.                               (lambda (a b c)
221.                                 (if c
222.                                   (if b
223.                                     (if a
224.                                       (dx x1 x2)
225.                                       (dx x1 x2)                                    )
226.                                     (dy y1 y2)                            )
227.                                   (dz z1 z2)    )       ) )                   )                )     )        )                        
228.       (setq f                  
229.              (lambda (p1 p2 / x1 y1 z1 x2 y2 z2 a b c)                         
230.                (mapcar 'set '(x1 y1 z1) p1)
231.                (mapcar 'set '(x2 y2 z2) p2)                            
232.                (mapcar 'set '(a b c)  (mapcar (function (lambda (a b) (equal a b fz))) p1 p2)       )
233.                (fp a b c)            )                )     )                          
234.      (vl-sort pL (function f))    ))                                    ; defun SortPointList
235.  
236.  
237. (defun gc:sort (lst fun / merge tmp)
238.   (defun merge (l1 l2)
239.     (cond      ((null l1) l2)      ((null l2) l1)
240.       ((fun (car l1) (car l2)) (cons (car l1) (merge (cdr l1) l2)))
241.       (T (cons (car l2) (merge l1 (cdr l2))))))
242.  
243.   (setq fun (eval fun)  lst (mapcar 'list lst))
244.   (while (cdr lst)
245.     (setq tmp lst lst nil)
246.     (while (cdr tmp)
247.       (setq lst (cons (merge (car tmp) (cadr tmp)) lst)
248.             tmp (cddr tmp)))
249.     (and tmp (setq lst (cons (car tmp) lst))))
250.   (car lst))
251.  
252.  
253. (defun MakeLayer ( name colour linetype lineweight willplot bitflag description )
254.   (regapp "AcAecLayerStandard")
255.     ;; (MakeLayer name colour linetype lineweight willplot bitflag description )
256.     ;; Specifications:
257.     ;; Description        Data Type        Remarks
258.     ;; ---------------------------------------------------------------------------------
259.     ;; Layer Name          STRING          Only standard chars allowed                 
260.     ;; Layer Colour        INTEGER         may be nil, -ve for Layer Off, Colour < 256 
261.     ;; Layer Linetype      STRING          may be nil, If not loaded, CONTINUOUS.      
262.     ;; Layer Lineweight    REAL            may be nil, 0 <= x <= 2.11                  
263.     ;; Plot?               BOOLEAN         T = Plot Layer, nil otherwise               
264.     ;; Bit Flag            INTEGER         0=None, 1=Frozen, 2=Frozen in VP, 4=Locked  
265.     ;; Description         STRING          may be nil for no description               
266.     ;; Function will return list detailing whether layer creation is successful.       
267.  
268.     ;; © Lee Mac 2010
269.   (or (tblsearch "LAYER" name)
270.     (entmake
271.       (append
272.         (list
273.           (cons 0       "LAYER")
274.           (cons 100     "AcDbSymbolTableRecord")
275.           (cons 100     "AcDbLayerTableRecord")
276.           (cons 2       name)
277.           (cons 70      bitflag)
278.           (cons 290     (if willplot 1 0))
279.           (cons 6       (if (and linetype (tblsearch "LTYPE" linetype)) linetype "CONTINUOUS"))
280.           (cons 62      (if (and colour (< 0 (abs colour) 256)) colour 7))
281.           (cons 370     (fix (* 100 (if (and lineweight (<= 0.0 lineweight 2.11)) lineweight 0.0))))
282.           )
283.         (if description (list (list -3 (list "AcAecLayerStandard" (cons 1000 "") (cons 1000 description)))))
284.         ))))

[Tharwat]

Hi,
Try the following program and be sure is that the program would select the crossed Line objects only and ignores polylines and I am raising this issue because you already have polyline objects among the lines that represents the road routes as in the above attached sample drawing.

Code - Auto/Visual Lisp: [Select]

1. (defun c:dimroad (/ p1 p2 ss i bkn int pts doc ins ang blk prs bse)
2.   ;;    Tharwat - 02.Mar.2019           ;;
3.   (if
4.     (and
5.       (setq p1 (getpoint "\nSpecify first point :"))
6.       (setq p2 (getpoint "\nNext point :" p1))
7.       (setq ss (ssget "_C" p1 p2 '((0 . "LINE"))))
8.       (setq i (sslength ss))
9.       (if (or (= i 6) (= i 8) (= i 10))
10.         (or (tblsearch "BLOCK"
11.                        (setq bkn (strcat "RoadDim-"
12.                                          (if (= i 10)
13.                                            "10"
14.                                            (strcat "0" (itoa i))
15.                                          )
16.                                  )
17.                        )
18.             )
19.             (alert (strcat "Block name <"
20.                            bkn
21.                            "> not found in current drawing."
22.                    )
23.             )
24.         )
25.         (alert
26.           "Number of collected lines are not equal to 6 or 8 nor to 10"
27.         )
28.       )
29.       (setq int -1)
30.       (repeat i
31.         (setq pts (cons (vlax-curve-getclosestpointto
32.                           (ssname ss (setq i (1- i)))
33.                           p1
34.                         )
35.                         pts
36.                   )
37.         )
38.       )
39.       (setq pts
40.              (vl-sort pts
41.                       '(lambda (a b) (< (distance p1 a) (distance p1 b)))
42.              )
43.       )
44.       (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
45.             ins (last pts)
46.             ang (angle (car pts) ins)
47.       )
48.       (if (and (> ang (* pi 0.5)) (< ang (* pi 1.5)))
49.         (setq ang (+ pi ang))
50.         (setq ins (car pts))
51.       )
52.     )
53.      (progn
54.        (vla-endUndomark doc)
55.        (vla-StartUndoMark doc)
56.        (setq blk (entmakex (list '(0 . "INSERT")
57.                                  (cons 10 ins)
58.                                  (cons 2 bkn)
59.                                  (cons 50 ang)
60.                                  '(41 . 1.0)
61.                                  '(42 . 1.0)
62.                                  '(43 . 1.0)
63.                            )
64.                  )
65.              prs (vlax-invoke
66.                    (vlax-ename->vla-object blk)
67.                    'getdynamicBlockproperties
68.                  )
69.              pts (reverse pts)
70.              bse (car pts)
71.        )
72.        (mapcar
73.          '(lambda (d)
74.             (setq int (1+ int))
75.             (vl-some '(lambda (x)
76.                         (if (= (vla-get-propertyname x) (itoa int))
77.                           (progn (vlax-put x 'Value (distance bse d)) t)
78.                         )
79.                       )
80.                      prs
81.             )
82.           )
83.          (cdr pts)
84.        )
85.        (vla-endUndomark doc)
86.      )
87.   )
88.   (princ)
89. ) (vl-load-com)
90.  
91.  

[HasanCAD]

OK
Thanks for your lisp but whats making my lisp not working.