PC: 2014

Extract text from drawing

;;By Dereje Kitaw
(defun C:trtr (/ eset
MULTILEADER_ERM_L80n MULTILEADER_ERM_L90n
MULTILEADER_ERM_L140A
) ;define a program name
(vl-load-com)
(or station (setq station "F00"))
(if (/= ""
(setq
strdia (getstring
(strcat "\nEnter Station Code <" station "> ")
)
)
)
(setq station strdia)
)

(or file_name (setq file_name "mydata"))
(if (/= ""
(setq
file_name_new
(getstring
(strcat "\nEnter File Name <" file_name "> ")
)
)
)
(setq file_name file_name_new)
)

(if (setq eset (ssget)) ;use the ssget function to select entities

(progn ;use progn since there will be more than 1 statement

(setq cntr 0) ;set the cntr to the first item in the set
(setq MTexT_Set (ssadd))
(setq MULTILEADER_Set (ssadd))
(setq TEXT_Set (ssadd))

;;; (setq wf (open "D:\mydata.txt" "w"))
(setq file_1 "D:/")
(setq wf (open (strcat file_1 file_name ".txt") "w"))

(while (< cntr (sslength eset)) ;while cntr is less than the length of the set

;;; Note: the length is one more than the index of items since the first item is zero. In other words, to
;;; get to the first item in a selection set consisting of one item you would use (ssname eset 0) not
;;; (ssname eset 1).

(setq en (ssname eset cntr)) ;get the entity name of the item indexed with cntr

(setq enlist (entget en)) ;get the dxf group codes of the enitity

(setq entity_name (cdr (assoc 0 enlist))) ;get the layer name

;;; (princ "\n ") ;print "\n " will cause a new line to be printed

;;; (princ entity_name) ;print the layer name to the command line
(cond
((= entity_name "MTEXT")
(progn
(setq
content (cdr (assoc 1 (entget en)))
)

(setq val (strcat station "," content))
(write-line val wf)
)

)

((= entity_name "MULTILEADER")
(progn
(setq
content
(cdr (assoc 304 enlist))
)
(setq val (strcat station "," content))
(write-line val wf)

)
)

((= entity_name "TEXT")
(progn
(setq content (cdr (assoc 1 (entget en))))

;;; (setq
;;; content
;;; (cdr (assoc 2 (entget (cdr (assoc 304 enlist)))))
;;; )
(setq val (strcat station "," content))
(write-line val wf)

)
)

)
(setq cntr (+ cntr 1)) ;increment the counter

) ;close the while statement
(close wf)
) ;close the progn on the if statement

(princ "\n Error - No entities selected.")
;print a message on the else statement

; note: the if statement can be a " if then " statement or a " if then else" statement

) ;close the if statement

)

Align Text

