Jump to content

LE - some of my lisp coding...


LEsq

Recommended Posts

Here, will be some of my autolisp/vital lisp/visual lisp/dcl...

 

Hope that will still of some use, about lisp I lost the practice, and nowadays dont' write in lisp anymore.

 

REDODIM

Select an exploded dimension and it will be re-done, this was intended to learn on how to recreate an exploded dimension.

 

(vl-load-com)
(defun sslist  (ss / n lst)
 (if (= (type ss) 'pickset)
   (repeat (setq n (ssLength ss))
     (setq n (1- n)
    lst (cons (ssname ss n) lst)))))
(defun coolineal  (p1 p2 ptchk / ang ang1 absang fuzz)
 (setq fuzz 0.00001)
 (if (or (equal p1 ptchk fuzz) (equal p2 ptchk fuzz))
   (setq retval t)
   (progn
     (setq ang    (angle p1 ptchk)
    ang1   (angle p1 p2)
    absang (abs (- ang ang1)))
     (if (or (equal absang 0.0 fuzz)
      (equal absang pi fuzz)
      (equal absang (* pi 2) fuzz))
t
nil))))
(defun lincool (l1 l2 / p1 p2 p3 p4)
 (setq p1 (cdr (assoc 10 (entget l1)))
p2 (cdr (assoc 11 (entget l1)))
p3 (cdr (assoc 10 (entget l2)))
p4 (cdr (assoc 11 (entget l2))))
 (if (and (coolineal p1 p2 p3) (coolineal p1 p2 p4))
   t))
(if (not thisdwg)
 (setq thisdwg (vla-get-activedocument (vlax-get-acad-object))))
(if (not modelspace)
 (setq modelspace
 (vla-get-modelspace thisdwg)))
(defun paperspace () (vla-get-paperspace thisdwg))
(defun rcmd-get-activespace  ()
 (if (= acmodelspace (vla-get-activespace thisdwg))
   modelspace
   (if (= (vla-get-mspace thisdwg) :vlax-true)
     modelspace
     (paperspace))))
(defun adddimrotated
       (xline1point xline2point dimlinelocation rotationangle / vla_dim)
 (if (not (vl-catch-all-error-p
     (setq vla_dim
     (vl-catch-all-apply
       'vla-adddimrotated
       (list (rcmd-get-activespace)
      (vlax-3d-point xline1point)
      (vlax-3d-point xline2point)
      (vlax-3d-point dimlinelocation)
      rotationangle)))))
   vla_dim))
(defun arrowhead-blk  (bname)
 (cond
   ((= bname "_DOT")
    acArrowDot)
   ((= bname "_DOTSMALL")
    acArrowDotSmall)
   ((= bname "_DOTBLANK")
    acArrowDotBlank)
   ((= bname "_ORIGIN")
    acArrowOrigin)
   ((= bname "_ORIGIN2")
    acArrowOrigin2)
   ((= bname "_OPEN")
    acArrowOpen)
   ((= bname "_OPEN90")
    acArrowOpen90)
   ((= bname "_OPEN30")
    acArrowOpen30)
   ((= bname "_CLOSED")
    acArrowClosed)
   ((= bname "_SMALL")
    acArrowSmall)
   ((= bname "_NONE")
    acArrowNone)
   ((= bname "_OBLIQUE")
    acArrowOblique)
   ((= bname "_BOXFILLED")
    acArrowBoxFilled)
   ((= bname "_BOXBLANK")
    acArrowBoxBlank)
   ((= bname "_CLOSEDBLANK")
    acArrowClosedBlank)
   ((= bname "_DATUMFILLED")
    acArrowDatumFilled)
   ((= bname "_DATUMBLANK")
    acArrowDatumBlank)
   ((= bname "_INTEGRAL")
    acArrowIntegral)
   ((= bname "_ARCHTICK")
    acArrowArchTick)))
(defun C:REDODIM  (/ ss lst lst_lines lst_blocks lst_solids ints int1 int2 int3 line1 line2
    line3 lst3)
 (if (setq ss (ssget))
   (progn
     (setq lst       (sslist ss)
    lst_lines
       (vl-remove-if-not
  (function (lambda (ent) (eq (cdadr (entget ent)) "LINE")))
  lst))
     (if (not
    (setq lst_blocks
    (vl-remove-if-not
      (function
        (lambda (ent) (eq (cdadr (entget ent)) "INSERT")))
      lst)))
(setq lst_solids
       (vl-remove-if-not
  (function
    (lambda (ent) (eq (cdadr (entget ent)) "SOLID")))
  lst)))
     (setq l_a     lst_lines
    L_a2    l_a
    lTemp   T
    lTot    nil
    lst_not
     nil
    par     nil)
     (while l_a2
(setq EntChk (car l_a2)
      l_a2   (cdr l_a2))
(setq list_T-nil
       (mapcar (function (lambda (x) (lincool x EntChk))) l_a2))
(setq lTemp (vl-remove-if
       'not
       (mapcar (function
   (lambda (x y)
     (if (and x y)
       y)))
        list_T-nil
        l_a2)))
(foreach j lTemp (setq l_a2 (vl-remove j l_a2)))
(setq lTemp (cons EntChk lTemp))
(if (and lTemp (> (length lTemp) 1))
  (setq lTot (cons lTemp lTot))
  (setq lst_not (cons ltemp lst_not))))
     (setq tmp nil)
     (if (and (not ltot) lst_not (= (length lst_not) 3))
(progn
  (setq lst3  (apply 'append lst_not)
 line1 (car lst3)
 line2 (cadr lst3)
 line3 (caddr lst3)
 p1    (cdr (assoc 10 (entget line1)))
 p2    (cdr (assoc 11 (entget line1)))
 p3    (cdr (assoc 10 (entget line2)))
 p4    (cdr (assoc 11 (entget line2)))
 p5    (cdr (assoc 10 (entget line3)))
 p6    (cdr (assoc 11 (entget line3)))
 int1  (inters p1 p2 p3 p4 nil)
 int2  (inters p3 p4 p5 p6 nil)
 int3  (inters p1 p2 p5 p6 nil)
 ints  (vl-remove nil (list int1 int2 int3))
 a     (car ints)
 b     (cadr ints)
 flag  (if lst_blocks
  "insert"
  "solid"))
  (cond
    ((= flag "solid")
     (setq solid1  (car lst_solids)
    elst    (entget solid1)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p3    (cdr (assoc 12 elst))
    solid2  (cadr lst_solids)
    elst    (entget solid2)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p4    (cdr (assoc 12 elst))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type dim_obj acarrowdefault)
     (vla-put-arrowhead2type dim_obj acarrowdefault))
    ((= flag "insert")
     (setq block1  (car lst_blocks)
    elst    (entget block1)
    bname   (cdr (assoc 2 (entget block1)))
    p3    (cdr (assoc 10 (entget block1)))
    block2  (cadr lst_blocks)
    elst    (entget block2)
    p4    (cdr (assoc 10 (entget block2)))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type
       dim_obj
       (arrowhead-blk (strcase bname)))
     (vla-put-arrowhead2type
       dim_obj
       (arrowhead-blk (strcase bname)))))))
     (if ltot
(progn
  (setq i 0)
  (repeat (length (setq par (car ltot)))
    (setq ename (nth i par)
   tmp (cons (cdr (assoc 10 (entget ename))) tmp)
   tmp (cons (cdr (assoc 11 (entget ename))) tmp)
   i (1+ i)))
  (setq flag (if lst_blocks
        "insert"
        "solid"))
  (cond
    ((= flag "solid")
     (setq solid1  (car lst_solids)
    elst    (entget solid1)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p3    (cdr (assoc 12 elst))
    solid2  (cadr lst_solids)
    elst    (entget solid2)
    p1    (cdr (assoc 10 elst))
    p2    (cdr (assoc 11 elst))
    p4    (cdr (assoc 12 elst))
    par    (apply 'append lst_not)
    a    (cdr (assoc 10 (entget (car par))))
    b    (cdr (assoc 10 (entget (cadr par))))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type dim_obj acarrowdefault)
     (vla-put-arrowhead2type dim_obj acarrowdefault))
    ((= flag "insert")
     (setq block1  (car lst_blocks)
    elst    (entget block1)
    bname   (cdr (assoc 2 (entget block1)))
    p3    (cdr (assoc 10 (entget block1)))
    block2  (cadr lst_blocks)
    elst    (entget block2)
    p4    (cdr (assoc 10 (entget block2)))
    par    (apply 'append lst_not)
    a    (cdr (assoc 10 (entget (car par))))
    b    (cdr (assoc 10 (entget (cadr par))))
    c    p3
    dim_obj
     (adddimrotated a b c (angle p3 p4)))
     (vla-put-arrowhead1type
       dim_obj
       (arrowhead-blk (strcase bname)))
     (vla-put-arrowhead2type
       dim_obj
       (arrowhead-blk (strcase bname)))))))
     (if dim_obj
(mapcar 'entdel lst))))
 (princ))
(princ)

Link to comment
Share on other sites

MTLSTAIR

Draws a floor plan and section of a metal stair following UBC code.

 

Included the ugliest source code but helpful back then - in the zip file, I wrote this routine, when was working on a high rise project (32 stories bulding hotel) and in charge of all the stairs analysis.

mtlstair.png

mtlstair.zip

Link to comment
Share on other sites

Here, will be some of my autolisp/vital lisp/visual lisp/dcl...

 

Hope that will still of some use, about lisp I lost the practice, and nowadays dont' write in lisp anymore.

 

Thank you also LE,

Link to comment
Share on other sites

AREAREADER - AR

Select closed polylines and it will show on the command line the area, some options available.

 

;; by LE
;; To turn this ability ON-OFF use:
;; For ON:
;; (setenv "AutoAreaReader" "1")
;; For OFF:
;; (setenv "AutoAreaReader" "0")
;;
;;
;; To change the print output use:
;; Variable name: def_show_area 
;; Options: 
;; 1. "Decimal"
;; 2. "Squarefeet"
;; 3. "Acres"
;; 4. "SquareMeters"
;; 5. "Hectares"
;; In example: 
;; Command: (setq def_show_area "Acres")
;;--------------------------------------------------------------
(if (not (getenv "AutoAreaReader"))
 (setenv "AutoAreaReader" "0"))
;;--------------------------------------------------------------
(defun ssget->vla-list  (ss / index vlaList)
 (setq index (if ss
 (1- (ssLength ss))
 -1))
 (while (>= index 0)
   (setq vlaList (cons
     (vlax-ename->vla-object
       (ssname ss index))
     vlaList)
  index   (1- index)))
 vlaList)
;;--------------------------------------------------------------
(defun addComma  (txt / strl cont1 lth cont txt1)
 (setq strl  (strlen txt)
cont1 1
txt1  "")
 (while (and (/= (substr txt cont1 1) ".") (<= cont1 strl))
   (setq cont1 (1+ cont1)))
 (setq lth   (1- cont1)
cont1 1
cont  (1- lth))
 (if (> lth 3)
   (progn
     (while (< cont1 lth)
(setq let  (substr txt cont1 1)
      txt1 (strcat txt1 let))
(if (and (zerop (rem cont 3)) (eq (type (read let)) 'INT))
  (setq txt1 (strcat txt1 ",")))
(setq cont  (1- cont)
      cont1 (1+ cont1)))
     (while (<= cont1 strl)
(setq txt1  (strcat txt1 (substr txt cont1 1))
      cont1 (1+ cont1)))
     txt1)
   txt))
;;--------------------------------------------------------------
(defun printArea  (ar / string)
 (setq string
   "\nChange variable LUPREC to a higher precision value - try again.")
 (if (not def_show_area)
   (setq def_show_area "Decimal"))
 (cond
   ((= def_show_area "Decimal")
    (if (zerop (atof (rtos ar 2 (getvar "luprec"))))
      (prompt string)
      (princ
 (addComma
   (rtos ar 2 (getvar "luprec"))))))
   ((= def_show_area "Squarefeet")
    (if (zerop (atof (rtos (/ ar 144.0) 2 (getvar "luprec"))))
      (prompt string)
      (progn
 (princ
   (addComma (rtos (/ ar 144.0) 2 (getvar "luprec"))))
 (princ " square feet"))))
   ((= def_show_area "Acres")
    (if
      (zerop
 (atof (rtos (/ (/ ar 144.0) 43560.0) 2 (getvar "luprec"))))
(prompt string)
(progn
  (princ
    (addComma
      (rtos (/ (/ ar 144.0) 43560.0) 2 (getvar "luprec"))))
  (princ " acres"))))
   ((= def_show_area "SquareMeters")
    (if (zerop (atof (rtos ar 2 (getvar "luprec"))))
      (prompt string)
      (progn
 (princ
   (addComma
     (rtos ar 2 (getvar "luprec"))))
 (princ " m2"))))
   ((= def_show_area "Hectares")
    (if
      (zerop
 (atof (rtos (/ ar 10000.0) 2 (getvar "luprec"))))
(prompt string)
(progn
  (princ
    (addComma
      (rtos (/ ar 10000.0) 2 (getvar "luprec"))))
  (princ " hectares"))))))
;;--------------------------------------------------------------
(defun areareader-pickfirst
      (reactor params / ss ent obj ar pol_data lst_dat)
 (if (eq (getenv "AutoAreaReader") "1")
   (cond
     ((and (eq 1 (logand 1 (getvar "pickfirst")))
    (setq ss (ssget "_i" '((0 . "LWPOLYLINE"))))
    (eq 1 (sslength ss))
    (setq ent (ssname ss 0))
    (setq obj (vlax-ename->vla-object ent))
    (eq (vla-get-closed obj) :vlax-true))
      (setq ar (vla-get-area obj))
      (princ "\nArea of single polyline= ")
      (printArea ar)
      (princ))
     ((and
 (eq 1 (logand 1 (getvar "pickfirst")))
 (setq ss (ssget "_i" '((0 . "LWPOLYLINE"))))
 (> (sslength ss) 1)
 (vl-every
   (function
     (lambda (obj) (eq (vla-get-closed obj) :vlax-true)))
   (setq objs (ssget->vla-list ss))))
      (princ "\nTotal area of multiple polylines= ")
      (setq ar (apply '+ (mapcar 'vla-get-area objs)))
      (printArea ar)
      (princ)))))
;;--------------------------------------------------------------
(if (not areareader_pickfirst_reactor)
 (setq areareader_pickfirst_reactor
 (vlr-set-notification
   (vlr-miscellaneous-reactor
     "AutoAreaReader"
     '((:vlr-pickfirstmodified . areareader-pickfirst)))
   'active-document-only)))
;;--------------------------------------------------------------
(defun dtt-removeall  (reactor params)
 (vlr-remove-all))
;;--------------------------------------------------------------
(if (not dtt_reactor_dwg)
 (setq dtt_reactor_dwg
 (vlr-set-notification
   (vlr-editor-reactor
     "removeallreactors"
     '((:vlr-beginclose . dtt-removeall)))
   'active-document-only)))
;;--------------------------------------------------------------
(defun C:AR()
(cond
 ;; ON
 ((and (eq (getenv "AutoAreaReader") "1")
areareader_pickfirst_reactor
(not (vlr-added-p areareader_pickfirst_reactor)))
  (vlr-add areareader_pickfirst_reactor))
 ;; OFF
 ((and (eq (getenv "AutoAreaReader") "0")
areareader_pickfirst_reactor
(vlr-added-p areareader_pickfirst_reactor))
  (vlr-remove areareader_pickfirst_reactor)))
 (princ))
(princ)

Link to comment
Share on other sites

DRAW A POLYLINE FROM A LIST OF GROUPED POINTS

A simple way to draw a polyline from points, where a line it is a list of two points SP-EP and a bulge data it is represent by three points SP-MP-EP

 

;; by LE
(if (not thisDwg)
 (setq thisDwg
(vla-get-activeDocument (vlax-get-acad-object))))

(defun pspace () (vla-get-paperSpace thisDwg))
(if (not :rcmModel)
 (setq :rcmModel
(vla-get-modelSpace thisDwg)))

(defun activespace  ()
 (if (= acModelSpace (vla-get-activeSpace thisDwg))
   :rcmModel
   (if (= (vla-get-mSpace thisDwg) :vlax-true)
     :rcmModel
     (pspace))))

(defun list->variantArray  (ptslist / arrayspace sarray)
 (setq arrayspace
(vlax-make-safeArray
   vlax-vbDouble
   (cons 0
 (- (length ptslist) 1))))
 (setq sarray (vlax-safeArray-fill arrayspace ptslist))
 (vlax-make-variant sarray))

(defun getbulge (fromVertex midp p2 / ang chord midc alt)
 (setq ang   (angle fromVertex p2)
chord (distance fromVertex p2)
midc  (polar fromVertex ang (* chord 0.5))
alt   (distance midp midc))
 (cond
   ((zerop chord) 0.0)
   ((equal (angle midp midc)
    (rem (+ ang (* pi 0.5)) (* pi 2))
    1e-4)
    (/ alt chord 0.5))
   (T (/ alt chord -0.5))))

(defun 2dpt  (pt)
 (if (caddr pt)
   (list (car pt) (cadr pt))
   pt))

(defun pline_vlisp  (tst / sp pts index vla_poly)
 (setq sp (2dpt (caar tst)))
   (setq
   pts (mapcar
  (function (lambda (lst)
       (cond
  ((= (length lst) 2) (2dpt (cadr lst)))
  ((= (length lst) 3) (2dpt (caddr lst))))))
  tst))
 (setq pts (cons sp pts))
 (if (not (vl-catch-all-error-p
     (setq vla_poly
     (vl-catch-all-apply
       'vla-addlightweightpolyline
       (list (activespace)
      (list->variantArray (apply 'append pts)))))))
   (vla-put-closed vla_poly t))
 (setq index 0)
 (mapcar (function
    (lambda (lst)
      (if (= (length lst) 3)
 (vla-setbulge
   vla_poly
   index
   (getbulge (car lst) (cadr lst) (caddr lst))))
      (setq index (1+ index))))
  tst)
 vla_poly)

;; list of points
;; included are lists of two for lines and three for curves
(setq tst (list
    '((39.6076 -8.96248 0.0) (32.6084 -18.2036 0.0))
    '((32.6084 -18.2036 0.0) (52.2729 -16.9548))
    '((52.2729 -16.9548)
      (56.9734 -18.4078)
      (59.5221 -22.6161))
    '((59.5221 -22.6161)
      (64.61 -25.6477)
      (66.938 -20.2017))
    '((66.938 -20.2017) (59.0222 -7.79693 0.0))
    '((59.0222 -7.79693 0.0) (39.6076 -8.96248 0.0))))
;; do the test...
;;(pline_vlisp tst) ;; remove this line to test the above code

Link to comment
Share on other sites

CUSTOM AUTOSAVE CONTROL

One way to make a backup copy of the autosave file into an specific folder location (C:AUTOSAVE) with a format prefix of BAK_(dwgname)

 

Note: load the reactor on each open file and it will do the save after saving the drawing.

 

(vl-load-com)
(if (not (vl-file-directory-p "C:\\AUTOSAVE\\"))
 (vl-mkdir "C:\\AUTOSAVE\\"))

(defun copy_sv$  (reactor params / files file)
 (if
   (and (setq files
 (vl-directory-files (getvar "SAVEFILEPATH") "*.SV$"))
 (setq file
 (vl-some
   (function
     (lambda (dwg)
       (if
  (wcmatch
    dwg
    (strcat "*"
     (vl-filename-base (getvar "DWGNAME"))
     "*"))
   dwg)))
   files)))
    (progn
      ;; make a copy of SV$ file into the c:\\autosave folder
      ;; as a drawing extension with the OUT_ prefix
      (vl-file-copy
 (strcat (getvar "SAVEFILEPATH") "\\" file)
 (strcat "C:\\AUTOSAVE\\" "OUT_" (getvar "DWGNAME")))
      ;; delete previous BAK_ file
      (vl-file-delete
 (strcat "C:\\AUTOSAVE\\" "BAK_" (getvar "DWGNAME")))
      ;; rename the new OUT_ file with the BAK_ prefix
      (vl-file-rename
 (strcat "C:\\AUTOSAVE\\" "OUT_" (getvar "DWGNAME"))
 (strcat "C:\\AUTOSAVE\\" "BAK_" (getvar "DWGNAME")))
      ;; delete OUT_ file
      (vl-file-delete
 (strcat "C:\\AUTOSAVE\\" "OUT_" (getvar "DWGNAME"))))))

(if (not dwg_reactor)
 (setq dwg_reactor
 (vlr-dwg-reactor nil '((:vlr-beginsave . copy_sv$)))))
(princ)

Link to comment
Share on other sites

REACTORSWIZ

A way to control visual lisp object reactors.

Routines samples included that generates a detail, keynote and a circle bubble symbols.

 

Some controls or features are:

- Position control of attributes.

- Assign one of the objects to control the copy when this object it is copied it will create a new symbol and add it to the same reactor.

- When one object from the symbol it is erased, the whole symbol will be erased too.

 

Hope it will make some sense...

 

Partial code sample.- (all the source code and vlisp .prj it is inside the attached zip)

;;LE
;; degrees
(setq :rwiz_45degrees (* pi 0.25))
(setq :rwiz_90degrees (* pi 0.5))
(setq :rwiz_135degrees (* pi 0.75))
(setq :rwiz_225degrees (* pi 1.25))
(setq :rwiz_270degrees (* pi 1.5))
(setq :rwiz_315degrees (* pi 1.75))
(setq :rwiz_360degrees (* pi 2.0))
;;;_____________________________________________________________
;; get acad object object
;; LE
(if (not :rwiz_acad)
   (setq :rwiz_acad (vlax-get-acad-object)))
;;;_____________________________________________________________
;;; get active drawing object
;;; LE
(defun rwiz-thisdwg () (vla-get-activedocument :rwiz_acad))
;; global variable for this drawing
;; LE
;;;(or :rwiz_thisdwg (setq :rwiz_thisdwg (rwiz-thisdwg)))
(setq
 :rwiz_thisdwg
  (cond (:rwiz_thisdwg)
 ((rwiz-thisdwg))
 (t (rwiz-thisdwg))))
;;;_____________________________________________________________
;; get model space object
;; LE
(if (not :rwiz_model)
   (setq :rwiz_model
   (vla-get-modelspace (rwiz-thisdwg))))
;;;_____________________________________________________________
;;; get paper space object
;;; LE
(defun rwiz-pspace () (vla-get-paperspace (rwiz-thisdwg)))
;;;_____________________________________________________________
;;; get active space object
(defun rwiz-get-activespace  ()
 (if (= acmodelspace (vla-get-activespace (rwiz-thisdwg)))
   :rwiz_model
   (if (= (vla-get-mspace (rwiz-thisdwg)) :vlax-true)
     :rwiz_model
     (rwiz-pspace))))
;;;_____________________________________________________________
;;; get active space name "Model" or "Paper"
(defun rwiz-activespacename  ()
 (cond
   ((= acmodelspace (vla-get-activespace (rwiz-thisdwg)))
    "Model")
   (t
    (if (= (vla-get-mspace (rwiz-thisdwg)) :vlax-true)
      "Model"
      "Paper"))))
;;;_____________________________________________________________
;;; adjust dimscale, it will use 1.0 factor when is in paper space
;;; sc = scale factor as real
;;; LE
(defun rwiz-adjust-dimscale  (sc)
 (if (= (rwiz-activespacename) "Model")
   sc
   1.0))
;;;_____________________________________________________________
;;; list to variant array
;;; ptslist = point list
(defun rwiz-list-variantarray  (ptslist / arrayspace sarray)
 (setq arrayspace
 (vlax-make-safearray
   ;; element type
   vlax-vbdouble
   ;; array dimension
   (cons 0
  (- (length ptslist) 1))))
 (setq sarray (vlax-safearray-fill arrayspace ptslist))
 ;; return array variant
 (vlax-make-variant sarray))
;;;_____________________________________________________________
;;; 3d point to 2d point
;;; 3dpt = 3d point
(defun rwiz-3dpt-2dpt  (3dpt)
 (list (float (car 3dpt)) (float (cadr 3dpt))))
;;;_____________________________________________________________
;;; selection set to vla objects list
;;; ss = selection set
(defun rwiz-ss-vla-list  (ss / index vlalist)
 (setq index (if ss
 (1- (sslength ss))
 -1))
 (while (>= index 0)
   (setq vlalist (cons
     (vlax-ename->vla-object
       (ssname ss index))
     vlalist)
  index   (1- index)))
 vlalist)
;;;_____________________________________________________________
;;; selection set to array
;;; ss = selection set
(defun rwiz-ss-array  (ss / c r)
 (setq c -1)
 (repeat (sslength ss)
   (setq r (cons (ssname ss (setq c (1+ c))) r)))
 (setq r (reverse r))
 (vlax-safearray-fill
   (vlax-make-safearray
     vlax-vbobject
     (cons 0 (1- (length r))))
   (mapcar 'vlax-ename->vla-object r)))
;;;_____________________________________________________________
;;; array of vbobject's
;;; vla_lst = vla-object list
;;; LE
(defun rwiz-array-vbobject  (vla_lst)
 (vlax-safearray-fill
   (vlax-make-safearray
     vlax-vbobject
     (cons 0 (1- (length vla_lst))))
   vla_lst))
;;;_____________________________________________________________
;;; make block
;;; usage:
;;; (rwiz-makeblock (list 0.0 0.0 0.0) "BLOCKNAME" selection_set T)
;;; flag:
;;; t = delete objects
;;; nil = keep objects
;;; LE
(defun rwiz-makeblock  (pt name ss flag / ssarray vla_block)
 (vla-copyobjects
   (rwiz-thisdwg)
   (setq ssarray (rwiz-ss-array ss))
   (setq vla_block (vla-add (vla-get-blocks (rwiz-thisdwg))
       (vlax-3d-point pt)
       name)))
 ;; delete objects
 (if (and flag
   ssarray
   (= (type ssarray) 'safearray)
   ;; is the safearray made of vlax-object's
   (= (vlax-safearray-type ssarray) 9))
   (mapcar 'vla-delete (safearray-value ssarray)))
 vla_block)
;;;_____________________________________________________________

 

...
 (cond
   ((and (equal (vlr-type reactor) :vlr-object-reactor)
  (vl-some 'vlax-erased-p (vlr-owners reactor)))
    (foreach owner  (vlr-owners reactor)
      (vlr-owner-remove reactor owner))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))
   ((and (equal (vlr-type reactor) :vlr-object-reactor)
  (not (vlr-owners reactor)))
    (foreach owner  (vlr-owners reactor)
      (vlr-owner-remove reactor owner))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))
   ((and (vlr-added-p reactor)
  (not (equal (vlr-type reactor)
       :vlr-object-reactor))
  (vl-some 'vlax-erased-p (vlr-data reactor)))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))
   ((and (vlr-added-p reactor)
  (not (equal (vlr-type reactor)
       :vlr-object-reactor))
  (not (vlr-data reactor)))
    (vlr-data-set reactor nil)
    (vlr-pers-release reactor))))
;;;_____________________________________________________________
(defun rwiz-update-pers-list  ()
 (mapcar
   (function
     (lambda (reactor)
(cond
  ((and (equal (vlr-type reactor) :vlr-object-reactor)
 (vl-some 'vlax-erased-p (vlr-owners reactor)))
   (foreach owner  (vlr-owners reactor)
     (vlr-owner-remove reactor owner))
   (vlr-data-set reactor nil)
   (vlr-pers-release reactor))
  ((and (equal (vlr-type reactor) :vlr-object-reactor)
 (not (vlr-owners reactor)))
   (foreach owner  (vlr-owners reactor)
     (vlr-owner-remove reactor owner))
   (vlr-data-set reactor nil)
   (vlr-pers-release reactor))
  ((and (vlr-added-p reactor)
 (not (equal (vlr-type reactor)
      :vlr-object-reactor))
 (vl-some 'vlax-erased-p (vlr-data reactor)))
   (vlr-data-set reactor nil)
   (vlr-pers-release reactor))
  ((and (vlr-added-p reactor)
 (not (equal (vlr-type reactor)
      :vlr-object-reactor))
...

symbols.png

reactorswiz.zip

Link to comment
Share on other sites

LCOPY

Line copier or multi line offseter, well what it does this super old routine is to draw or select a line and then after giving the offset distance and by moving the cursor it will do the offset to the side we move the cursor and perpendicular to the selected line.

 

Never finished the routine (it works as-is) and back then (on 1994) I was trying to emulate a command that I used from Intergraph Microstation 4.0 a great offset tool back then, and don't know if still available.

 

That one from Microstation, was able to select the line and move the cursor to one side and it will draw the offset's and going the opposite way it will erase the offset's lines.

 

To those lispers it might be a good challenge.

 

(vl-load-com)
(defun C:LCOPY (/      p1     p2     p3     p4    sep   lcopyent
 entlist       m      s     n    c   lst
 obj  take   code5  mklin     
       )  
;;;      (lbx-sysvarbegin
;;; '("cursorsize" "snapang" "orthomode")
;;;      )
;;; global symbol for angle direction
     (if (not atemp)
(setq atemp 0.0)
     )
;;; preset distance separation
     (if (not ll)
(setq ll 1.0)
     )
;;; just in case delete list of points
     (file2nil)
     (setq lst nil)
     (prompt
"\nLine Copier - inside this view only "
     )
     (setq mklin (vector))
     (if (= mklin nil)
(setq obj (entsel "\nSelect: "))
(progn (setq p1 (car mklin)) (setq p2 (cadr mklin)))
     )
     (if (and obj (= (cdr (assoc 0 (entget (car obj)))) "LINE"))
(progn
  (setq lcopyent (car obj))
;;;   (redraw lcopyent 3)
  (setq
    entlist (entget lcopyent)
    p1     (cdr (assoc 10 entlist))
    p2     (cdr (assoc 11 entlist))
  )
)
     )
     (setq lst (readfile))
     (if (and p1 p2)
(progn
  (if (and (not (member (point2str p1) lst))
    (not (member (point2str p2) lst))
      )
    (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
  )
  (if (not (member (point2str p1) lst))
    (write2file (point2str p1))
  )
  (if (not (member (point2str p2) lst))
    (write2file (point2str p2))
  )
  (setq lst (readfile))
)
     )
     (if p1
(progn
  (setvar "orthomode" 0)
  (initget 6)
  (setq sep
  (getdist
    (strcat "\nSelect two points/<Offset distance = "
     (rtos ll)
     ">: "
    )
  )
  )
  (if (= sep nil)
    (setq sep ll)
  )
  (if (not ll)
    (setq ll 1.0)
  )
  (setq ll sep)
)
     )
     (if (and p1 p2 sep)
(progn
  (prompt
    "\n<ENTER to stop>/Move the cursor to copy"
  )
  (while (not (equal (setq take (grread 't)) '(2 13)))
    (setq code5 (car take))
    (setq p3 (cadr take))
    (if (and p3 (= 5 code5))
      (progn
 (setq ;;find a point perpendicular to p1 & p2
       p4
        (inters p1
         p2
         p3
         (polar p3 (+ (angle p1 p2) (* pi 0.5)) 1.0)
         nil
        )
 )
 (setq ;;use p3 & p4 as a angle of copy, we need a parallel copy
       p1 (polar p1 (angle p4 p3) sep)
       p2 (polar p2 (angle p4 p3) sep)
 )
 (setq lst (readfile))
 (if (and p1 p2)
   (progn
     (if (and (not (member (point2str p1) lst))
       (not (member (point2str p2) lst))
  )
       (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
     )
     (if (not (member (point2str p1) lst))
       (write2file (point2str p1))
     )
     (if (not (member (point2str p2) lst))
       (write2file (point2str p2))
     )
   )
 )
      )
      (progn
 (prompt
   "\r<ENTER to stop>/Move the cursor to copy"
 )
 (alert
   "\nWorks only at the active view, other commands are disabled."
 )
      )
    )
  )
)
     )
;;;      (lbx-sysvarend)
 (princ)
)
;;; write strings points data to a working temporary file
(defun write2file (n / file p search)
 (setq search (acad-target))
 (setq file (open (strcat search "$par$") "a"))
 (write-line n file)
 (close file)
)
;;; read the working temporary file
(defun readfile (/ file n tmp search)
 (setq search (acad-target))
 (if (findfile (strcat search "$par$"))
   (progn
     (setq file (open (findfile (strcat search "$par$")) "r"))
     (while (setq n (read-line file))
(if (/= n "")
  (setq tmp (append tmp (list n)))
)
     )
     (close file)
   )
 )
 tmp
)
;;; delete working temporary file
(defun file2nil (/ search)
 (setq search (acad-target))
 (if (findfile (strcat search "$par$"))
   (vl-file-delete (findfile (strcat search "$par$")))
   nil
 )
)
;;; use AutoCAD location as a target directory
(defun acad-target ()
 (substr (findfile "ACAD.EXE")
  1
  (- (strlen (findfile "ACAD.EXE")) 
 )
)
;;; conversion of point list to string arguments
(defun point2str (n / x y z)
 (setq x (rtos (car n) 2 6)
y (rtos (cadr n) 2 6)
z (rtos (caddr n) 2 6)
 )
 (strcat x y z)
)
(defun rtd (a) (* (/ a pi) 180.0))
;;; alignment angle (vector direction)
(defun aangle (/ p1 ang)
 (setq p1 (getpoint "\n<Select LINE>/Line from: "))
 (if p1
   (progn
     (setq
ang (getangle
      (strcat "\nAlignment angle <"
       (rtos (rtd atemp) 2 0)
       ">: "
      )
      p1
    )
     )
     (if (= ang nil)
(setq ang atemp)
     )
     (setq atemp ang)
     (setvar "orthomode" 1)
     (list ang p1)
   )
   nil
 )
)
;;; do a vector, returns: list of two
;;; points to construct the vector or nil
(defun vector (/ anglin ang p1 sep)
 (setq sna (getvar "snapang"))
 (setq anglin (aangle))
 (if anglin
   (progn
     (setq ang (car anglin))
     (setq p1 (cadr anglin))
     (setvar "snapang" ang)
     (setq size (getvar "cursorsize"))
     (setvar "cursorsize" 1)
     (initget 6)
     ;;no zero, no negative
     (setq sep
     (getdist p1
       (strcat "\nNext point/Length <"
        (rtos ll)
        ">: "
       )
     )
     )
     (if (= sep nil)
(setq sep ll)
     )
     (if (not ll)
(setq ll 1.0)
     )
     (setq ll sep)
     (if sna
(setvar "snapang" sna)
     )
     (if size
(setvar "cursorsize" size)
     )
     (list p1 (polar p1 ang sep))
   )
   nil
 )
)
(princ)

Link to comment
Share on other sites

CIRCLE TO POLY

A way to convert circle entities to polylines.

 

(vl-load-com)
(defun circ2poly
      (obj / ctr radio a b c d pts vla_poly color_use space)
 (if (wcmatch (getvar "acadver") "16*,17*,18*")
   (setq color_use (vla-get-colorindex (vla-get-truecolor obj))))
 (if (wcmatch (getvar "acadver") "15*")
   (setq color_use (vla-get-color obj)))
 (setq ctr (vlax-get obj 'center))
 (setq radio (vlax-get obj 'radius))
 (setq a (polar ctr pi radio))
 (setq b (polar ctr 0.0 radio))
 (setq c (polar ctr (* pi 0.5) radio))
 (setq d (polar ctr (* pi 1.5) radio))
 (setq pts (mapcar '2dpt (list a b)))
 (setq
   space (vla-objectidtoobject
    (vla-get-database obj)
    (vla-get-ownerid obj)))
 (if (not (vl-catch-all-error-p
     (setq vla_poly
     (vl-catch-all-apply
       'vla-addlightweightpolyline
       (list space
      (lstVariantarray (apply 'append pts)))))))
   (vla-put-closed vla_poly t))
 (vla-setbulge
   vla_poly
   0
   (getBulge a c b))
 (vla-setbulge
   vla_poly
   1
   (getBulge b d a))
 (putColor vla_poly color_use)
 vla_poly)

(defun 2dpt  (pt)
 (if (caddr pt)
   (list (car pt) (cadr pt))
   pt))

(defun putColor  (obj color_use)
 (if (wcmatch (getvar "acadver") "16*,17*,18*")
   (setq vla_truecolor
   (vla-getinterfaceobject
     (vlax-get-acad-object)
     (cond
       ((wcmatch (getvar "acadver") "16*")
 "AutoCAD.AcCmColor.16")
       ((wcmatch (getvar "acadver") "17*")
 "AutoCAD.AcCmColor.17")
       ((wcmatch (getvar "acadver") "18*")
 "AutoCAD.AcCmColor.18")))))
 (if (wcmatch (getvar "acadver") "16*,17*,18*")
   (progn
     (vla-put-colorindex
vla_truecolor
color_use)
     (if obj
(vla-put-truecolor obj vla_truecolor)))
   (if (wcmatch (getvar "acadver") "15*")
     (vla-put-color obj color_use)))
 (vlax-release-object vla_truecolor)
 (setq vla_truecolor nil))

(defun lstVariantarray  (ptslist / arrayspace sarray)
 (setq arrayspace
 (vlax-make-safearray
   vlax-vbdouble
   (cons 0
  (- (length ptslist) 1))))
 (setq sarray (vlax-safearray-fill arrayspace ptslist))
 (vlax-make-variant sarray))

(defun getBulge  (fromvertex midp p2 / ang chord midc alt)
 (setq ang   (angle fromvertex p2)
chord (distance fromvertex p2)
midc  (polar fromvertex ang (* chord 0.5))
alt   (distance midp midc))
 (cond
   ((zerop chord) 0.0)
   ((equal (angle midp midc)
    (rem (+ ang (* pi 0.5)) (* pi 2))
    1e-4)
    (/ alt chord 0.5))
   (t (/ alt chord -0.5))))

(defun ss2lst  (ss / i lst)
 (setq i (if ss
    (1- (sslength ss))
    -1))
 (while (>= i 0)
   (setq lst (cons
 (vlax-ename->vla-object
   (ssname ss i))
 lst)
  i   (1- i)))
 lst)

;; single
(defun C:SCIRC2POLY  (/ obj)
 (setq
   obj (vlax-ename->vla-object (car (entsel "\nSelect Circle: "))))
 (circ2poly obj))

;; multiple
(defun C:MCIRC2POLY  (/ ss lst)
 (if (setq ss (ssget '((0 . "CIRCLE"))))
   (progn
     (setq lst (ss2lst ss))
     (foreach obj lst (circ2poly obj))))
 (princ))
(princ)

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...