Export Text Co-Ordinates to CSV File

(defun c:T_export(/ *error* file sset ename lst i p string)
     (vl-load-com)
     (defun *error* (s)
          (if file (close file))
          (cond
       ( ( not s ) )
       ( (member s '("Function cancelled" "quit / exit abort") ) )
       ( (princ (strcat "\n---->Error:" s) ) )
   )
       (princ))
       (if (setq sset (ssget "_:L" '((0 . "TEXT,MTEXT"))))
    (progn
         (if (setq file (open (strcat (getvar 'dwgprefix) "Text Coordinates.csv") "w"))
      (progn
           (write-line (strcat "String Name" "," "X" "," "Y") file)
           (repeat (setq i (sslength sset))
         (setq ename (entget (ssname sset (setq i (1- i)))))
         (if
     (or
        (= "MTEXT" (cdr (assoc 0 ename)))
        (and
          (zerop (cdr (assoc 72 ename)))
          (zerop (cdr (assoc 73 ename)))
        )
      )
    (setq p (cdr (assoc 10 ename)))
    (setq p (cdr (assoc 11 ename)))
         )
         (setq string (cdr (assoc 1 ename)))
         (write-line (strcat string "," (rtos (car p)) "," (rtos (cadr p))) file)
    )
           (close file)
           (alert "\nVertex Points exported to csv file.")
           (alert (strcat "File saved in - "(getvar 'dwgprefix) "Text Coordinates.csv"))
          
       )
       (alert "\nCSV file Currenty running, Close it first.")
    )
      )
  (*error* "Nothing selected")
       )
       (*error* nil)
       (princ)
  )

Read More

Write Polyline Vertex Points to CSV File

(defun c:Pl_export(/ *error* file sset  ename lst)

     (vl-load-com)
     (defun *error* (s)
          (if file (close file))
          (cond
       ( ( not s ) )
       ( (member s '("Function cancelled" "quit / exit abort") ) )
       ( (princ (strcat "\n---->Error:" s) ) )
   )
       (princ))
       (if (setq sset (ssget "_:L" '((0 . "POLYLINE"))))
    (progn
         (if (setq file (open (strcat (getvar 'dwgprefix) "Polyline Vertex List.csv") "w"))
      (progn
           (write-line (strcat "X" "," "Y" "," "Z") file)
           (repeat (setq i (sslength sset))
         (setq ename (vlax-ename->vla-object (ssname sset (setq i (1- i)))))
         (setq lst (vlax-safearray->list
       (vlax-variant-value
         (vla-get-coordinates ename)
       )
     )
         )
         (repeat (/ (length lst) 3)
       (write-line (strcat (rtos (car lst)) "," (rtos (cadr lst)) "," (rtos (caddr lst))) file)
       (setq lst (cdddr lst))
         )
    )
           (close file)
           (alert "\nVertex Points exported to csv file.")
           (alert (strcat "File saved in - "(getvar 'dwgprefix) "Polyline Vertex List.csv"))
      )
      (alert "\nCSV file Currenty running, Close it first.")
  )
     )
     (*error* "Nothing Selected.")
 )
        (*error* nil)
        (princ)
 )

Read More

Write LWpolyline Vertex Points to CSV File

(defun c:Lw_export (/ *error* file sset ename lst i)
    (vl-load-com)
    (defun *error* (s)
 (if file
     (close file)
 )
 (cond
     ((not s))
     ((member s '("Function cancelled" "quit / exit abort")))
     ((princ (strcat "\n---->Error:" s)))
 )
 (princ)
    )
    (if (setq sset (ssget "_:L" '((0 . "LWPOLYLINE,POLYLINE"))))
 (progn
     (if (setq file (open (strcat (getvar 'dwgprefix)
      "Lwpolyline Vertex List.csv"
     )
     "w"
      )
  )
  (progn
      (write-line (strcat "X" "," "Y") file)
      (repeat (setq i (sslength sset))
   (setq ename (vlax-ename->vla-object
     (ssname sset (setq i (1- i)))
        )
   )
   (setq lst (vlax-safearray->list
          (vlax-variant-value
       (vla-get-coordinates ename)
          )
      )
   )
   (repeat (/ (length lst) 2)
       (write-line
    (strcat (rtos (car lst))
     ","
     (rtos (cadr lst))
    )
    file
       )
       (setq lst (cddr lst))
   )
      )
      (close file)
      (alert "\nVertex Points exported to csv file.")
      (alert (strcat "File saved in - "
       (getvar 'dwgprefix)
       "Lwpolyline Vertex List.csv"
      )
      )
  )
  (alert "\nCSV file Currenty running, Close it first.")
     )
 )
 (*error* "Nothing Selected.")
    )
    (*error* nil)
    (princ)
)

Read More

Change Polyline Width

(defun c:lw (/ *error* acdoc width ss )
  (vl-load-com)
  (defun *error* (s)
       (if acdoc (vla-endundomark acdoc))
          (cond
        ( (not s ) )
        ( (member s '("Function cancelled" "quit / exit abort") ) )
        ( (vl-exit-with-error (strcat "\n----Error:" s) ) )
   )
    (princ))
  (setq acdoc (vla-get-activedocument
            (vlax-get-acad-object)
       )
  )
  (vla-startundomark acdoc)
  (if (setq ss (ssget "_:L" '((0 . "LWPOLYLINE"))))
      (progn
    (setq width (getreal "\nEnter New Width Value:"))
    (vlax-for each (setq ss (vla-get-activeselectionset acdoc))
      (if (vlax-property-available-p each 'ConstantWidth)
        (vlax-put each 'ConstantWidth width)
      )
 )
 (vla-delete ss)
      )
    )
    (*error* nil)
    (princ))

Read More

Delete layer Entity

(defun c:Dle (/ ext lst s sset lay)
    (while (null ext)
 (setvar 'errno 0)
 (if sset
     (initget "Undo")
 )
 (setq s (entsel "\nPick An object to Erase[Undo]:"))
 (cond
     ((= 7 (getvar 'errno))
      (princ "\nMissed.Try again.")
     )
     ((= "Undo" s)
      (if lst
   (progn
       (setq sset (car lst))
       (setq lst (cdr lst))
       (repeat (sslength sset)
    (entdel (ssname sset 0))
    (ssdel (ssname sset 0) sset)
       )
   )
   (princ "\nNothing to Undo.")
      )
     )
     ((= 'ename (type (car s)))
      (setq lay (cdr (assoc 8 (entget (car s)))))
      (if (/= (getvar 'clayer) lay)
   (progn
       (setq sset (ssget "x" (list (cons 8 lay))))
       (command "_.ERASE" sset "")
       (setq lst (cons sset lst))
   )
   (princ "\nCannot Delete Current Layer.")
      )
     )
     ((setq ext t))
 )
    )
    (princ)
)

Read More

Totaling Text Values

(defun c:TTx ()
    (defun *error* (msg)
(if (not
(member msg '("Function cancelled" "quit / exit abort"))
   )
      (princ msg)
)
(setvar 'cmdecho cmh)
(princ)
    )
    (setq cmh (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (if (setq ss (ssget '((0 . "TEXT") (1 . "##.###,#*"))))
(progn
   (setq cntr 0
 len (sslength ss)
 total 0
   )
   (repeat len
(setq ssnm (ssname ss cntr))
(setq ent (entget ssnm))
(setq val (atof (cdr (assoc 1 ent))))
(setq total (+ total val))
(setq cntr (1+ cntr))
   )
   (if (setq TExt
(car (entsel "\nSelect A TExt To rePlace Value:"
     )
)
)
(progn
   (entmod (subst (cons 1 (rtos total 2 3))
  (assoc 1 (entget TExt))
  (entget TExt)
   )
   )
   (entupd TExt)
)
(princ "\nError No Text Selected:")
   )
)
(princ "\nError No Texts Selected for Total Value:")
    )
    (*error* "")
    (princ)
)

Read More

Image Clipper

(defun c:icp (/ image object fuzz i l len p lst pts)
    (vl-load-com)
    (if
 (and
     (setq image (car (entsel "\nSelect RasterImage:")))
     (setq Object (car (entsel "\nSelect Clipping Object:")))
 )
    (progn
        (setq l   nil
       fuzz 0.1
       i   fuzz
        )
        (cond
     ((eq (cdr (assoc 0 (entget object))) "CIRCLE")
      (setq len (vlax-get (vlax-ename->vla-object object)
     'circumference
         )
      )
      (repeat (fix (/ len fuzz))
   (setq p (vlax-curve-getpointatdist object fuzz))
   (setq l (cons (list (car p) (cadr p)) l))
   (setq fuzz (+ i fuzz))
      )
      (setq lst (apply 'append (reverse l)))
      (vla-put-ClippingEnabled
   (vlax-ename->vla-object image)
   :vlax-true
      )
      (vla-clipboundary
   (vlax-ename->vla-object image)
   (gs:Safearray lst)
      )
      (vla-delete (vlax-ename->vla-object object))
     )
     ((eq (cdr (assoc 0 (entget object))) "LWPOLYLINE")
      (vla-put-ClippingEnabled
   (vlax-ename->vla-object image)
   :vlax-true
      )
      (setq pts (vlax-safearray->list
      (vlax-variant-value
          (vla-get-coordinates
       (vlax-ename->vla-object object)
          )
      )
         )
      )
      (vla-clipboundary
   (vlax-ename->vla-object image)
   (gs:Safearray pts)
      )
      (vla-delete (vlax-ename->vla-object object))
     )
        )
    )
    )
    (princ)
)
(defun gs:Safearray (points / arrayspace)
    (setq arrayspace
      (vlax-make-safearray
   vlax-vbdouble
   (cons 0 (1+ (length points)))
      )
    )
    (vlax-safearray-fill
 arrayspace
 (append points (list (car points) (cadr points)))
    )
)

Read More

Find Mid Points Between Two Valid Points

;; Sub Programs for Get Mid Point Between Two Points

;Method-1
(defun _Midpoint (a b)
    (list
(/ (+ (car a) (car b)) 2)
(/ (+ (cadr a) (cadr b)) 2)
    )
)
;Method-2
(defun _Midpoint (a b)
    (setq ang (angle a b))
    (setq distoff (/ (distance a b) 2))
    (polar a ang distoff)
)

;Method-3
(defun c:Test ()
    (setq a (getpoint)
 b (getpoint)
    )
    (setq ang (angle a b))
    (setq ofdist (/ (distance a b) 2))
    (setq m (polar a ang ofdist))
    (command "circle" m 2)
)

Read More