AutoCAD Tips

The title of this post pretty much describes what this routine does. It behaves just like the OFFSET command but it allows you to offset single or multiple segments of a polyline. This pretty cool if you’ve ever needed something like this.

Here’s how to use it:

• OFSEGS <enter> to start
• Specify the offset distance or enter T for the “Through” option
• Select the segments that are to be offset
• Hit <enter> when done selecting segments
• Click on a side to specify what side the objects should be offset

;; OFSEGS -Gilles Chanteau- 2008/03/26

;; Offsets the selected segments of lwpolyline

;; Joined segments are offseted in a single lwpolyline

;; Keeps arcs and widthes

;; Works whatever the current UCS and the pline OCS and elevation

(defun c:ofsegs (/ ofdist ent pline normal elevat params

points side closest par bulge p1

p2 arc_data

)

(vl-load-com)

(or *acdoc*

(setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))

)

(initget 6 "Through")

(if (setq

ofdist (getdist

(strcat "\nSpecify offset distance or [Through] <"

(if (< (getvar "OFFSETDIST") 0)

"Through"

(rtos (getvar "OFFSETDIST"))

)

">: "

)

)

)

(if (= ofdist "Through")

(setvar "OFFSETDIST" -1)

(setvar "OFFSETDIST" ofdist)

)

(setq ofdist (getvar "OFFSETDIST"))

)