(defun c:rrt (/
; local functions
getSegment get-opp-ang undobegin undoend
; local variables
ent txt_ent obj txt_obj obj_typ ang ans
)

;;; FUNCTION
;;; rotates the user selected (M)TEXT to the user selected
;;; entity. valid entites are light weight plines, lines
;;; and (m)text. you are given the chance to rotate the
;;; by 180 degrees after intial rotation.
;;;
;;; ARGUMENTS
;;; none
;;;
;;; USAGE
;;; enter RRT on the comand line
;;;
;;; PLATFORMS
;;; 2000+
;;;
;;; AUTHOR
;;; Copyright© 2004 Mark S. Thomas
;;; mark_AT_theswamp.org
;;;
;;; VERSION
;;; 1.0 Tue Dec 07, 2004
;;; 1.1 Tue Dec 21, 2004 ; added ARC types
;;; 1.1a Tue Dec 21, 2004 ; reversed the pick order
;;;
;;; TODO:
;;; handle text that has 'fit' justification
;;; add more entites for angle extraction
;;; more testing

(vl-load-com)

;; credit Stig Madsen
;; refer to thread titled "relaxed-curves" under the "Teach Me"
;; section of TheSwamp at www.theswamp.org/phpBB2/
(defun getSegment (obj pt / cpt eParam stParam)
(cond ((setq cpt (vlax-curve-getClosestPointTo obj pt))
(setq eParam (fix (vlax-curve-getEndParam obj)))
(if (= eParam (setq stParam (fix (vlax-curve-getParamAtPoint obj cpt))))
(setq stParam (1- stParam))
(setq eParam (1+ stParam))
)
(list eParam (vlax-curve-getPointAtParam obj stParam)
(vlax-curve-getPointAtParam obj eParam))
)
)
)

;; undo functions
(defun undobegin ()
(vla-EndUndoMark
(vlax-get-property
(vlax-get-acad-object)
'ActiveDocument
)
)
(vla-StartUndoMark
(vlax-get-property
(vlax-get-acad-object)
'ActiveDocument
)
)
)

(defun undoend ()
(vla-EndUndoMark
(vlax-get-property
(vlax-get-acad-object)
'ActiveDocument
)
)
)

;; returns the oppsite of an angle define in radians
(defun get-opp-ang (ang)
(cond ((< ang pi)(+ ang pi))
((> ang pi)(- ang pi))
((equal ang pi) 0.0)
((equal ang 0.0) pi)
)
)

;; ================= body of main function starts here ======================

;; ----------- Get the Text to Align -----------------
(cond
((setq txt_ent (car (entsel "\nSelect text to align")))
(setq txt_obj (vlax-ename->vla-object txt_ent)
obj_typ (vlax-get-property txt_obj 'ObjectName)
)
(cond
((or (= obj_typ "AcDbMText") (= obj_typ "AcDbText")))
(T
(setq txt_ent nil)
(alert "I only know how to align (M)TEXT, sorry! "))
)
)
)

;; ----------- Get the Object to Align To -----------------
(cond
((and txt_ent
(setq ent (entsel "\nSelect entity for alignment: ")))
(setq obj (vlax-ename->vla-object (car ent))
obj_typ (vlax-get-property obj 'ObjectName)
)
(cond
((= obj_typ "AcDbPolyline")
(if (setq pt_lst (getSegment obj (last ent)))
(setq ang (angle (cadr pt_lst)(caddr pt_lst)))
)
)
((= obj_typ "AcDbLine")
(setq ang (vlax-get-property obj 'Angle))
)
((= obj_typ "AcDbText")
(setq ang (vlax-get-property obj 'Rotation))
)
((= obj_typ "AcDbMText")
(setq ang (vlax-get-property obj 'Rotation))
)
((= obj_typ "AcDbArc")
(setq ang (angle
(vlax-safearray->list
(vlax-variant-value
(vla-get-StartPoint obj)))
(vlax-safearray->list
(vlax-variant-value
(vla-get-EndPoint obj)))
)
)
)

(T (alert "That's not an entity I deal with"))
)
)
)

;; ----------- Align the Text -----------------
(cond
((null ang)) ; do nothing
((null txt_ent)) ; do nothing
(T
(undobegin)
(vlax-put-property txt_obj 'Rotation ang)
(setq ans (getstring "\nRotate 180 [Y/N]<N>: "))
(if (= (strcase ans) "Y")
(vlax-put-property txt_obj 'Rotation (get-opp-ang ang))
)
(vlax-release-object txt_obj)
(undoend)
)
)
(princ)
) Logged

Routine for rotating text to a the current viewtwist angle.

; ROTOTXT.LSP
; Routine for rotating text to a the current viewtwist angle.
;
;

(defun c:ROV ( / ss2 i vta tmp)
(vl-load-com)
(prompt "\n Select TEXT and MTEXT to rotate ")
(setq ss2 (ssget '((0 . "*TEXT")))
i 0
vta (- 0 (getvar "viewtwist"))
)
(repeat (sslength ss2)
(setq tmp (vlax-ename->vla-object (ssname ss2 i)))
(if (eq (vla-get-ObjectName tmp) "AcDbText")
(progn
(vlax-put tmp "Rotation" vta)
(vlax-put tmp "Alignment" acAlignmentLeft)
)
(progn
(vlax-put tmp "Rotation" 0.0)
(vlax-put tmp "AttachmentPoint" acAttachmentPointTopLeft)
)
)
(setq i (1+ i))
)
)

match only rotation of text lisp

(defun mangerr (msg)
(if (null wasworld) (command "_.ucs" "_p"))
(if msg (princ msg))
(if olderr (setq *error* olderr))
(princ)
)

(defun c:mang (/ olderr wasworld ent elist orient sset ssqty index ssqty next nxlst nxrot nwlst)
(setq olderr *error* *error* mangerr)
(command "_.undo" "_g")
(if (= (getvar "worlducs") 1)(setq wasworld T))
(if (null wasworld) (command ".ucs" "w"))
(setq ent (entsel))
(setq elist (entget (car ent)))
(setq orient (assoc 50 elist))
(prompt "\nSelect objects to match rotation: ")
(setq sset (ssget))
(setq ssqty (sslength sset))
(setq index 0)
(repeat ssqty
(setq next (ssname sset index))
(setq nxlst (entget next))
(setq nxrot (assoc 50 nxlst))
(setq nwlst (subst orient nxrot nxlst))
(entmod nwlst)
(setq index (1+ index))
)
(if (null wasworld)(command "_.ucs" "_p"))
(setq *error* olderr)
(command "_.undo" "_end")
(princ)
)

Change the color of selected object- Lisp

(defun c:lcc ( / obj layer color)
(while (setq obj (nentsel "\nSelect entity on layer: "))
(setq layer (entget
(tblobjname "layer" (cdr (assoc 8 (entget (car obj)))))
)
color (acad_colordlg (cdr (assoc 62 layer)))
)
(if color
(entmod (subst (cons 62 color) (assoc 62 layer) layer))
)
)
(princ)
)

Change view to based on two points -Lisp

;;; This routine will dview twist a drawing by
;;; selecting points in the drawing.
;;; Also sets the snap angle for the new twist.

(defun C:DVT()
(prompt "Select Points From Left To Right.")
(setq point1 (getpoint "\nSelect First Reference Point:"))
(setq point2 (getpoint "\nSelect Second Reference Point:"))
(setq ang1 (angle point1 point2))(print ang1)
(setq new_dv (angtos (- (* 2.00 pi) ang1) 0))
(command "_dview" "" "tw" new_dv "")
;;; (setvar "snapang" (* -1.0 (getvar "viewtwist")))
(princ)
)

reverse the direction in which Lines

;|

PLREV.LSP (c) 1999-2004 Tee Square Graphics

Version 2.03a - 11/15/2004

Used to reverse the direction in which Lines, Polylines, LWPolylines
and other objects are drawn. Useful for correcting the "direction"
of specialized complex linetypes.
____

Revision History:

Version 2.03a: problem with non-American English installations fixed
(with thanks to Jürgen Palme); name changed from REV to PLREV to
resolve conflict with shortcut for REVolve command. 11/15/2004

Version 2.03: problem with ByLayer linetype fixed. 9/18/2001

Version 2.02: revised to preserve layer property of selected object.
8/17/2001

Version 2.01: error checking added; bug related to PLINEGEN system
variable fixed. 3/27/2001

Version 2.0 updated to include Arcs and Circles. These will be
converted to either Polylines or LWPolylines, depending on the
current setting of the PLINETYPE variable. Circles and Arcs over
180 may sometimes behave oddly; for best results, select these
items by clicking on a point near the "quad" points, at 0, 90,
180 or 270 degrees. If an Arc or Circle disappears during a REV
operation, just enter a U (undo) command to bring back the object
and try again by picking a different point on the object. 3/24/2001

Please report bugs and other difficulties, along with a detailed
description of the steps leading up to the problem, via email to
cadman@turvill.com.

|;

(defun C:PLREV (/ olderr cmde blip ltsc cclr snap pwid pgenen1 nam ent p obj ltp
clr lts wid flgs first final next spl cur vert a clos zoomit clyr lyr)
(setq olderr *error*)
(defun *error* (x)
(setvar "cmdecho" cmde)
(setvar "blipmode" blip)
(setvar "osmode" snap)
(setvar "celtscale" ltsc)
(setvar "cecolor" cclr)
(setvar "plinewid" pwid)
(setvar "plinegen" pgen)
(setq *error* olderr)
(princ)
) ;; end of *error* function
(setq cmde (getvar "cmdecho")
blip (getvar "blipmode")
ltsc (getvar "celtscale")
cclr (getvar "cecolor")
snap (getvar "osmode")
pwid (getvar "plinewid")
clyr (getvar "clayer")
pgen (getvar "plinegen"))
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(setvar "osmode" 0)
(setvar "plinewid" 0)
(setvar "plinegen" 1)
(command "_.undo" "_be")
(while (null (setq en1 (entsel "\nPick an object to reverse: "))))
(setq nam (car en1)
ent (entget nam)
p (cadr en1)
obj (cdr (assoc 0 ent)))
(cond
((= obj "CIRCLE")
(setq ctr (cdr (assoc 10 ent))
dia (* 2.0 (cdr (assoc 40 ent)))
a (angle p ctr))
(command "_.break" p (polar p (/ pi 4) 0.001)
"_.pedit" p "_y" "_c" "_x")
(carc))
((= obj "ARC")
(command "_.break" p "@"
"_.pedit" p "_y" "_j" nam (entlast) "" "_x")
(carc))
(T nil))
(setq ltp (cdr (assoc 6 ent))
lyr (cdr (assoc 8 ent))
clr (cdr (assoc 62 ent))
lts (cdr (assoc 48 ent))
wid (cdr (assoc 40 ent))
flgs (cdr (assoc 70 ent)))
(if (not ltp)(setq ltp "bylayer"))
(cond
((= obj "LINE")
(setq first (assoc 10 ent)
final (assoc 11 ent)
ent (subst (cons 10 (cdr final)) first ent)
ent (subst (cons 11 (cdr first)) final ent))
(entmod ent))
((= obj "LWPOLYLINE")
(setq final (cdr (assoc 10 (setq ent (reverse ent))))
next (cdr (assoc 10 (cdr (member (assoc 10 ent) ent)))))
(prev))
((= obj "POLYLINE")
(setq spl (= (logand flgs 4) 4)
cur (= (logand flgs 2) 2)
vert (entnext nam))
(if cur
(command "_.pedit" p "_s" ""))
(while (= (cdr (assoc 0 (entget (setq vert (entnext vert))))) "VERTEX")
(setq next final
final (cdr (assoc 10 (entget vert)))))
(prev))
(T (alert "Not a REVersible object.")))
(command "_.undo" "_e")
(setvar "cmdecho" cmde)
(setvar "blipmode" blip)
(setvar "osmode" snap)
(setvar "celtscale" ltsc)
(setvar "cecolor" cclr)
(setvar "plinewid" pwid)
(setvar "plinegen" pgen)
(setvar "clayer" clyr)
(setq *error* olderr)
(princ)
)
(defun carc ()
(setq ent (entget (entlast))
nam (cdr (assoc -1 ent))
obj (cdr (assoc 0 ent)))
)
(defun prev ()
(setq a (angle next final)
clos (= (logand flgs 1) 1))
(if clos (command "_.pedit" nam "_o" ""))
(setq zoomit (null (ssget "_c" final final)))
(if zoomit (command "_.zoom" "_c" final ""))
(if clr (command "_.color" clr))
(if lts (setvar "celtscale" lts))
(setvar "clayer" lyr)
(command "_.pline" (polar final a 0.0001) final ""
"_.chprop" (entlast) "" "_lt" ltp ""
"_.pedit" (entlast) "_j" nam "" ""
"_.break" final (polar final a 0.001))
(if cur (command "_.pedit" (entlast) "_f" ""))
(if spl (command "_.pedit" (entlast) "_s" ""))
(if clos (command "_.pedit" (entlast) "_c" ""))
(if wid (command "_.pedit" (entlast) "_w" wid ""))
(if zoomit (command "_.zoom" "_p"))
)
(alert (strcat "PLREV.LSP (c) 1999-2004 Tee Square Graphics\n\n"
" Type PLREV to begin."))
(princ)

NEW-LIN lisp

;|

NEW-LIN.LSP -- (c) 2000 Tee Square Graphics

NEW-LIN is a useful AutoLISP routine that extracts parameters for
unknown LineTypes in a drawing, and creates entries in a new LineType
definition file, NEW-ACAD.LIN. After extraction, the LineType definitions
may be moved to ACAD.LIN or any other *.LIN file desired by the user.

This version of NEW-LIN.LSP functions fully with simple LineTypes, and
Complex LineTypes composed of linear elements and Text objects. Because
of difficulty in extracting Shape data from shape definition (*.shx)
files, the user may, for the time being, have to supply the appropriate
name for the Shape represented by {Shape #nnn} in NEW-ACAD.LIN, in cases
where the associated Shape Source File (*.shp) is unavailable.

|;

(defun C:NEW-LIN (/ flag outf ltname tblent tblist i desc alist acode value
rot shpno shxfl shpfl inf dat n shpnm flg txt sty)
(setq flag (findfile "new-acad.lin")
outf (open (if flag flag "new-acad.lin") "w"))
(write-line ";;" outf)
(write-line ";; New LineType descriptions extracted" outf)
(write-line ";; from existing drawing(s) by NEW-LIN.LSP." outf)
(write-line ";;" outf)
(write-line ";; NEW-LIN.LSP (c) 2000 Tee Square Graphics" outf)
(write-line ";;\n" outf)
(setvar "luprec" 8)
(setvar "auprec" 8)
(tblnext "ltype" T)
(while (setq tblent (tblnext "ltype"))
(setq ltname (cdr (assoc 2 tblent))
tblent (tblobjname "ltype" ltname)
tblist (entget tblent)
i 1
desc "A,")
(write-line (strcat "*" (cdr (assoc 2 tblist)) "," (cdr (assoc 3 tblist))) outf)
(while (< i (length tblist))
(setq alist (nth i tblist)
acode (car alist)
value (cdr alist))
(cond
((= acode 49)
(setq desc (strcat desc (trim (rtos value 2 8)) ",")))
((= acode 74)
(setq flag (if (= (logand value 4) 4) T nil)
rot (if (= (logand value 1) 1) "a" "r")))
((= acode 75)
(setq shpno (itoa value)))
((= acode 340)
(if flag
(progn
(setq shxfl (cdr (assoc 3 (entget value)))
shpfl (strcat (substr shxfl 1 (- (strlen shxfl) 3)) "shp"))
(if (setq inf (findfile shpfl))
(progn
(setq inf (open inf "r"))
(while (setq dat (read-line inf))
(if (wcmatch dat (strcat "`*" shpno "*"))
(progn
(setq n 1)
(repeat 2
(while (/= (substr dat n 1) ",")
(setq n (1+ n)))
(setq n (1+ n)))
(setq shpnm (substr dat n)))))
(close inf)))))
(setq flg flag
txt (if flag
(if shpnm shpnm (strcat "{Shape #" shpno "}"))
(strcat "\"" (cdr (assoc 9 (member alist tblist))) "\""))
sty (if flag
(cdr (assoc 3 (entget value)))
(cdr (assoc 2 (entget value))))
desc (strcat desc "\n[" txt "," sty ",s="
(trim (rtos (cdr (nth (1+ i) tblist)) 2 8)) "," rot "="
(trim (angtos (cdr (nth (+ i 2) tblist)) 0 8)) ",x="
(trim (rtos (cdr (nth (+ i 3) tblist)) 2 8)) ",y="
(trim (rtos (cdr (nth (+ i 4) tblist)) 2 8)) "],\n")
i (+ i 4)))
(T nil))
(setq i (1+ i)))
(write-line (substr desc 1 (1- (strlen desc))) outf)
(write-line " " outf))
(close outf)
(alert (strcat "All loaded LineTypes in the current drawing database have been\n"
"duplicated in a new LineType definition file, NEW-ACAD.LIN.\n"
"Any complex LineTypes using Shape Definitions for which no\n"
"source file (*.shp) could be found will contain a reference in\n"
"curly braces { }; the user must supply the correct shape name\n"
"before NEW-ACAD.LIN can be used to load these LineTypes."))
(princ)
)
(defun trim (x / i)
(setq i (strlen x))
(while (= (substr x i) "0")
(setq i (1- i)
x (substr x 1 i)))
(if (= (substr x i) ".")
(substr x 1 (1- i))
x)
)

draws a box around selected text based on a user defined offset factor

;| TBOX.lsp draws a box around selected text based on a user defined offset factor.
Written and Tested in R2000.
Version 1.2 - by Tippit CADD Services
Version 1.3 - by pd
------------------------------------------------------------------------
------------------------------------------------------------------------
Created by J. Tippit, SPAUG President
E-mail: jefft@wilkersonproperties.com
Web Site: http://www.spaug.org

------------------------------------------------------------------------
------------------------------------------------------------------------

Revisions:
1.0 Originally created ?
1.1 Added scale factor prompt & entity verification 10/21/99
1.2 Added MTEXT support, osmode handling, error trapping 11/26/99
1.3 Added MTEXT angle-support, replacement scale with offset 12/29/00
|;

;----------------------------------------------------------------------
; Error Handler
;----------------------------------------------------------------------
(defun tboxerr (s)
(if (not (member s '("console break" "Function cancelled")))
(princ (strcat "\nError: " s "\nResetting Variables."))
)
(setvar "osmode" OSM)
(command "._undo" "e")
(setvar "cmdecho" 1)
(setq *error* tboxolderr)
(princ)
)
;----------------------------------------------------------------------
; Main Program
;----------------------------------------------------------------------
(defun C:TBOX ( / E1 TB LL UR UL LR EL PT APT WDT HGT PT1 PT2 PT3 PT4 PT5 PT6 PT7 PT8 PT9)
(setq tboxolderr *error* *error* tboxerr)
(setvar "cmdecho" 0)
(command "._undo" "be")
(setq OSM (getvar "osmode"))
(setvar "osmode" 0)
(setq TE nil)
(while (not TE)
(progn
(setq TE (car (entsel "\nSelect Text or MText: ")))
(if TE
(progn
(setq E1 (entget TE))
(if (= (cdr (assoc 0 E1)) "TEXT")
(progn
(if (or (= SF nil)(= SF ""))(setq SF "1.5"))
(setq SF "0.12")
(setq SF2 SF)
(if (or (= SF nil)(= SF ""))(setq SF SF2))
(command "ucs" "Entity" TE)
(setq TB (textbox (list (cons -1 TE)))
LL (car TB)
UR (cadr TB)
UL (list (car LL) (cadr UR))
LR (list (car UR) (cadr LL))
)
(command "._pline" LL LR UR UL "c")
(setq EL (entlast))
(setq PT (list (+ (car UL) 1000) (+ (cadr UL) 1000)))
(command "._offset" SF EL PT "")
(entdel EL)
(command "ucs" "w")
)
(progn
(if (= (cdr (assoc 0 E1)) "MTEXT")
(progn
(if (or (= SF nil)(= SF ""))(setq SF "1.5"))
(setq SF "0.12")
(setq SF2 SF)
(if (or (= SF nil)(= SF ""))(setq SF SF2))
(setq APT (cdr (assoc 71 E1))) ; attachment point
(setq WDT (cdr (assoc 42 E1))) ; width
(setq HGT (cdr (assoc 43 E1))) ; height
(setq PT7 (cdr (assoc 10 E1))) ; insertion point
(setq PT9 (list (+ (car PT7) WDT) (cadr PT7) (caddr PT7)))
(setq PT3 (list (car PT9) (+ (cadr PT9) HGT) (caddr PT9)))
(setq PT1 (list (car PT7) (+ (cadr PT7) HGT) (caddr PT7)))

(command "._pline" PT7 PT9 PT3 PT1 "c")
(setq EL (entlast))

(command "._move" EL "" PT1 PT7)
(command "._rotate" "last" "" (list (car pt7)(cadr pt7))(/(*(cdr (assoc 50 E1))180)pi))
(command "._offset" SF EL PT7 "")
(entdel EL)
)
(progn
(setq TE nil)
(prompt "\nSelected object is not TEXT or MTEXT. Try again. ")
)
)
)
)
)
(prompt "\nMissed. Try again.")
)
)
)

(command "._erase" EL "")
(if (= (cdr (assoc 0 E1)) "TEXT")(command "ucs" "w"))
(redraw)
(setvar "osmode" OSM)
(command "_undo" "e")
(setvar "cmdecho" 1)
(setq *error* tboxolderr)
(princ)
)
(prompt (strcat "\nCopyright \251 TCS 1999 Version 1.3 - Text Box Routine loaded."))
(prompt "\nType TBOX to execute.")
(princ)

Lisp link

http://www.turvill.com/t2/free_stuff/index.htm

Scale drawing

(defun C:123 (/ eset
MULTILEADER_ERM_L80n MULTILEADER_ERM_L90n
MULTILEADER_ERM_L140A
) ;define a program name
(vl-load-com)
(or drawing_scale (setq drawing_scale "60")) ; set global variables

(if
(/= ""
(setq
strdia (getstring
(strcat "\nEnter Drawing Scale <" drawing_scale "> ")
)
)
)
(setq drawing_scale strdia)
)
(princ "\nEnter Drawing Scale is ")
(princ drawing_scale)
(princ)

(if (setq eset (ssget)) ;use the ssget function to select entities

(progn ;use progn since there will be more than 1 statement

(setq cntr 0) ;set the cntr to the first item in the set
(setq MTexT_Set (ssadd))
(setq MULTILEADER_Set (ssadd))
(setq INSERT_Set (ssadd))
(setq TEXT_Set (ssadd))
(setq MULTILEADER_ERM_L80n (ssadd))
(setq MULTILEADER_ERM_L90n (ssadd))
(setq MULTILEADER_ERM_L110 (ssadd))
(setq MULTILEADER_ERM_L140A (ssadd))

(setq MTexT_ERM_L80n (ssadd))
(setq MTexT_ERM_L90n (ssadd))
(setq MTexT_ERM_L100 (ssadd))
(setq MTexT_ERM_L110 (ssadd))
(setq MTexT_ERM_L120n (ssadd))
(setq MTexT_ERM_L140A (ssadd))
(setq MTexT_ERM_L160A (ssadd))

(setq Station_Entrance_Block (ssadd))
(setq Pedistrain_Bridge_Entrance_Block (ssadd))
(setq ETSphone_number (ssadd))
(setq all_blocks (ssadd))

(setq Fire_Zone_pline_Block (ssadd))

(while (< cntr (sslength eset)) ;while cntr is less than the length of the set

;;; Note: the length is one more than the index of items since the first item is zero. In other words, to
;;; get to the first item in a selection set consisting of one item you would use (ssname eset 0) not
;;; (ssname eset 1).

(setq en (ssname eset cntr)) ;get the entity name of the item indexed with cntr

(setq enlist (entget en)) ;get the dxf group codes of the enitity

(setq entity_name (cdr (assoc 0 enlist))) ;get the layer name

;;; (princ "\n ") ;print "\n " will cause a new line to be printed

;;; (princ entity_name) ;print the layer name to the command line
(cond
((= entity_name "MTEXT")
(progn
(setq
style (cdr (assoc 7 (entget en)))
)
(cond
((or (= "ERM L80n" style) (= "ERM L80" style))

(setq MTexT_ERM_L80n
(ssadd en MTexT_ERM_L80n)
)
)
((= "ERM L90n" style)
(setq MTexT_ERM_L90n
(ssadd en MTexT_ERM_L90n)
)
)
((or (= "ERM L100" style) (= "ERM L100n" style))
(setq MTexT_ERM_L100
(ssadd en MTexT_ERM_L100)
)
)
((= "ERM L110" style)
(setq MTexT_ERM_L110
(ssadd en MTexT_ERM_L110)
)
)
((= "ERM L120n" style)
(setq MTexT_ERM_L120n
(ssadd en MTexT_ERM_L120n)
)
)
((= "ERM L140A" style)
(setq MTexT_L140A
(ssadd en MTexT_L140A)
)
)
((= "ERM L160 A" style)
(setq MTexT_ERM_L160A
(ssadd en MTexT_ERM_L160A)
)
)
)

)

)
;;; ((= entity_name "LWPOLYLINE") (ssadd entity_name MTexT_Set))
((= entity_name "MULTILEADER")
(progn
(setq
style (cdr (assoc 2 (entget (cdr (assoc 340 enlist)))))
)
(cond
((= "ERM L80n" style)
(setq MULTILEADER_ERM_L80n
(ssadd en MULTILEADER_ERM_L80n)
)
)
((= "ERM L90n" style)
(setq MULTILEADER_ERM_L90n
(ssadd en MULTILEADER_ERM_L90n)
)
)

((= "ERM L110" style)
(setq MULTILEADER_ERM_L110
(ssadd en MULTILEADER_ERM_L110)
)
)
((= "ERM L140A" style)
(setq MULTILEADER_ERM_L140A
(ssadd en MULTILEADER_ERM_L140A)
)
)
((= "ERM L160A" style)
(setq MTexT_ERM_L160A
(ssadd en MTexT_ERM_L160A)
)
)
)

)
)
;;; -------------------------------------------------------------
((= entity_name "INSERT")
(progn
(setq
style (cdr (assoc 2 (entget en)))
)
(cond
((= "Arrow-Sta-Ent" style)

(setq Station_Entrance_Block
(ssadd en Station_Entrance_Block)
)
)
((= "Arrow-Adj-Sta" style)
(setq Pedistrain_Bridge_Entrance_Block
(ssadd en Pedistrain_Bridge_Entrance_Block)
)
)
((or (= "ETSphone#" style)
(= "windscreen1" style)
(= "Elev-Sta" style)
)
(setq ETSphone_number
(ssadd en ETSphone_number)
)
)
((= entity_name "INSERT")
(setq all_blocks
(ssadd en all_blocks)
)
)

)

)

;;; --------------------------------------------
)
((= entity_name "TEXT") (ssadd en TEXT_Set))

((= entity_name "LWPOLYLINE")
(progn
(setq
layer_name
(cdr (assoc 8 (entget en)))
)
(cond
((= "VJ-FIRE-ZONE" layer_name)

(setq Fire_Zone_pline_Block
(ssadd en Fire_Zone_pline_Block)
)
)

)

)

)
)
(setq cntr (+ cntr 1)) ;increment the counter

) ;close the while statement

) ;close the progn on the if statement

(princ "\n Error - No entities selected.")
;print a message on the else statement

; note: the if statement can be a " if then " statement or a " if then else" statement

) ;close the if statement
(setq a (sslength MULTILEADER_ERM_L80n))
(princ (strcat (rtos (sslength MULTILEADER_ERM_L80n) 2 0)
" MULTILEADER_ERM_L80n entities selected.\n"
)
)
(princ (strcat (rtos (sslength MULTILEADER_ERM_L90n) 2 0)
" MULTILEADER_ERM_L90n entities selected.\n"
)
)
(princ (strcat (rtos (sslength MULTILEADER_ERM_L110) 2 0)
" MULTILEADER_ERM_L110 entities selected.\n"
)
)
(princ (strcat (rtos (sslength MULTILEADER_ERM_L140A) 2 0)
" MULTILEADER_ERM_L140A entities selected.\n"
)
)

;;;Mtext out put

(princ (strcat (rtos (sslength MTexT_ERM_L80n) 2 0)
" MTexT_ERM_L80n entities selected.\n"
)
)
(princ (strcat (rtos (sslength MTexT_ERM_L90n) 2 0)
" MTexT_ERM_L90n entities selected.\n"
)
)
(princ (strcat (rtos (sslength MTexT_ERM_L100) 2 0)
" MTexT_ERM_L100 entities selected.\n"
)
)
(princ (strcat (rtos (sslength MTexT_ERM_L110) 2 0)
" MTexT_ERM_L110 entities selected.\n"
)
)
(princ (strcat (rtos (sslength MTexT_ERM_L120n) 2 0)
" MTexT_ERM_L120n entities selected.\n"
)
)
(princ (strcat (rtos (sslength MTexT_ERM_L140A) 2 0)
" MTexT_ERM_L140A entities selected.\n"
)
)

(princ (strcat (rtos (sslength MTexT_ERM_L160A) 2 0)
" MTexT_ERM_L160A entities selected.\n"
)
)

(princ
(strcat (rtos (sslength Pedistrain_Bridge_Entrance_Block) 2 0)
" Pedistrain_Bridge_Entrance_Block entities selected.\n"
)
)

(princ
(strcat (rtos (sslength Station_Entrance_Block) 2 0)
" Station_Entrance_Block entities selected.\n"
)
)
(princ
(strcat (rtos (sslength ETSphone_number) 2 0)
" ETSphone_number entities selected.\n"
)
)
(princ
(strcat (rtos (sslength all_blocks) 2 0)
" Other blocks entities selected.\n"
)
)

(princ
(strcat (rtos (sslength Fire_Zone_pline_Block) 2 0)
" Fire_Zone_pline_ entities selected.\n"
)
)
(cond
((< 0 (sslength MULTILEADER_ERM_L80n))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr
(assoc
2
(entget
(cdr (assoc
340
(entget
(ssname
MULTILEADER_ERM_L80n
0
)
)
)
)
)
)
)
6
2
)
)
1000
)
)
2
2
)
)
(mapcar
(function
(lambda (x)
(vla-put-TextHeight x (atof calculated_text))
)
)
(mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex MULTILEADER_ERM_L80n))
)
)
)
)
)

;;;------------------------------------------------------------------------------------------------------------------------
(cond
((< 0 (sslength MULTILEADER_ERM_L90n))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr
(assoc
2
(entget
(cdr (assoc
340
(entget
(ssname
MULTILEADER_ERM_L90n
0
)
)
)
)
)
)
)
6
2
)
)
1000
)
)
2
2
)
)
(mapcar
(function
(lambda (x)
(vla-put-TextHeight x (atof calculated_text))
)
)
(mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex MULTILEADER_ERM_L90n))
)
)
)
)
)

