;;;-------======={ Insert Blocks Program }======------------
;;; Description : Insert Block for Selected
;;; "TEXT" "MTEXT"...
Sunday, 9 February 2014
Sunday, 15 December 2013
Posted by Unknown on 01:17 with No comments
[ ---- ===={ Subtract Text Digits from last}=====----------------------]
[Author: Ganesh Kumar, Copyright © 2012 -www.autolispgs.blogspot.in ]
[-------------------------------------------------------------------------]
(defun c:ltd(/ *error* adoc digits en textval slen textupdate Loop)
(vl-load-com)
(defun *error* (msg)
(if adoc (vla-endundomark adoc))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\n--->Error :"msg))
)
(princ)
)
(setq adoc(vla-get-activedocument...
Saturday, 14 December 2013
Posted by Unknown on 07:04 with No comments
(defun c:mmv (/ *error* sset i en textvalue maxval minval valuelist)
(vl-load-com)
(defun *error* (msg)
(if (not
(member msg '("Function cancelled" "quit / exit abort"))
)
(princ (strcat "\n---->error:" msg))
)
(princ)
)
(setq valuelist nil)
(if (setq sset (ssget '((0 . "TEXT,MTEXT") (1 . "##.###,#*"))))
(progn
(if (= (sslength sset) 1)
(alert "\n Select at least Two Text!")
(progn
(repeat (setq i (sslength sset))
(setq en (vlax-ename->vla-object
(ssname sset (setq i (1- i)))
...
Wednesday, 27 March 2013
Posted by Unknown on 22:18 with No comments
(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)
...
Posted by Unknown on 21:54 with 1 comment
(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...
Posted by Unknown on 21:51 with No comments
(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...
Posted by Unknown on 04:40 with No comments
(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...
Tuesday, 26 March 2013
Posted by Unknown on 22:33 with No comments
(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...
Monday, 25 March 2013
Posted by Unknown on 22:12 with No comments
(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))
...
Sunday, 24 March 2013
Posted by Unknown on 23:06 with No comments
(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...
Thursday, 14 March 2013
Posted by Unknown on 05:46 with No comments
;; 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...
Monday, 18 February 2013
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
...
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...
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...
Posted by Unknown on 00:14 with 1 comment
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...
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:"))
...
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...
Subscribe to:
Posts (Atom)