(if (and (setq ent (entsel "\nSelect a segment to offset: "))

(setq pline (vlax-ename->vla-object (car ent)))

(= (vla-get-ObjectName pline) "AcDbPolyline")

(setq normal (vlax-get pline 'Normal))

(setq elevat (vla-get-Elevation pline))

)

(progn

(setq params (cons (fix (vlax-curve-getParamAtPoint

pline

(trans (osnap (cadr ent) "_nea") 1 0)

)

)

params

)

)

(HighlightSegment pline (car params))

(while

(setq ent (entsel "\nSelect next segment or <exit>: "))

(if (equal (vlax-ename->vla-object (car ent)) pline)

(progn

(setq par (fix (vlax-curve-getParamAtPoint

pline

(trans (osnap (cadr ent) "_nea") 1 0)

)

)

params (if (member par params)

(vl-remove par params)

(cons par params)

)

)

(redraw)

(foreach p params (HighlightSegment pline p))

)

)

)

(if (setq side (getpoint

(if (minusp (getvar "OFFSETDIST"))

"\nSpecify through point: "

"\nSpecify point on side to offset: "

)

)

)

(progn

(redraw)

(vla-StartUndoMark *acdoc*)

(setq side (ilp

(trans side 1 0)

((lambda (p)

(trans (list (car p) (cadr p) (1+ (caddr p))) 2 0)

)

(trans side 1 2)

)

(trans (list 0 0 elevat) normal 0)

normal

)

closest (vlax-curve-getClosestPointTo pline side T)

par (vlax-curve-getParamAtPoint pline closest)

)

(if (minusp (getvar "OFFSETDIST"))

(setq ofdist (distance side closest))

)

(cond

((equal closest (vlax-curve-getStartPoint pline) 1e-9)

(setq side (trans side 0 normal))

)

((equal closest (vlax-curve-getEndPoint pline) 1e-9)

(setq par (- par 1)

side (trans side 0 normal)

)

)

((= (fix par) par)

(setq side

(polar

(trans closest 0 normal)

((if

(clockwise-p

(trans

(vlax-curve-getPointAtParam pline (- par 0.1))

0

normal

)

(trans closest 0 normal)

(trans

(vlax-curve-getPointAtParam pline (+ par 0.1))

0

normal

)

)

+

-

)

(angle '(0 0 0)

(trans (vlax-curve-getFirstDeriv pline par)

0

normal

T

)

)

(/ pi 2)

)

ofdist

)

)

)

(T

(setq par (fix par)

side (trans side 0 normal)

)

)

)

(setq bulge (vla-getBulge pline (fix par))

p1 (trans (vlax-curve-getPointAtParam pline (fix par))

0

normal

)

p2 (trans (vlax-curve-getPointAtParam pline (1+ (fix par)))

0

normal

)

)

(if (zerop bulge)

(if (clockwise-p side p2 p1)

(setq ofdist (- ofdist))

)

(progn

(setq arc_data (PolyArc-data bulge p1 p2))

(if (minusp bulge)

(if (< (cadr arc_data)

(distance (car arc_data) side)

)

(setq ofdist (- ofdist))

)

(if (< (distance (car arc_data) side)

(cadr arc_data)

)

(setq ofdist (- ofdist))

)

)

)

)

(mapcar

(function

(lambda (p)

(vl-catch-all-apply 'vla-Offset (list p ofdist))

(vla-delete p)

)

)

(Copysegments pline params)

)

(vla-EndUndoMark *acdoc*)

)

)

)

(princ "\nUnvalid entity.")

)

(princ)

)

;; CopySegments

;; Duplicates polyline segments at the same location

;; Consecutive selected segments are joined

;;

;; Arguments

;; pline : the source polyline (vla-object)

;; params ; the index list of segment to be copied

;;

;; Return

;; the list of created polylines

(defun CopySegments (pline params / nor space tmp copy ret)

(vl-load-com)

(or *acdoc*

(setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))

)

(setq params (vl-sort params '<)

nor (vlax-get pline 'Normal)

space (vla-ObjectIDToObject *acdoc* (vla-get-OwnerID pline))

)

(while params

(setq tmp (cons (car params) tmp)

params (cdr params)

)

(if (and (zerop (car tmp))

(= (- (vlax-curve-getEndParam pline) 1) (last params))

(equal (vlax-curve-getStartPoint pline)

(vlax-curve-getEndPoint pline)

1e-9

)

)

(progn

(setq params (reverse params)

tmp (cons (car params) tmp)

params (cdr params)

)

(while (= (car params) (1- (car tmp)))

(setq tmp (cons (car params) tmp)

params (cdr params)

)

)

(setq tmp (reverse tmp)

params (reverse params)

)

)

)

(while (= (car params) (1+ (car tmp)))

(setq tmp (cons (car params) tmp)

params (cdr params)

)

)

(setq tmp (reverse (cons (1+ (car tmp)) tmp)))

(setq

pts

(vl-remove nil

(mapcar

(function

(lambda (pa / pt)

(if (setq pt (vlax-curve-getPointAtParam pline pa))

((lambda (p)

(list (car p) (cadr p))

)

(trans pt 0 nor)

)

)

)

)

tmp

)

)

)

(setq copy

(vlax-invoke

space

'addLightWeightPolyline

(apply 'append pts)

)

)

(foreach p (cdr (reverse tmp))

(vla-setBulge

copy

(vl-position p tmp)

(vla-getBulge pline p)

)

(vla-getWidth pline p 'swid 'ewid)

(vla-setWidth copy (vl-position p tmp) swid ewid)

)

(foreach prop '(Elevation Layer Linetype

LinetypeGeneration LinetypeScale

Lineweight Normal Thickness

TrueColor

)

(if (vlax-property-available-p pline prop)

(vlax-put copy prop (vlax-get pline prop))

)

)

(setq tmp nil

ret (cons copy ret)

)

)

)

;;======================================================;;

;; HighlightSegment

;; Highlight a polyline segment

;;

;; Arguments

;; pl : the polyline (vla-object)

;; par : the segment index

(defun HighlightSegment (pl par / p1 p2 n lst)

(and

(setq p1 (vlax-curve-getPointAtParam pl par))

(setq p1 (trans p1 0 1))

(setq p2 (vlax-curve-getPointAtParam pl (+ par 1)))

(setq p2 (trans p2 0 1))

(if (zerop (vla-getBulge pl par))

(grvecs (list -255 p1 p2))

(progn

(setq n 0)

(repeat 100

(setq lst (cons (trans (vlax-curve-getPointAtParam pl (+ n par)) 0 1)

lst

)

n (+ n 0.01)

)

)

(grvecs

(cons -255 (apply 'append (mapcar 'list lst (cdr lst))))

)

)

)

)

)

;;=====================================================;;

;;; Clockwise-p

;;; Returns T if p1 p2 and p3 are clockwise

(defun clockwise-p (p1 p2 p3)

(< (sin (- (angle p1 p3) (angle p1 p2))) -1e-14)

)

;;========================================================;;

;;; Polyarc-data

;;; Returns a list of the center, radius and angle of a 'polyarc'.

(defun polyarc-data (bu p1 p2 / ang rad cen area cg)

(setq ang (* 2 (atan bu))

rad (/ (distance p1 p2)

(* 2 (sin ang))

)

cen (polar p1

(+ (angle p1 p2) (- (/ pi 2) ang))

rad

)

)

(list cen (abs rad) ang)

)

;;====================================================;;

;;; VXV Returns the dot product of two vectors

(defun vxv (v1 v2)

(apply '+ (mapcar '* v1 v2))

)

;;===================================================;;

;;; ILP

;;; Returns the intersection point between a line (extended) and a plane

;;;

;;; Arguments

;;; p1 and p2 : two points defining the line

;;; org : a point on the plane

;;; nor : the plane normal

(defun ilp (p1 p2 org nor / scl)

(setq scl (/ (vxv nor (mapcar '- p1 org))

(vxv nor (mapcar '- p2 p1))

)

)

(mapcar (function (lambda (x1 x2) (+ (* scl (- x1 x2)) x1)))

p1

p2

)

)