Monday 18 February 2013

Change Text Style

Posted by Unknown on 22:40 with No comments 
(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)
)

Polyline Measurments

Posted by Unknown on 22:35 with No comments


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)
)

Line Total

Posted by Unknown on 02:39 with No comments

(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)
 )

Create New Layer

Posted by Unknown on 00:14 with 2 comments




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)
)




Set Current Layer

Posted by Unknown on 00:13 with No comments

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)
)

Match Layer

Posted by Unknown on 00:12 with No comments 
(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)
)

Change Text Height Globally

Posted by Unknown on 00:10 with No comments 
(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))

Change Rotation Angle

Posted by Unknown on 00:09 with No comments 
(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))
 )
Subscribe to: Posts (Atom)