Topic: ---={ Challenge }=--- Selective offset of polygonal pline edges

[ribarm]

Hi all,

I think this is challenge issue, as I think it's pretty hard solvable, and I don't have much experience to play with this, but it would be very useful feature if accomplished... For a start let it be not dynamic, but just like standard offset, you specify distance and side for offset and it'll do just some edges, but be aware that chained edges should be trimmed/extended adequate like it's doing built-in offset command... Maybe I overlooked something, but I don't need pure lisping, I want to say that every method is allowed - using other known and unknown commands, functions etc... If it's not a problem, it's allowed to be used OFFSET built-in command to accomplish similar result, just rename main function name to something like "selectiveoffset" or something... This task should be applicable only for polygonal open/closed pline edges (LWPOLYLINE)... Selected edges should be highlighted or made visible by picking using BLIPMODE = 1, or any other method you think of for creating adequate selection and previewing that selection of edges...

So lets see if it's doable,
I wish you good luck, and happy coding,
Regards, M.R.

[kdub_nz]

If I remember correctly, Gilles has published a routine to do this about 10 years ago.

It Offset and Copied segments of a polyline.

I'd suggest that you won't get much better than that if you can  find it.


added

Try this:
https://www.theswamp.org/index.php?topic=21933.msg266096#msg266096

I'm not sure if it is the latest build.

Regards,

[ribarm]

If I remember correctly, Gilles has published a routine to do this about 10 years ago.

It Offset and Copied segments of a polyline.

I'd suggest that you won't get much better than that if you can  find it.


added

Try this:
https://www.theswamp.org/index.php?topic=21933.msg266096#msg266096

I'm not sure if it is the latest build.

Regards,

Oh, right, I had that one in my library... It seems that it has grown just enough for me to forget what I have in it... Thanks kdub, somehow now when I look at it I very much agree that I don't think I could find much better than that...

Thanks, Gilles...

[ribarm]

I've just analyzed Gilles's code, and I figured out that we should need something more... For instance, when segments are offset, we need to find a way if it's possible to connect those segments (Gilles's resulting plines) with segments that haven't been offset and make final offset with exactly the same number of segment edges like original pline...

I hope you understand new requirements...
M.R.

[ribarm]

Here is my attempt, basically the same as Gilles's code, but just a little larger... And it may return Invalid command sent as input error, but it does what I meant to do...

Code - Auto/Visual Lisp: [Select]

