Topic: BlockAtVertices

[pedroantonio]

Hi i am using BlockAtVertices.lsp. But i need to do 2 changes .
1) When i have a close polyline puts me 2 points in fist vertex because the fist and the last vertex are same. I want to have one block (only for the close polylines the first and the last vertex to have one block)

2)I use annotated attribute blocks. When this routine insert the points convert my blocks to a new block so i can not channge them.I want to insert them as attribute blocks

Code - Auto/Visual Lisp: [Select]

1.  
2. ;;-----------------=={ Block At Vertices }==------------------;;
3. ;; ;;
4. ;; Inserts a Block at each vertex of selected Polylines, ;;
5. ;; rotated to the angle of the segment following the vertex. ;;
6. ;;------------------------------------------------------------;;
7. ;; Author: Lee McDonnell, 2010 ;;
8. ;; ;;
9. ;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
10. ;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
11. ;;------------------------------------------------------------;;
12.  
13. (defun c:BlockAtVertices ( / *error* _StartUndo _EndUndo _Insert _AngleAtParam doc block ss )
14. (vl-load-com)
15. ;; © Lee Mac 2010
16.  
17. (setq block "AnnotPoint.dwg") ;; << Block Name
18.  
19. (defun *error* ( msg )
20. (and doc (_EndUndo doc))
21. (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
22. (princ (strcat "\n** Error: " msg " **")))
23. (princ)
24. )
25.  
26. (defun _StartUndo ( doc ) (_EndUndo doc)
27. (vla-StartUndoMark doc)
28. )
29.  
30. (defun _EndUndo ( doc )
31. (if (= 8 (logand 8 (getvar 'UNDOCTL)))
32. (vla-EndUndoMark doc)
33. )
34. )
35.  
36. (defun _Insert ( block point rotation )
37. (entmakex
38. (list
39. (cons 0 "INSERT")
40. (cons 2 block)
41. (cons 10 point)
42. (cons 50 rotation)
43. (cons 41 1.0) ;; X Scale
44. (cons 42 1.0) ;; Y Scale
45. (cons 43 1.0) ;; Z Scale
46. )
47. )
48. )
49.  
50. (defun _AngleatParam ( entity param )
51. (angle '(0. 0. 0.) (vlax-curve-getFirstDeriv entity param))
52. )
53.  
54. (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
55.  
56. (cond
57. ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
58.  
59. (princ "\n** Current Layer Locked **")
60. )
61. ( (not
62. (or
63. (and (tblsearch "BLOCK" (vl-filename-base block))
64. (setq block (vl-filename-base block))
65. )
66. (and
67. (setq block
68. (findfile
69. (strcat block
70. (if (eq "" (vl-filename-extension block)) ".dwg" "")
71. )
72. )
73. )
74. (
75. (lambda ( / ocm )
76. (setq ocm (getvar 'CMDECHO)) (setvar 'CMDECHO 0)
77. (command "_.-insert" block) (command)
78. (setvar 'CMDECHO ocm)
79.  
80. (tblsearch "BLOCK" (setq block (vl-filename-base block)))
81. )
82. )
83. )
84. )
85. )
86.  
87. (princ "\n** Block not Found **")
88. )
89. ( (not (setq ss (ssget '((0 . "*POLYLINE")))))
90.  
91. (princ "\n*Cancel*")
92. )
93. (t
94.  
95. (_StartUndo doc)
96.  
97. (
98. (lambda ( i / e )
99. (while (setq e (ssname ss (setq i (1+ i))))
100. (
101. (lambda ( param end )
102. (while (<= (setq param (1+ param)) end)
103. (_Insert block (vlax-curve-getPointatParam e param) (_AngleAtParam e param))
104. )
105. )
106. (1- (vlax-curve-getStartParam e)) (vlax-curve-getEndParam e)
107. )
108. )
109. )
110. -1
111. )
112.  
113. (_EndUndo doc)
114. )
115. )
116.  
117. (princ)
118. )
119.  
120.  

[ronjonp]

If you don't want it to insert 2 blocks at start and end point, you could use something like this to check if the objects is closed.

Code - Auto/Visual Lisp: [Select]

1. (defun _fuzzyclosed (ename fuzz)
2.   (equal (vlax-curve-getstartpoint ename) (vlax-curve-getendpoint ename) fuzz)
3. )

Then iterate (1- (vlax-curve-getendparam e)) if the object is closed.

[pedroantonio]

Is it possible to understand the overlap polylines and not insert blocks in the same points ?

[ronjonp]

Just maintain a list of processed points .. if it's in the list skip else place the block.

[Grrr1337]

Just maintain a list of processed points ..

Here are 2 similair iterative suggestions:

Code: [Select]

; Unique point list - iterative
(defun UqpL ( fuzz pL / L p )
  (while pL
    (setq p (car pL))
    (if (or (null L) (not (vl-some '(lambda (x) (equal x p fuzz)) L))) (setq L (cons p L)) )
    (setq pL (cdr pL))
  ); while
  (reverse L)
); defun UqpL

; Unique point list - iterative
(defun UqpL ( fuzz pL / L p )
  (while pL
    (setq p (car pL))
    (or (vl-some '(lambda (x) (equal x p fuzz)) (cdr pL)) (setq L (cons p L)) )
    (setq pL (cdr pL))
  ); while
  (reverse L)
); defun UqpL
I also tried recursively, but was not successful - since It requires building and checking the new list at the same time 

[Lee Mac]

Others: http://lee-mac.com/uniqueduplicate.html

[Grrr1337]

Others: http://lee-mac.com/uniqueduplicate.html

Nice Lee,
I've forgot that you had these (I only and always used the LM:Unique).

[ronjonp]

Another offering:

Code - Auto/Visual Lisp: [Select]

1. (defun uqpl1 (pl fuzz / l p)
2.   (while (setq p (car pl))
3.     (setq pl (vl-remove-if (function (lambda (x) (equal x p fuzz))) pl))
4.     (setq l (cons p l))
5.   )
6.   (reverse l)
7. )