http://www.cadtutor.net/forum/showthread.php?49301-Any-function-to-draw-Lines-instead-of-Mline&p=335931&viewfull=1#post335931 This was an interesting 1:
;=======================================================================; QMLine.Lsp Sep 28, 2010; Multi Line With Quantity And Distance Inputs;================== Start Program ======================================(princ "\nCopyright (C) 1990-2010, Fabricated Designs, Inc.")(princ "\nLoading QMLine v1.0 ");++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++(defun qml_smd ()(SetUndo)(setq olderr *error* *error* (lambda (msg) (while (> (getvar "CMDACTIVE") 0) (command)) (and (/= msg "quit / exit abort") (princ (strcat "\nError: *** " msg " *** "))) (and (= (logand (getvar "UNDOCTL")8) (command "_.UNDO" "_END" "_.U")) (qml_rmd)) qml_var '(("OSMODE" . 0) ("SORTENTS" . 119) ("LUPREC" . 2) ("BLIPMODE". 0) ("SNAPMODE". 1) ("ORTHOMODE" . 1) ("UCSICON" . 1) ("HIGHLIGHT" . 1) ("COORDS" . 2) ("DIMZIN" . 1) ("CMDECHO" . 0) ("CECOLOR" . "BYLAYER") ("CELTYPE" . "BYLAYER")))(foreach v qml_var(and (getvar (car v)) (setq qml_rst (cons (cons (car v) (getvar (car v))) qml_rst)) (setvar (car v) (cdr v))))(princ (strcat (getvar "PLATFORM") " Release " (ver)))(princ));++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++(defun qml_rmd () (setq *error* olderr) (foreach v qml_rst (setvar (car v) (cdr v))) (command "_.UNDO" "_END") (prin1));++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++(defun SetUndo ()(and (zerop (getvar "UNDOCTL")) (command "_.UNDO" "_ALL"))(and (= (logand (getvar "UNDOCTL") 2) 2) (command "_.UNDO" "_CONTROL" "_ALL"))(and (= (logand (getvar "UNDOCTL")8) (command "_.UNDO" "_END"))(command "_.UNDO" "_GROUP"));++++++++++++ GrDraw A Point List ++++++++++++++++++++++++++++++++(defun grpl (l c f / tmp) (setq tmp l) (while (> (length tmp) 1) (grdraw (car tmp) (cadr tmp) c f) (setq tmp (cdr tmp))));;;ARG -> POINT_LIST OFFSET_DISTANCE OFFSET_SIDE ("Inside" "Outside")(defun offset (pl of side / p1 p2 p3 p4 cls_flag ccw cw tmp ol pi05 func v1 ipt nl);;;CCW TEST - FROM COMPUSERVE DAYS;;;ARG -> POINT_LIST;;;RET -> POSITIVE = CCW NEGATIVE = CW(defun surf (lst / sum i)(setq i 0 sum 0)(while (< i (- (length lst) 1)) (setq sum (+ sum (- (* (car (nth i lst))(cadr (nth (+ 1 i) lst))) (* (cadr (nth i lst)) (car(nth (+ 1 i) lst)))))) (setq i (1+ i)))(/ sum 2.0))(setq cls_flag (if (equal (car pl) (last pl) 1e- T nil))(if (minusp (surf pl)) (setq cw T) (setq ccw T))(cond ((and ccw (= side "Inside"))(setq func +)) ((and cw(= side "Inside"))(setq func -)) ((and ccw (= side "Outside")) (setq func -)) ((and cw(= side "Outside")) (setq func +)))(setq tmp pl ol nil pi05 (* pi 0.5))(while (> (length tmp) 2) (setq p1 (polar (nth 0 tmp) (func (angle (nth 0 tmp) (nth 1 tmp)) pi05) of)) (setq p2 (polar (nth 1 tmp) (func (angle (nth 0 tmp) (nth 1 tmp)) pi05) of)) (setq p3 (polar (nth 1 tmp) (func (angle (nth 1 tmp) (nth 2 tmp)) pi05) of)) (setq p4 (polar (nth 2 tmp) (func (angle (nth 1 tmp) (nth 2 tmp)) pi05) of)) (and (not v1) (not cls_flag) (setq v1 p1 ol (list v1))) (setq ipt (inters p1 p2 p3 p4 nil)) (and ipt (setq ol (cons ipt ol))) (setq tmp (cdr tmp)))(and (not cls_flag) (setq ol (cons p4 ol)))(and cls_flag (setq nl (- (length pl) 2)) (setq p1 (polar (nth nl pl) (func (angle (nth nl pl) (nth 0 pl)) pi05) of)) (setq p2 (polar (nth 0 pl) (func (angle (nth nl pl) (nth 0 pl)) pi05) of)) (setq p3 (polar (nth 0 pl) (func (angle (nth 0 pl) (nth 1 pl)) pi05) of)) (setq p4 (polar (nth 1 pl) (func (angle (nth 0 pl) (nth 1 pl)) pi05) of)) (setq ipt (inters p1 p2 p3 p4 nil)) (and ipt (setq ol (cons ipt ol)) (setq ol (append ol (list ipt)))))ol);************ Main Program ***************************************(defun qml_ (/ olderr qml_var qml_rst odef o qdef q np pl r c) (qml_smd);(*-debug-* 9 "qml_");;;OFFSET DISTANCE (setq odef (if db_ofd db_ofd 2)) (initget 6) (setq o (getdist (strcat "\nOffset Distance : "))) (if (not o) (setq o odef)) (setq db_ofd o);;;OFFSET QTY (setq qdef (if db_ofq db_ofq 2)) (initget 6) (setq q (getint (strcat "\nNumber Of Offset Lines Per Side : "))) (if (not q) (setq q qdef)) (setq db_ofq q);;:GET POINTS (initget 1) (setq np (getpoint "\n1st Point: ")) (setq pl (list np)) (while (setq np (getpoint np "\nNext Point: ")) (setq pl (cons np pl)) (grpl pl 2 3) (setq r 1 c 1) (repeat q (set (read (strcat "R" (itoa r))) (offset pl (* o c) "Inside")) (set (read (strcat "R" (itoa (1+ r)))) (offset pl (* o c) "Outside")) (setq c (1+ c)) (grpl (cdr (reverse (eval (read (strcat "R" (itoa r)))))) 1 3) (grpl (cdr (reverse (eval (read (strcat "R" (itoa (1+ r))))))) 3 3) (setq r (+ r 2))));;;CENTER LINE (command "_.PLINE") (foreach p pl (command p)) (command "");;;OFFSET LINES (setq r 1) (repeat q (command "_.PLINE") (foreach p (eval (read (strcat "R" (itoa r)))) (command p)) (command "") (command "_.PLINE") (foreach p (eval (read (strcat "R" (itoa (1+ r))))) (command p)) (command "") (setq r (+ r 2)));;;CLEAR DYNAMIC POINT LISTS (setq r 1) (repeat q (set (read (strcat "R" (itoa r))) nil) (set (read (strcat "R" (itoa (1+ r)))) nil) (setq r (+ r 2)));(*break*);(*-debug-* 0 "qml_") (qml_rmd));************ Load Program ***************************************(defun C:QMLine () (qml_))(if qml_ (princ "\nQMLine Loaded\n"))(prin1);|================== End Program =======================================
If the first point and last points are coincidental, it should fillet and close th loop.-David I cheated, but here's my contribution...
(defun c:OD (/ _draw _eq lwp) ;; Offset Draw ;; Required subroutines: AT:GetPoints ;; Alan J. Thompson, 09.28.10 (vl-load-com) (defun _draw (lst / lst gen) (if (vl-consp lst) (progn (if (_eq (car lst) (last lst)) (setq lst (reverse (cdr (reverse lst))) gen (+ (* (getvar 'plinegen) 128) 1) ) (setq gen (* (getvar 'plinegen) 128)) ) (vlax-ename->vla-object (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 gen) ) (mapcar (function (lambda (p) (cons 10 (reverse (cdr (reverse (trans p 1 0))))))) lst) ) ) ) ) ) ) (defun _eq (a b) (equal (list (car a) (cadr a)) (list (car b) (cadr b)))) (initget 6) (setq *OD:Off* (cond ((getdist (strcat "\nSpecify offset distance : " ) ) ) (*OD:Off*) ) ) (initget 6) (setq *OD:Num* (cond ((getint (strcat "\nSpecify number of offsets : " ) ) ) (*OD:Num*) ) ) (if (setq lwp (_draw (AT:GetPoints))) ((lambda (i) (repeat *OD:Num* (setq i (1+ i)) (mapcar (function (lambda (d) (vl-catch-all-apply (function vla-offset) (list lwp (* i d))))) (list *OD:Off* (- *OD:Off*)) ) ) ) 0. ) ) (princ))(defun AT:GetPoints (/ lst pt) ;; Return list of picked points ;; Alan J. Thompson, 06.18.10 (if (car (setq lst (list (getpoint "\nSpecify first point: ")))) (progn (while (and (if (> (length lst) 2) (setq pt (initget 0 "Close") pt (getpoint (car lst) "\nSpecify next point : ") ) (setq pt (getpoint (car lst) "\nSpecify next point: ")) ) (/= pt "Close") ) (mapcar (function (lambda (a b) (and a b (grdraw a b 1 1)))) (setq lst (cons pt lst)) (cdr lst) ) ) (redraw) (if (> (length lst) 1) (reverse (cond ((= pt "Close") (cons (last lst) lst)) (lst) ) ) ) ) )) Lee, I think that might have been the thread, but I still want to see I remember something that was more than just two PLINES. I'm pretty sure....
David/Alan, these are both exactly what I wanted, on the mark. It's funny because now I have used each of y'alls program, I realize with my initial clarification, this creates the program to always have a centerline which means the offsets increment in odd numbers. The lowest amount of PLINES it creates is 3 because if you use an offset distance of one, it creates two offset PLINES along with the center. So I can only have an odd number of PLINES (3, 5, 7, etc). So, come to think of it due to my lack of a programmers approach, I created an odd number of PLINES only. Meh, no worries, its easier just to delete one PLINE to get what I need. It seems it would be too much trouble to re-write these programs. It already gets me way ahead of the game. It's only for schematic layout of mechanical piping in plan view, so it doesn't have to be spectacular.
Speaking off, how the crap can y'all write so much code so quickly? Ugh... I'm always so envious of programmers that can "whip something up". What I need to do is get some authorization to pay one of y'all to build a complete custom suite that fits our company needs and standards.
Anyways, I always feel humiliated like I'm asking for a freebie and most of y'all have always helped me out and I undoubtedly appreciate it. I can't help but to always feel in debt to the few of you who have always lent a hand with some LISP help.
- Tannar A simple addition...
(defun c:OD (/ _draw _eq lwp) ;; Offset Draw ;; Required subroutines: AT:GetPoints ;; Alan J. Thompson, 09.28.10 (vl-load-com) (defun _draw (lst / lst gen) (if (vl-consp lst) (progn (if (_eq (car lst) (last lst)) (setq lst (reverse (cdr (reverse lst))) gen (+ (* (getvar 'plinegen) 128) 1) ) (setq gen (* (getvar 'plinegen) 128)) ) (vlax-ename->vla-object (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 gen) ) (mapcar (function (lambda (p) (cons 10 (reverse (cdr (reverse (trans p 1 0))))))) lst) ) ) ) ) ) ) (defun _eq (a b) (equal (list (car a) (cadr a)) (list (car b) (cadr b)))) (initget 6) (setq *OD:Off* (cond ((getdist (strcat "\nSpecify offset distance : " ) ) ) (*OD:Off*) ) ) (initget 6) (setq *OD:Num* (cond ((getint (strcat "\nSpecify number of offsets : " ) ) ) (*OD:Num*) ) ) (initget 0 "Yes No") (setq *OD:Del* (cond ((getkword (strcat "Delete middle line? : " ) ) ) (*OD:Del*) ) ) (if (setq lwp (_draw (AT:GetPoints))) ((lambda (i) (repeat *OD:Num* (setq i (1+ i)) (mapcar (function (lambda (d) (vl-catch-all-apply (function vla-offset) (list lwp (* i d))))) (list *OD:Off* (- *OD:Off*)) ) ) (and (eq *OD:Del* "Yes") (vl-catch-all-apply (function vla-delete) (list lwp))) ) 0. ) ) (princ))(defun AT:GetPoints (/ lst pt) ;; Return list of picked points ;; Alan J. Thompson, 06.18.10 (if (car (setq lst (list (getpoint "\nSpecify first point: ")))) (progn (while (and (if (> (length lst) 2) (setq pt (initget 0 "Close") pt (getpoint (car lst) "\nSpecify next point : ") ) (setq pt (getpoint (car lst) "\nSpecify next point: ")) ) (/= pt "Close") ) (mapcar (function (lambda (a b) (and a b (grdraw a b 1 1)))) (setq lst (cons pt lst)) (cdr lst) ) ) (redraw) (if (> (length lst) 1) (reverse (cond ((= pt "Close") (cons (last lst) lst)) (lst) ) ) ) ) )) BTW, nice use of grdraw. I considered that, but was just lazy. Bravo. Also an extra we wrote an auto measure so if you come in tomorow you don't have to remember width settings from day before, just drag a line over what you have drawn previously measure the offsets sq and in your case also how many you need to create. This could be added to alanjt's as an option when asking for widths etc.
Nice thing is just have some preset examples in your drawing floating around or bring into drawing a block containing line answers.
Anyway you should be able to pull this apart have a look at the date 1993!
;;;---------------------------------------------------------------------------;4;;;;;;;;;;; by Alan;;; 1 june 1993;;; ;;;DESCRIPTION;;;measure wall by dragging across sets w2 w3 w4 ;;;;---------------------------------------------------------------------------;;;;---------------------------------------------------------------------------;;;; Main Program.;;;---------------------------------------------------------------------------;(setvar "cmdecho" 0)(defun cal_ang_pt ()(while (setq en (ssname ss 0)) (setq pt3 (cdr (assoc 10 (entget en)))) (setq pt4 (cdr (assoc 11 (entget en)))) (setq pt5 (inters pt1 pt2 pt3 pt4 nil)) (setq dist (distance pt1 pt5)) (command "line" pt1 "perp" pt5 "") (command "erase" "Last" "") (setq pt6 (getvar "lastpoint")) (setq sss (cons pt6 sss)) (ssdel en ss) ))(setq pt1 (getpoint "\nPick first point on inside of wall :"))(setq pt2 (getpoint pt1 "\nPick second point on outside of wall :"))(setq ss (ssget "F" (list pt1 pt2))) (defun sort_pts ()(setq dimno (length sss))(setq I 0) (setq maxx (- dimno 1))(while (/= I maxx) (setq j0 pt1)(setq J 1)(setq K (- dimno I) ) (while (/= J K) (setq j3 (LIST 1 1 1))(setq j4 (LIST 2 2 2))(setq j2 (nth J sss)) (setq L (- j 1))(setq j1 (nth L sss))(if (
页:
1
[2]