1. ;; OFSEGS -Gilles Chanteau- 2008/03/26
2. ;; Offsets the selected segments of lwpolyline
3. ;; Joined segments are offseted in a single lwpolyline
4. ;; Keeps arcs and widthes
5. ;; Works whatever the current UCS and the pline OCS and elevation
6.  
7. ;; Modified by M.R. -Marko Ribar, d.i.a.- 2017/08/21
8. ;; Changed name of command function to "segsoffset"
9. ;; If possible joines offset segments with unoffset segments
10. ;; forming new pline with exactly the same number of segments like original pline
11.  
12. (defun c:segsoffset ( / *acdoc* ofdist ent pline normal elevat params points side closest par bulge p1 p2 arc_data k paramsall paramsr el ell ss pea li1 li2 )
13.  
14.   (vl-load-com)
15.  
16.   (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
17.   (initget 6 "Through")
18.   (if (setq ofdist
19.              (getdist (strcat "\nSpecify offset distance or [Through] <"
20.                               (if (< (getvar "OFFSETDIST") 0)
21.                                 "Through"
22.                                 (rtos (getvar "OFFSETDIST"))
23.                               )
24.                               "> : "
25.                       )
26.              )
27.       )
28.     (if (= ofdist "Through")
29.       (setvar "OFFSETDIST" -1)
30.       (setvar "OFFSETDIST" ofdist)
31.     )
32.     (setq ofdist (getvar "OFFSETDIST"))
33.   )
34.   (if (and (setq ent (entsel "\nSelect a segment to offset : "))
35.            (setq pline (vlax-ename->vla-object (car ent)))
36.            (= (vla-get-ObjectName pline) "AcDbPolyline")
37.            (setq normal (vlax-get pline 'Normal))
38.            (setq elevat (vla-get-Elevation pline))
39.       )
40.     (progn
41.       (setq k -1)
42.       (repeat (fix (vlax-curve-getendparam pline))
43.         (setq paramsall (cons (setq k (1+ k)) paramsall))
44.       )
45.       (setq paramsall (reverse paramsall))
46.       (setq params (cons (fix (vlax-curve-getParamAtPoint
47.                                 pline
48.                                 (vlax-curve-getclosestpointto pline (trans (cadr ent) 1 0))
49.                               )
50.                          )
51.                          params
52.                    )
53.       )
54.       (HighlightSegment pline (car params))
55.       (while (and (not (initget "X")) (/= (setq ent (entsel "\nSelect next segment or [eXit] : ")) "X"))
56.         (if (and ent (equal (vlax-ename->vla-object (car ent)) pline))
57.           (progn (setq par    (fix (vlax-curve-getParamAtPoint
58.                                      pline
59.                                      (vlax-curve-getclosestpointto pline (trans (cadr ent) 1 0))
60.                                    )
61.                               )
62.                        params (if (member par params)
63.                                 (vl-remove par params)
64.                                 (cons par params)
65.                               )
66.                  )
67.                  (redraw)
68.                  (foreach p params (HighlightSegment pline p))
69.           )
70.         )
71.       )
72.       (if (setq side (getpoint (if (minusp (getvar "OFFSETDIST"))
73.                                  "\nSpecify through point : "
74.                                  "\nSpecify point on side to offset : "
75.                                )
76.                      )
77.           )
78.         (progn
79.           (redraw)
80.           (vla-StartUndoMark *acdoc*)
81.           (setq side    (ilp (trans side 1 0)
82.                              ((lambda (p)
83.                                 (trans (list (car p) (cadr p) (1+ (caddr p)))
84.                                        2
85.                                        0
86.                                 )
87.                               )
88.                                (trans side 1 2)
89.                              )
90.                              (trans (list 0 0 elevat) normal 0)
91.                              normal
92.                         )
93.                 closest (vlax-curve-getClosestPointTo pline side T)
94.                 par     (vlax-curve-getParamAtPoint pline closest)
95.           )
96.           (if (minusp (getvar "OFFSETDIST"))
97.             (setq ofdist (distance side closest))
98.           )
99.           (cond ((equal closest (vlax-curve-getStartPoint pline) 1e-9)
100.                  (setq side (trans side 0 normal))
101.                 )
102.                 ((equal closest (vlax-curve-getEndPoint pline) 1e-9)
103.                  (setq par  (- par 1)
104.                        side (trans side 0 normal)
105.                  )
106.                 )
107.                 ((= (fix par) par)
108.                  (setq
109.                    side (polar
110.                           (trans closest 0 normal)
111.                           ((if (clockwise-p
112.                                  (trans (vlax-curve-getPointAtParam
113.                                           pline
114.                                           (- par 0.1)
115.                                         )
116.                                         0
117.                                         normal
118.                                  )
119.                                  (trans closest 0 normal)
120.                                  (trans (vlax-curve-getPointAtParam
121.                                           pline
122.                                           (+ par 0.1)
123.                                         )
124.                                         0
125.                                         normal
126.                                  )
127.                                )
128.                              +
129.                              -
130.                            )
131.                             (angle
132.                               '(0 0 0)
133.                               (trans (vlax-curve-getFirstDeriv pline par)
134.                                      0
135.                                      normal
136.                                      T
137.                               )
138.                             )
139.                             (/ pi 2)
140.                           )
141.                           ofdist
142.                         )
143.                  )
144.                 )
145.                 (T
146.                  (setq par  (fix par)
147.                        side (trans side 0 normal)
148.                  )
149.                 )
150.           )
151.           (setq bulge (vla-getBulge pline (fix par))
152.                 p1    (trans (vlax-curve-getPointAtParam pline (fix par))
153.                              0
154.                              normal
155.                       )
156.                 p2    (trans (vlax-curve-getPointAtParam pline (1+ (fix par)))
157.                              0
158.                              normal
159.                       )
160.           )
161.           (if (zerop bulge)
162.             (if (clockwise-p side p2 p1)
163.               (setq ofdist (- ofdist))
164.             )
165.             (progn
166.               (setq arc_data (PolyArc-data bulge p1 p2))
167.               (if (minusp bulge)
168.                 (if (< (cadr arc_data) (distance (car arc_data) side))
169.                   (setq ofdist (- ofdist))
170.                 )
171.                 (if (< (distance (car arc_data) side) (cadr arc_data))
172.                   (setq ofdist (- ofdist))
173.                 )
174.               )
175.             )
176.           )
177.           (setq el (entlast) ell el)
178.           (mapcar
179.             (function (lambda (p)
180.                         (vl-catch-all-apply 'vla-Offset (list p ofdist))
181.                         (vla-delete p)
182.                       )
183.             )
184.             (Copysegments pline params)
185.           )
186.           (setq paramsr (vl-remove-if (function (lambda (x) (vl-position x params))) paramsall))
187.           (foreach par paramsr
188.             (Copysegments pline (list par))
189.           )
190.           (setq ss (ssadd))
191.           (while (setq el (entnext el))
192.             (ssadd el ss)
193.           )
194.           (setq pea (getvar 'peditaccept))
195.           (setvar 'peditaccept 1)
196.           (vl-cmdf "_.PEDIT" "_M" ss "" "_J" "_J" "_E" 1e+6)
197.           (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
198.           (setvar 'peditaccept pea)
199.           (setq el (entlast))
200.           (if (/= (vlax-curve-getendparam pline) (vlax-curve-getendparam el))
201.             (while (setq ell (entnext ell))
202.               (entdel ell)
203.             )
204.           )
205.           (if (and el (not (vlax-erased-p el)) (= (vla-get-closed pline) :vlax-false))
206.             (progn
207.               (setq li1 (entmakex (list '(0 . "LINE") (cons 10 (vlax-curve-getstartpoint pline)) (cons 11 (mapcar (function +) (vlax-curve-getclosestpointto el (vlax-curve-getstartpoint pline)) (polar '(0 0) (if (not (equal (vlax-curve-getstartpoint pline) (vlax-curve-getclosestpointto el (vlax-curve-getstartpoint pline)) 1e-6)) (angle (vlax-curve-getstartpoint pline) (vlax-curve-getclosestpointto el (vlax-curve-getstartpoint pline))) (+ (* 0.5 pi) (angle '(0 0) (vlax-curve-getfirstderiv pline (vlax-curve-getstartparam pline))))) 0.01))))))
208.               (setq li2 (entmakex (list '(0 . "LINE") (cons 10 (vlax-curve-getendpoint pline)) (cons 11 (mapcar (function +) (vlax-curve-getclosestpointto el (vlax-curve-getendpoint pline)) (polar '(0 0) (if (not (equal (vlax-curve-getendpoint pline) (vlax-curve-getclosestpointto el (vlax-curve-getendpoint pline)) 1e-6)) (angle (vlax-curve-getendpoint pline) (vlax-curve-getclosestpointto el (vlax-curve-getendpoint pline))) (+ (* 0.5 pi) (angle '(0 0) (vlax-curve-getfirstderiv pline (vlax-curve-getendparam pline))))) 0.01))))))
209.               (entdel (setq pline (vlax-vla-object->ename pline)))
210.               (if (vlax-curve-getpointatparam el (+ (vlax-curve-getparamatpoint el (vlax-curve-getclosestpointto el (cdr (assoc 11 (entget li2))))) 0.1))
211.                 (vl-cmdf "_.TRIM" li1 li2 "" "_non" (trans (vlax-curve-getpointatparam el (+ (vlax-curve-getparamatpoint el (vlax-curve-getclosestpointto el (cdr (assoc 11 (entget li2))))) 0.1)) 0 1) "")
212.               )
213.               (entdel pline)
214.               (if (/= (vlax-curve-getendparam pline) (vlax-curve-getendparam el))
215.                 (progn
216.                   (entdel pline)
217.                   (if (vlax-curve-getpointatparam el (- (vlax-curve-getparamatpoint el (vlax-curve-getclosestpointto el (cdr (assoc 11 (entget li2))))) 0.1))
218.                     (vl-cmdf "_.TRIM" li1 li2 "" "_non" (trans (vlax-curve-getpointatparam el (- (vlax-curve-getparamatpoint el (vlax-curve-getclosestpointto el (cdr (assoc 11 (entget li2))))) 0.1)) 0 1) "")
219.                   )
220.                   (entdel pline)
221.                 )
222.               )
223.               (entdel li1)
224.               (entdel li2)
225.               (if (/= (vlax-curve-getendparam pline) (vlax-curve-getendparam el))
226.                 (while (setq ell (entnext ell))
227.                   (entdel ell)
228.                 )
229.               )
230.             )
231.           )
232.           (vla-EndUndoMark *acdoc*)
233.         )
234.       )
235.     )
236.     (princ "\nInvalid entity.")
237.   )
238.   (princ)
239. )
240.  
241. ;; CopySegments
242. ;; Duplicates polyline segments at the same location
243. ;; Consecutive selected segments are joined
244. ;;
245. ;; Arguments
246. ;; pline : the source polyline (vla-object)
247. ;; params ; the index list of segment to be copied
248. ;;
249. ;; Return
250. ;; the list of created polylines
251.  
252. (defun CopySegments (pline params / nor space tmp copy ret)
253.   (vl-load-com)
254.   (or *acdoc*
255.       (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
256.   )
257.   (setq params (vl-sort params '<)
258.         nor    (vlax-get pline 'Normal)
259.         space  (vla-ObjectIDToObject *acdoc* (vla-get-OwnerID pline))
260.   )
261.   (while params
262.     (setq tmp    (cons (car params) tmp)
263.           params (cdr params)
264.     )
265.     (if (and (zerop (car tmp))
266.              (= (- (vlax-curve-getEndParam pline) 1) (last params))
267.              (equal (vlax-curve-getStartPoint pline)
268.                     (vlax-curve-getEndPoint pline)
269.                     1e-9
270.              )
271.         )
272.       (progn (setq params (reverse params)
273.                    tmp    (cons (car params) tmp)
274.                    params (cdr params)
275.              )
276.              (while (= (car params) (1- (car tmp)))
277.                (setq tmp    (cons (car params) tmp)
278.                      params (cdr params)
279.                )
280.              )
281.              (setq tmp    (reverse tmp)
282.                    params (reverse params)
283.              )
284.       )
285.     )
286.     (while (= (car params) (1+ (car tmp)))
287.       (setq tmp    (cons (car params) tmp)
288.             params (cdr params)
289.       )
290.     )
291.     (setq tmp (reverse (cons (1+ (car tmp)) tmp)))
292.     (setq
293.       pts (vl-remove
294.             nil
295.             (mapcar
296.               (function
297.                 (lambda (pa / pt)
298.                   (if (setq pt (vlax-curve-getPointAtParam pline pa))
299.                     ((lambda (p) (list (car p) (cadr p)))
300.                       (trans pt 0 nor)
301.                     )
302.                   )
303.                 )
304.               )
305.               tmp
306.             )
307.           )
308.     )
309.     (setq copy (vlax-invoke
310.                  space
311.                  'addLightWeightPolyline
312.                  (apply 'append pts)
313.                )
314.     )
315.     (foreach p (cdr (reverse tmp))
316.       (vla-setBulge
317.         copy
318.         (vl-position p tmp)
319.         (vla-getBulge pline p)
320.       )
321.       (vla-getWidth pline p 'swid 'ewid)
322.       (vla-setWidth copy (vl-position p tmp) swid ewid)
323.     )
324.     (foreach prop '(Elevation       Layer           Linetype
325.                     LinetypeGeneration              LinetypeScale
326.                     Lineweight      Normal          Thickness
327.                     TrueColor
328.                    )
329.       (if (vlax-property-available-p pline prop)
330.         (vlax-put copy prop (vlax-get pline prop))
331.       )
332.     )
333.     (setq tmp nil
334.           ret (cons copy ret)
335.     )
336.   )
337. )
338.  
339. ;;======================================================;;
340. ;; HighlightSegment
341. ;; Highlight a polyline segment
342. ;;
343. ;; Arguments
344. ;; pl : the polyline (vla-object)
345. ;; par : the segment index
346.  
347. (defun HighlightSegment (pl par / p1 p2 n lst)
348.   (and
349.     (setq p1 (vlax-curve-getPointAtParam pl par))
350.     (setq p1 (trans p1 0 1))
351.     (setq p2 (vlax-curve-getPointAtParam pl (+ par 1)))
352.     (setq p2 (trans p2 0 1))
353.     (if (zerop (vla-getBulge pl par))
354.       (grvecs (list -1 p1 p2))
355.       (progn (setq n 0)
356.              (repeat 100
357.                (setq lst (cons
358.                            (trans (vlax-curve-getPointAtParam pl (+ n par)) 0 1)
359.                            lst
360.                          )
361.                      n   (+ n 0.01)
362.                )
363.              )
364.              (grvecs
365.                (cons -1 (apply 'append (mapcar 'list lst (cdr lst))))
366.              )
367.       )
368.     )
369.   )
370. )
371.  
372. ;;=====================================================;;
373. ;;; Clockwise-p
374. ;;; Returns T if p1 p2 and p3 are clockwise
375.  
376. (defun clockwise-p (p1 p2 p3)
377.   (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-14)
378. )
379.  
380. ;;========================================================;;
381. ;;; Polyarc-data
382. ;;; Returns a list of the center, radius and angle of a 'polyarc'.
383.  
384. (defun polyarc-data (bu p1 p2 / ang rad cen area cg)
385.   (setq ang (* 2 (atan bu))
386.         rad (/ (distance p1 p2) (* 2 (sin ang)))
387.         cen (polar p1 (+ (angle p1 p2) (- (/ pi 2) ang)) rad)
388.   )
389.   (list cen (abs rad) ang)
390. )
391.  
392. ;;====================================================;;
393. ;;; VXV Returns the dot product of two vectors
394.  
395. (defun vxv (v1 v2) (apply '+ (mapcar '* v1 v2)))
396.  
397. ;;===================================================;;
398. ;;; ILP
399. ;;; Returns the intersection point between a line (extended) and a plane
400. ;;;
401. ;;; Arguments
402. ;;; p1 and p2 : two points defining the line
403. ;;; org : a point on the plane
404. ;;; nor : the plane normal
405.  
406. (defun ilp (p1 p2 org nor / scl)
407.   (setq
408.     scl (/ (vxv nor (mapcar '- p1 org)) (vxv nor (mapcar '- p2 p1)))
409.   )
410.   (mapcar (function (lambda (x1 x2) (+ (* scl (- x1 x2)) x1)))
411.           p1
412.           p2
413.   )
414. )
415.  

M.R.

[gile]

Hi,

Here's the last version published on this page.
It defines 2 commands: OFSEGS (OFfset SEGmentS) and COPSEGS (COPy SEGmentS)

You should have to learn some French...

Code - Auto/Visual Lisp: [Select]

1. ;;; OFSEGS (gile) 26/08/08
2. ;;; Décale les segments de polyligne sélectionnés.
3.  
4. (defun c:ofsegs (/ ofdist   ent      pline    normal   elevat   params
5.                    points   side     closest  par      bulge    p1
6.                    p2       arc_data
7.                   )
8.   (vl-load-com)
9.   (or *acdoc*
10.       (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
11.   )
12.   (initget 6 "Par")
13.   (if (setq
14.         ofdist (getdist
15.                  (strcat "\nSpécifiez la distance de décalage ou [Par] <"
16.                          (if (< (getvar "OFFSETDIST") 0)
17.                            "par"
18.                            (rtos (getvar "OFFSETDIST"))
19.                          )
20.                          ">: "
21.                  )
22.                )
23.       )
24.     (if (= ofdist "Par")
25.       (setvar "OFFSETDIST" -1)
26.       (setvar "OFFSETDIST" ofdist)
27.     )
28.     (setq ofdist (getvar "OFFSETDIST"))
29.   )
30.   (if (and (setq ent (entsel "\nSélectionnez un segment à décaler: "))
31.            (setq pline (vlax-ename->vla-object (car ent)))
32.            (= (vla-get-ObjectName pline) "AcDbPolyline")
33.            (setq normal (vlax-get pline 'Normal))
34.            (setq elevat (vla-get-Elevation pline))
35.       )
36.     (progn
37.       (setq params (cons (fix (vlax-curve-getParamAtPoint
38.                                 pline
39.                                 (trans (osnap (cadr ent) "_nea") 1 0)
40.                               )
41.                          )
42.                          params
43.                    )
44.       )
45.       (HighlightSegment pline (car params))
46.       (while
47.         (setq ent (entsel "\nSélectionnez le segment suivant ou <Quitter>: "))
48.          (if (equal (vlax-ename->vla-object (car ent)) pline)
49.            (progn
50.              (setq par (fix (vlax-curve-getParamAtPoint
51.                               pline
52.                               (trans (osnap (cadr ent) "_nea") 1 0)
53.                             )
54.                        )
55.                    params (if (member par params)
56.                             (vl-remove par params)
57.                             (cons par params)
58.                             )
59.              )
60.              (redraw)
61.              (foreach p params (HighlightSegment pline p))
62.            )
63.          )
64.       )
65.       (if (setq side (GetPointAboutPlane
66.                        normal
67.                        (trans (list 0 0 elevat) normal 0)
68.                        (if (minusp (getvar "OFFSETDIST"))
69.                          "\nSpécifiez une valeur pour \"Par le point\": "
70.                          "\nSpécifiez un point sur le côté à décaler: "
71.                        )
72.                      )
73.           )
74.         (progn
75.           (redraw)
76.           (vla-StartUndoMark *acdoc*)
77.           (setq closest (vlax-curve-getClosestPointTo pline side T)
78.                 par     (vlax-curve-getParamAtPoint pline closest)
79.           )
80.           (if (minusp (getvar "OFFSETDIST"))
81.             (setq ofdist (distance side closest))
82.           )
83.           (cond
84.             ((equal closest (vlax-curve-getStartPoint pline) 1e-9)
85.              (setq side (trans side 0 normal))
86.             )
87.             ((equal closest (vlax-curve-getEndPoint pline) 1e-9)
88.              (setq par  (- par 1)
89.                    side (trans side 0 normal)
90.              )
91.             )
92.             ((= (fix par) par)
93.              (setq side
94.                     (polar
95.                       (trans closest 0 normal)
96.                       ((if
97.                          (clockwise-p
98.                            (trans
99.                              (vlax-curve-getPointAtParam pline (- par 0.1))
100.                              0
101.                              normal
102.                            )
103.                            (trans closest 0 normal)
104.                            (trans
105.                              (vlax-curve-getPointAtParam pline (+ par 0.1))
106.                              0
107.                              normal
108.                            )
109.                          )
110.                           +
111.                           -
112.                        )
113.                         (angle '(0 0 0)
114.                                (trans (vlax-curve-getFirstDeriv pline par)
115.                                       0
116.                                       normal
117.                                       T
118.                                )
119.                         )
120.                         (/ pi 2)
121.                       )
122.                       ofdist
123.                     )
124.              )
125.             )
126.             (T
127.              (setq par  (fix par)
128.                    side (trans side 0 normal)
129.              )
130.             )
131.           )
132.           (setq bulge (vla-getBulge pline (fix par))
133.                 p1    (trans (vlax-curve-getPointAtParam pline (fix par))
134.                              0
135.                              normal
136.                       )
137.                 p2    (trans (vlax-curve-getPointAtParam pline (1+ (fix par)))
138.                              0
139.                              normal
140.                       )
141.           )
142.           (if (zerop bulge)
143.             (if (clockwise-p side p2 p1)
144.               (setq ofdist (- ofdist))
145.             )
146.             (progn
147.               (setq arc_data (PolyArc-data bulge p1 p2))
148.               (if (minusp bulge)
149.                 (if (< (cadr arc_data)
150.                        (distance (car arc_data) side)
151.                     )
152.                   (setq ofdist (- ofdist))
153.                 )
154.                 (if (< (distance (car arc_data) side)
155.                        (cadr arc_data)
156.                     )
157.                   (setq ofdist (- ofdist))
158.                 )
159.               )
160.             )
161.           )
162.           (mapcar
163.             (function
164.               (lambda (p)
165.                 (vl-catch-all-apply 'vla-Offset (list p ofdist))
166.                 (vla-delete p)
167.               )
168.             )
169.             (Copysegments pline params)
170.           )
171.           (vla-EndUndoMark *acdoc*)
172.         )
173.       )
174.     )
175.     (princ "\nEntité non valide.")
176.   )
177.   (princ)
178. )
179.  
180. ;;================================================================;;
181.  
182. ;; COPSEGS (gile) 26/03/08
183. ;; Copie les segments de polyligne sélectionnés.
184.  
185. (defun c:copsegs (/ ent pl par lst)
186.   (vl-load-com)
187.   (if (and (setq ent (entsel "\nSélectionnez un segment à copier: "))
188.            (setq pl (vlax-ename->vla-object (car ent)))
189.            (= (vla-get-ObjectName pl) "AcDbPolyline")
190.       )
191.     (progn
192.       (setq par (fix (vlax-curve-getParamAtPoint
193.                        pl
194.                        (trans (osnap (cadr ent) "_nea") 1 0)
195.                      )
196.                 )
197.             lst (cons par lst)
198.       )
199.       (HighlightSegment pl par)
200.       (while
201.         (setq ent (entsel "\nSélectionnez le segment suivant ou <Quitter>: "))
202.          (if (equal (vlax-ename->vla-object (car ent)) pl)
203.            (progn
204.              (setq par (fix (vlax-curve-getParamAtPoint
205.                               pl
206.                               (trans (osnap (cadr ent) "_nea") 1 0)
207.                             )
208.                        )
209.                    lst (if (member par lst)
210.                          (vl-remove par lst)
211.                          (cons par lst)
212.                          )
213.              )
214.              (redraw)
215.              (foreach p lst (HighlightSegment pl p))
216.            )
217.          )
218.       )
219.       (setq lst (vl-sort lst '<))
220.       (if (setq from (getpoint "\nSpécifiez le point de base: "))
221.         (while (and
222.                  (setq to (vl-catch-all-apply
223.                             'getpoint
224.                             (list from "\nSpécifiez le deuxième point: ")
225.                           )
226.                  )
227.                  (listp to)
228.                )
229.           (mapcar (function (lambda (p)
230.                               (vla-move p
231.                                         (vlax-3d-point (trans from 1 0))
232.                                         (vlax-3d-point (trans to 1 0))
233.                               )
234.                             )
235.                   )
236.                   (CopySegments pl lst)
237.           )
238.         )
239.       )
240.       (redraw)
241.     )
242.     (princ "\nEntité non valide.")
243.   )
244.   (princ)
245. )
246.  
247. ;;================================================================;;
248.  
249.  
250. ;; CopySegments
251. ;; Copie des segments de polyligne
252. ;; Les segments sont copiés à la même place et conservent leurs propriétés
253. ;; Les segments jointifs sont unis en une polyligne unique
254. ;;
255. ;; Arguments
256. ;; pline : la polyligne source (vla-object)
257. ;; params ; la liste des indices des segment à copier
258. ;;
259. ;; Retour
260. ;; la liste des polylignes créées
261.  
262. (defun CopySegments (pline params / nor space tmp copy ret)
263.   (vl-load-com)
264.   (or *acdoc*
265.       (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
266.   )
267.   (setq params (vl-sort params '<)
268.         nor    (vlax-get pline 'Normal)
269.         space  (vla-ObjectIDToObject *acdoc* (vla-get-OwnerID pline))
270.   )
271.   (while params  
272.     (setq tmp    (cons (car params) tmp)
273.           params (cdr params)
274.     )
275.     (if (and (zerop (car tmp))
276.              (= (- (vlax-curve-getEndParam pline) 1) (last params))
277.              (equal (vlax-curve-getStartPoint pline)
278.                     (vlax-curve-getEndPoint pline)
279.                     1e-9
280.              )
281.         )
282.       (progn
283.         (setq params (reverse params)
284.               tmp    (cons (car params) tmp)
285.               params (cdr params)
286.         )
287.         (while (= (car params) (1- (car tmp)))
288.           (setq tmp    (cons (car params) tmp)
289.                 params (cdr params)
290.           )
291.         )
292.         (setq tmp    (reverse tmp)
293.               params (reverse params)
294.         )
295.       )
296.     )
297.     (while (= (car params) (1+ (car tmp)))
298.       (setq tmp    (cons (car params) tmp)
299.             params (cdr params)
300.       )
301.     )
302.     (setq tmp (reverse (cons (1+ (car tmp)) tmp)))
303.     (setq
304.       pts
305.        (vl-remove nil
306.                   (mapcar
307.                     (function
308.                       (lambda (pa / pt)
309.                         (if (setq pt (vlax-curve-getPointAtParam pline pa))
310.                           ((lambda (p)
311.                              (list (car p) (cadr p))
312.                            )
313.                             (trans pt 0 nor)
314.                           )
315.                         )
316.                       )
317.                     )
318.                     tmp
319.                   )
320.        )
321.     )
322.     (setq copy
323.            (vlax-invoke
324.              space
325.              'addLightWeightPolyline
326.              (apply 'append pts)
327.            )
328.     )
329.     (foreach p (cdr (reverse tmp))
330.       (vla-setBulge
331.         copy
332.         (vl-position p tmp)
333.         (vla-getBulge pline p)
334.       )
335.       (vla-getWidth pline p 'swid 'ewid)
336.       (vla-setWidth copy (vl-position p tmp) swid ewid)
337.     )
338.     (foreach prop '(Elevation       Layer           Linetype
339.                     LinetypeGeneration              LinetypeScale
340.                     Lineweight      Normal          Thickness
341.                     TrueColor
342.                    )
343.       (if (vlax-property-available-p pline prop)
344.         (vlax-put copy prop (vlax-get pline prop))
345.       )
346.     )
347.     (setq tmp nil
348.           ret (cons copy ret)
349.     )
350.   )
351. )
352.  
353. ;;================================================================;;
354.  
355. ;; HighlightSegment
356. ;; Met un segment de polyligne en surbrillance
357. ;;
358. ;; Arguments
359. ;; pl : la polyligne (vla-object)
360. ;; par : l'indice du segment
361.  
362. (defun HighlightSegment (pl par / p1 p2 n lst)
363.   (and
364.     (setq p1 (vlax-curve-getPointAtParam pl par))
365.     (setq p1 (trans p1 0 1))
366.     (setq p2 (vlax-curve-getPointAtParam pl (+ par 1)))
367.     (setq p2 (trans p2 0 1))
368.     (if (zerop (vla-getBulge pl par))
369.       (grvecs (list -255 p1 p2))
370.       (progn
371.         (setq n 0)
372.         (repeat 100
373.           (setq lst (cons (trans (vlax-curve-getPointAtParam pl (+ n par)) 0 1)
374.                           lst
375.                     )
376.                 n   (+ n 0.01)
377.           )
378.         )
379.         (grvecs
380.           (cons -255 (apply 'append (mapcar 'list lst (cdr lst))))
381.         )
382.       )
383.     )
384.   )
385. )
386.  
387. ;;================================================================;;
388.  
389. ;;; Clockwise-p
390. ;;; Retourne T si les points p1 p2 et p3 tournent dans le sens horaire
391.  
392. (defun clockwise-p (p1 p2 p3)
393.   (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-14)
394. )
395.  
396. ;;================================================================;;
397.  
398. ;;; Polyarc-data
399. ;;; Retourne la liste des données d'un arc de polyligne (centre rayon angle).
400.  
401. (defun polyarc-data (bu p1 p2 / ang rad cen area cg)
402.   (setq ang (* 2 (atan bu))
403.         rad (/ (distance p1 p2)
404.                (* 2 (sin ang))
405.             )
406.         cen (polar p1
407.                    (+ (angle p1 p2) (- (/ pi 2) ang))
408.                    rad
409.             )
410.   )
411.   (list cen (abs rad) ang)
412. )
413.  
414. ;;================================================================;;
415.  
416. ;; GETPOINTABOUTPLANE
417. ;; Retourne le point d'intersection de la perpendiculaire à la vue courante passant
418. ;; par le point saisi par l'utilsateur et le plan défini par sa normale et un point.
419. ;;
420. ;; Arguments
421. ;; nor : le vecteur normal du plan d'intersection
422. ;; org : un point sur le plan d'intersection (SCG)
423. ;; msg : le message d'invite ou ""
424. ;;
425. ;; Retour : les coordonnées (SCG) du point d'intersection ou nil
426.  
427. (defun GetPointAboutPlane (nor org msg / p1 p2 sc)
428.   (if (and (setq p1 (getpoint msg))
429.            (setq p1 (trans p1 1 0))
430.            (setq p2 (trans p1 0 2))
431.            (setq p2 (trans (list (car p2) (cadr p2) (1+ (caddr p2))) 2 0))
432.            (/= 0
433.                (setq sc (apply '+ (mapcar '* nor (mapcar '- p2 p1))))
434.            )
435.       )
436.     (mapcar
437.       (function
438.         (lambda (x1 x2)
439.           (+ (* (/ (apply '+ (mapcar '* nor (mapcar '- p1 org))) sc)
440.                 (- x1 x2)
441.              )
442.              x1
443.           )
444.         )
445.       )
446.       p1
447.       p2
448.     )
449.   )
450. )

[Lee Mac]

This may also be of interest: Offset Polyline Section - the program will allow you to offset a section of a selected polyline between any two selected points, therefore the user is not restricted to full segments.