;;;------------------------------------------------------------------------------------------------------------------------
(cond
((< 0 (sslength MULTILEADER_ERM_L110))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr
(assoc
2
(entget
(cdr (assoc
340
(entget
(ssname
MULTILEADER_ERM_L110
0
)
)
)
)
)
)
)
6
3
)
)
1000
)
)
2
2
)
)
(mapcar
(function
(lambda (x)
(vla-put-TextHeight x (atof calculated_text))
)
)
(mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex MULTILEADER_ERM_L110))
)
)
)
)
)

;;;------------------------------------------------------------------------------------------------------------------------
(cond
((< 0 (sslength MULTILEADER_ERM_L140A))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr
(assoc
2
(entget
(cdr (assoc
340
(entget
(ssname
MULTILEADER_ERM_L140A
0
)
)
)
)
)
)
)
6
3
)
)
1000
)
)
2
2
)
)
(mapcar
(function
(lambda (x)
(vla-put-TextHeight x (atof calculated_text))
)
)
(mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex MULTILEADER_ERM_L140A))
)
)
)
)
)

;;; ---Mtext height---
;;;------------------------------------------------------------------------------------------------------------------------
(cond
((< 0 (sslength MTexT_ERM_L80n))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr (assoc
7
(entget
(ssname
MTexT_ERM_L80n
0
)
)
)
)
6
2
)
)
1000
)
)
2
2
)
)
(setq i 0
n (sslength MTexT_ERM_L80n)
)
(while (< i n)
(setq e (ssname MTexT_ERM_L80n i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq SZ (cons 40 (atof calculated_text)))
(setq ed (entget (ssname
MTexT_ERM_L80n
i
)
)
)
(setq ed (subst SZ (assoc 40 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)

(cond
((< 0 (sslength MTexT_ERM_L90n))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr (assoc
7
(entget
(ssname
MTexT_ERM_L90n
0
)
)
)
)
6
2
)
)
1000
)
)
2
2
)
)
(setq i 0
n (sslength MTexT_ERM_L90n)
)
(while (< i n)
(setq e (ssname MTexT_ERM_L90n i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq SZ (cons 40 (atof calculated_text)))
(setq ed (entget (ssname
MTexT_ERM_L90n
i
)
)
)
(setq ed (subst SZ (assoc 40 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)

(cond
((< 0 (sslength MTexT_ERM_L100))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr (assoc
7
(entget
(ssname
MTexT_ERM_L100
0
)
)
)
)
6
3
)
)
1000
)
)
2
2
)
)
(setq i 0
n (sslength MTexT_ERM_L100)
)
(while (< i n)
(setq e (ssname MTexT_ERM_L100 i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq SZ (cons 40 (atof calculated_text)))
(setq ed (entget (ssname
MTexT_ERM_L100
i
)
)
)
(setq ed (subst SZ (assoc 40 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)

(cond
((< 0 (sslength MTexT_ERM_L110))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr (assoc
7
(entget
(ssname
MTexT_ERM_L110
0
)
)
)
)
6
3
)
)
1000
)
)
2
2
)
)
(setq i 0
n (sslength MTexT_ERM_L110)
)
(while (< i n)
(setq e (ssname MTexT_ERM_L110 i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq SZ (cons 40 (atof calculated_text)))
(setq ed (entget (ssname
MTexT_ERM_L110
i
)
)
)
(setq ed (subst SZ (assoc 40 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)

(cond
((< 0 (sslength MTexT_ERM_L120n))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr (assoc
7
(entget
(ssname
MTexT_ERM_L120n
0
)
)
)
)
6
3
)
)
1000
)
)
2
2
)
)
(setq i 0
n (sslength MTexT_ERM_L120n)
)
(while (< i n)
(setq e (ssname MTexT_ERM_L120n i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq SZ (cons 40 (atof calculated_text)))
(setq ed (entget (ssname
MTexT_ERM_L120n
i
)
)
)
(setq ed (subst SZ (assoc 40 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)
(cond
((< 0 (sslength MTexT_ERM_L140A))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr (assoc
7
(entget
(ssname
MTexT_ERM_L140A
0
)
)
)
)
6
3
)
)
1000
)
)
2
2
)
)
(setq i 0
n (sslength MTexT_ERM_L140A)
)
(while (< i n)
(setq e (ssname MTexT_ERM_L140A i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq SZ (cons 40 (atof calculated_text)))
(setq ed (entget (ssname
MTexT_ERM_L140A
i
)
)
)
(setq ed (subst SZ (assoc 40 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)

(cond
((< 0 (sslength MTexT_ERM_L160A))
(progn
(setq calculated_text
(rtos
(*
(atof drawing_scale)
(/ (atof
(substr
(cdr (assoc
7
(entget
(ssname
MTexT_ERM_L160A
0
)
)
)
)
6
3
)
)
1000
)
)
2
2
)
)
(setq i 0
n (sslength MTexT_ERM_L160A)
)
(while (< i n)
(setq e (ssname MTexT_ERM_L160A i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq SZ (cons 40 (atof calculated_text)))
(setq ed (entget (ssname
MTexT_ERM_L160A
i
)
)
)
(setq ed (subst SZ (assoc 40 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)

(cond
((< 0 (sslength Station_Entrance_Block))
(progn
(setq calculated_block_scale
(rtos
(*
94.5
(/ (atof drawing_scale)
60
)
)
2
2
)
)
(setq i 0
n (sslength Station_Entrance_Block)
)
(while (< i n)
(setq e (ssname Station_Entrance_Block i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq x_scale (cons 41 (atof calculated_block_scale)))
(setq y_scale (cons 42 (atof calculated_block_scale)))
(setq z_scale (cons 43 1))
(setq ed (entget (ssname
Station_Entrance_Block
i
)
)
)
(setq ed (subst x_scale (assoc 41 ed) ed))
(setq ed (subst y_scale (assoc 42 ed) ed))
(setq ed (subst z_scale (assoc 43 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)
;;;This will affect the arrow showing station so i will return it back to normal;
;;; for pedistrian it should be 60
(cond
((< 0 (sslength Pedistrain_Bridge_Entrance_Block))
(progn
(setq calculated_block_scale
(rtos
(*
60
(/ (atof drawing_scale)
60
)
)
2
2
)
)
(setq i 0
n (sslength Pedistrain_Bridge_Entrance_Block)
)
(while (< i n)
(setq e (ssname Pedistrain_Bridge_Entrance_Block i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq x_scale (cons 41 (atof calculated_block_scale)))
(setq y_scale (cons 42 (atof calculated_block_scale)))
(setq z_scale (cons 43 (atof calculated_block_scale)))
(setq ed (entget (ssname
Pedistrain_Bridge_Entrance_Block
i
)
)
)
(setq ed (subst x_scale (assoc 41 ed) ed))
(setq ed (subst y_scale (assoc 42 ed) ed))
(setq ed (subst z_scale 1 ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)

(cond
((< 0 (sslength all_blocks))
(progn

(setq calculated_block_scale
drawing_scale
)
(setq i 0
n (sslength all_blocks)
)
(while (< i n)
(setq e (ssname all_blocks i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq x_scale (cons 41 (atof calculated_block_scale)))
(setq y_scale (cons 42 (atof calculated_block_scale)))
(setq z_scale (cons 43 1))
(setq ed (entget (ssname
all_blocks
i
)
)
)
(setq ed (subst x_scale (assoc 41 ed) ed))
(setq ed (subst y_scale (assoc 42 ed) ed))
(setq ed (subst z_scale (assoc 43 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)
(cond
((< 0 (sslength ETSphone_number))
(princ
"\nPlease manualy adjust phone number or Windscreen scales "
)
)
)

(cond
((< 0 (sslength Fire_Zone_pline_Block))
(progn
(setq calculated_width
(rtos
(*
0.03
(atof drawing_scale)
)
2
2
)
)

(setq i 0
n (sslength Fire_Zone_pline_Block)
)
(while (< i n)
(setq e (ssname Fire_Zone_pline_Block i)
x (cdr (assoc 0 (entget e)))

)

(progn
(setq x_scale (cons 43 (atof calculated_width)))
;;; (setq y_scale (cons 42 (atof calculated_width)))
;;; (setq z_scale (cons 43 1))
(setq ed (entget (ssname
Fire_Zone_pline_Block
i
)
)
)
(setq ed (subst x_scale (assoc 43 ed) ed))
;;; (setq ed (subst y_scale (assoc 42 ed) ed))
;;; (setq ed (subst z_scale (assoc 43 ed) ed))
(entmod ed)
(princ)
)

(setq i (1+ i))

)
)
)
)
) ;close the program