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

Change Text Style

(defun c:CTS(/ *error* adoc sset userkey ApplyStyle CreateTextStyles)
    (vl-load-com) ;Load activex Support
    (defun *error* (s)
     (if adoc (vla-endundomark adoc))
  (if (not (member s '("Function cancelled" "quit / exit abort")))
      (princ (strcat "\n---->Error:" s))
  )
  (princ)
 )
 (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
 (setq cmh (getvar 'cmdecho))
 (vla-startundomark adoc)
 (setvar 'cmdecho 0)
 ;;Apply Text Styles 
    (defun CreateTextStyles (name ttf)
       (if 
     (not (tblsearch "STYLE" name))
  (progn
      (if
       (or
        (member name '("ROMANS" "R"))
     (member name '("STANDARD" "S"))
    )
       (vl-cmdf "_.Style" name ttf "" "" "" "n" "n" "n")
       (vl-cmdf "_.Style" name ttf "" "" "" "n" "n")
      )
  )
 )
   )
   (defun ApplyStyle (ss sname / en i)
    (repeat (setq i (sslength ss))
     (setq en (vlax-ename->vla-object (ssname ss(setq i (1- i)))))
  (if (vlax-write-enabled-p en)
      (vlax-put-Property en 'StyleName sname)
  )
 )
)
 (if (setq sset (ssget '((0 . "TEXT,MTEXT"))))
     (progn
      (if (setq userkey (strcase (getstring "\nEnter New Style Name <ARial/Times Roman/Romans/STandard>:")))
       (progn
        (cond
         (  
          (or
           (or
            (= userkey "AR")
         (= userkey "A")
         (= userkey "ARIAL")
        )
       )
       (progn
           (createTextStyles "ARIAL" "Arial")
        (ApplyStyle sset "ARIAL")
       )
      )
         (
          (= userkey "T")
       (progn
           (CreateTextStyles "Times New Roman" "Times New Roman")
        (ApplyStyle sset "Times New Roman")
       )
      )
      (   
          (or
           (or
            (= userkey "ROMANS")
         (= userkey "R")
        )
       )
       (progn
           (CreateTextStyles "ROMANS" "Romans.shx")
        (ApplyStyle sset "ROMANS")
       )
      )
      (
          (or
           (or
            (= userkey "STANDARD")
         (= userkey "S")
         (= userkey "ST")
        )
       )
       (progn
           (CreateTextStyles "STANDARD" "Txt.shx")
        (ApplyStyle sset "STANDARD")
       )
      )
      (t
          (if (= userkey "")
              (princ "\nInvalid entry Try again.")
              (progn
                  (if (not (tblsearch "STYLE" userkey))
               (princ (strcat "\nText Style < " userkey " > not found!"))
               (ApplyStyle sset userkey)
           )
       )
            )
       
      )
     )
    )
   )
  )
  (*error* "non objects found!")
 )
 (vla-endundomark adoc)
 (princ)
)

Read More

Polyline Measurments

Info : Creates Distance Text  to Selected Polylines , Lwpolyline and Line

(defun c:mse (/ *error* adoc space sset i ang e en p s nd _Text c pp p1
       p2)
    (vl-load-com)
    (defun *error* (x)
 (if adoc
     (vla-endundomark adoc)
 )
 (cond ((not x))
       ((member x '("Function cancelled" "quit / exit abort")))
       ((princ (strcat "\n----> Error:" x)))
 )
 (princ)
    )
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    (setq space (vla-get-modelspace adoc))
    (vla-startundomark adoc)
    (prompt "\nSelect LINE,POLYLINES,LWPOLYLINES")
    (if (setq sset (ssget "_:L"
     '((-4 . "<Or")
       (0 . "LINE")
       (0 . "LWPOLYLINE")
       (0 . "POLYLINE")
       (-4 . "Or>")
      )
     )
 )
 (progn
     (defun ang (a b / ang1)
  (setq ang1 (atof (angtos (angle a b))))
  (if
      (and
   (>= ang1 90.0)
   (<= ang1 273.0)
      )
         (angle b a)
         (angle a b)
  )
     )

      (repeat (setq i (sslength sset))
  (setq e (ssname sset (setq i (1- i))))
  (setq en (entget e))
  (if (= "LINE" (cdr (assoc 0 en)))
      (progn (setq s (cdr (assoc 10 en)))
      (setq nd (cdr (assoc 11 en)))
      (setq p  (mapcar
     (function (lambda (a b) (/ (+ a b) 2.))
     )
     s
     nd
        )
      )
      (setq _Text (vla-addtext
        space
        (rtos (distance s nd))
        (vlax-3d-point p)
        2.0
           )
      )
      (vla-put-alignment
          _Text
          acalignmentbottomcenter
      )
      (vla-put-TextAlignMentPoint
          _Text
          (vlax-3d-point p)
      )
      (vla-put-Rotation _Text (ang s nd))
      )
      (progn (setq c 0)
      (repeat (- (fix (vlax-curve-getendparam e))
          (fix (vlax-curve-getstartparam e))
       )
          (setq pp (mapcar
         (function
      (lambda (a b) (/ (+ a b) 2.))
         )
         (setq p1 (vlax-curve-getpointatparam
        e
        c
           )
         )
         (setq p2 (vlax-curve-getpointatparam
        e
        (setq c (1+ c))
           )
         )
     )
          )

           (setq _Text (vla-addtext
            space
            (rtos (distance p1 p2))
            (vlax-3d-point pp)
            2.0
        )
          )
          (vla-put-alignment
       _Text
       acalignmentbottomcenter
          )
          (vla-put-TextAlignMentPoint
       _Text
       (vlax-3d-point pp)
          )
          (vla-put-Rotation _Text (ang p1 p2))
      )
      )
  )
     )
 )
    )
    (*error* nil)
    (vla-endundomark adoc)
    (vlax-release-object adoc)
    (princ)
)

Read More

Line Total

(defun c:Line_Total(/ sset *adco* total len)
;;Author:Ganesh Shetty, Copyright © 2013 -http://autolispgs.blogspot.in
  (vl-load-com)
  (if (setq sset (ssget "_:L" '((-4 . "<Or")
(0 . "POLYLINE")
(0 . "LINE")
(0 . "LWPOLYLINE")
(-4 . "or>"))

)
)
    (progn
      (setq *adoc*(vla-get-activedocument(vlax-get-acad-object)))
      (setq total 0)
      (vlax-for x (setq sset(vla-get-activeselectionset *adoc*))
(setq len(vlax-curve-getdistatparam x (vlax-curve-getendparam x)))
(setq total(+ total len))
      )
      (alert (strcat "\nTotal Line Total is  : " (rtos total)))
      (vla-delete sset)
    )
  )
  (princ)
 )

Read More

Create New Layer

Autolisp Codes :
(defun c:Newlayer (/ Layername Color)
  ;;Author:Ganesh Shetty, Copyright © 2013 -http://autolispgs.blogspot.in
  (setq Layername(getstring "\nEnter New Layer Name:"))
  (if (not (Tblsearch "LAYER" Layername))
    (progn
      (setq color(getint "\nEnter Color Type for New Layer:"))
      (command "_Layer" "New" layername "c" color layername "")
      (princ(strcat "\nLayer \"" layername "\"Created ."))
    )
    (princ "\nLayer Name Already exist.")
  )
  (princ)
);end defun



Visual Lisp Codes:


(Defun c:New-layer()
  (vl-load-com)
  (setq *Activedoc(vla-get-activedocument(vlax-get-acad-object)))
  (setq layers(vla-get-layers *Activedoc))
  (setq Nlay(getstring "\nEnter New Layer Name:"))
  (if
    (not
      (vl-catch-all-error-p
(vl-catch-all-apply 'Vla-item (list layers Nlay))
      )
    )
    (princ "\nLayer Name Already exist.")
    (progn
      (setq laycol(getint "\nEnter Color for New Layer:"))
      (vla-put-color (vla-add layers Nlay) laycol)
      (princ(strcat "\nLayer \"" Nlay "\"Created ."))
    )
  )
  (vlax-release-object *Activedoc)
  (princ)
)

Read More

Set Current Layer

Autolisp Codes:

(defun c:Sl(/ old_cmh sel ent laynme )
;;Author:Ganesh Shetty, Copyright © 2013 -http://autolispgs.blogspot.in
  (setq old_cmh(getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (if (setq sel (car (entsel "\nSelect an Object to set Layer Current:")))
    (progn
      (setq ent(entget sel))
      (setq laynme(cdr (assoc 8 ent)))
      (command "_Layer" "set" laynme "")
      (princ (strcat "\nLayer \""   laynme "\" is  Current Now:"))
    )
  )
  (setvar 'cmdecho oldcmh)
  (princ)
)

Visual Lisp Codes:

(defun c:Sl (/ *Activedoc* *Layers* ename Sel);(S)et (L)ayer
;;Author:Ganesh Shetty, Copyright © 2013 -http://autolispgs.blogspot.in
  (vl-load-com)    ;loading Activex Support
  (setq *Activedoc* (vlax-get-property
        (vlax-get-acad-object)
        'Activedocument
      )
 *Layers*    (vlax-get-property *Activedoc* 'Layers)
  )
  (if (setq sel (car (entsel "\nSelect an Object to Set layer Current:")))
    (progn
      (setq ename(vlax-ename->vla-object sel))
      (vla-put-activelayer *Activedoc* (vla-item *layers* (vla-get-layer ename)))
      (princ (strcat "\nLayer \""   (vla-get-layer ename) "\" is  Current Now:"))
    )
  )
  (princ)
)

Read More

Match Layer

(defun c:Cl (/ *error* adoc sset e lay layname e changelayer)
    (defun *error* (s)
     (if adoc (vla-endundomark adoc))
  (if (not (member s '("Function cancelled" "quit / exit abort")))
      (princ (strcat "\n---->Error:" s))
  )
  (princ)
 )
(defun changelayer (ent name / ss ename i)
  (if (> (sslength ent) 1)
    (princ (strcat "\n"(rtos (sslength ent) 2 0)  "  objects changed Layer to \"" name "\""))
    (princ (strcat   "\nOne object changed Layer to \"" name "\""))
  )
  (repeat (setq i(sslength ent))
    (setq ss(ssname ent(setq i(1- i))))
    (setq ename(vlax-ename->vla-object ss))
    (if (vlax-write-enabled-p ename)
      (vla-put-layer ename name)
    )
  )
)
 (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark adoc)
 (if (setq sset (ssget "_:L"))
     (progn
      (while 
       (progn
           (setvar 'errno 0)
           (initget "TypeIt")
        (setq sel (entsel "\nSelect an Object for Layer or [Type It]:"))
        (cond
            ( (= 7 (getvar 'errno) )
           (princ "\nNothing Selected.")
         )
         ( (= sel "TypeIt")
           (setq Lay (getstring "\nEnter Layer Name:"))
        (if (not (tblsearch "LAYER" Lay))
          (progn
              (princ (strcat "\nEntered Layer Name \"" lay "\" Does Not exist in Layers List!"))
        (princ "\nTry again.")
       )
       (changelayer sset lay)
        ) 
           
         )
         ( (= 'ename (Type (car sel)))
           (setq e (vlax-ename->vla-object (car sel)))
        (if (vlax-property-available-p e 'Layer)
               (setq layname(vla-get-layer e))
        )
           (changelayer sset layname)
         )
     )
    )
   )
  )
  (*error* "Non Objects Selected!")
 )
 (vla-endundomark adoc)
 (princ)
)

Read More

Change Text Height Globally

(defun c:CTH(/ *error* adoc sset value i en)
    (vl-load-com);Load Activex Support
    (defun *error* (s)
     (if adoc (vla-endundomark adoc))
  (if (not (member s '("Function cancelled" "quit / exit abort")))
      (princ (strcat "\n---->Error:" s))
  )
  (princ)
 )
 (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark adoc)
 (if
     (and
      (setq sset (ssget '((0 . "TEXT,MTEXT"))))
   (setq value (getreal "\nEnter New Height Value:"))
  )
  (progn
      (if (<= value 0)
       (*error* "Negative Values Not Allowed")
    (progn
        (repeat (setq i (sslength sset))
         (setq en (vlax-ename->vla-object (ssname sset (setq i (1- i)))))
      (if (vlax-write-enabled-p en)
          (vlax-put-property en 'Height value)
      )
     )
    )
   )
  )
 )
 (vla-endundomark adoc)
 (princ))

Read More

Change Rotation Angle

(defun c:CTR(/ *error* )
    (vl-load-com);Load Activex Support
    (defun *error* (s)
     (if adoc (vla-endundomark adoc))
  (if (not (member s '("Function cancelled" "quit / exit abort")))
      (princ (strcat "\n---->Error:" s))
  )
  (princ)
 )
 (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark adoc)
 (if
     (and
      (setq sset (ssget '((0 . "TEXT,MTEXT"))))
   (setq value (getreal "\nEnter New Rotation Value in Degrees:"))
  )
  (progn
      (if (< value 0)
       (*error* "Negative Values Not Allowed")
    (progn
        (repeat (setq i (sslength sset))
         (setq en (vlax-ename->vla-object (ssname sset (setq i (1- i)))))
      (if (vlax-write-enabled-p en)
          (vlax-put-property en 'Rotation (DTR value))
      )
     )
    )
   )
  )
 )
 (vla-endundomark adoc)
 (princ))
 ;;Sub function for Convert Degree to Radians;;
 (defun DTR (a)
     (* pi (/ a 180.0))
 )

Read More