PDA

View Full Version : Lisp Modification ~ Plot Stamp



PIERCE
31st Aug 2006, 06:24 pm
Hello all, wondering if any VBA pro's would like to help me out.

I have two plot stamp lisp that I have been tweaking a bit to match
a standard Title Block for the company I am at now. Problem is my
knowledge of VBA is slight.

Here are the two lisp, and what is needed to make either work.

;================================================= ========================
(defun listxref ( / data work first rxn nxn xnm)
;Fm: Richard Halle [AVE TM] 73417,340
(initget "A V S")
(setq first t)
(setq nst_lst nil)
(while (setq data (tblnext "block" first)) ;rewind 1st time thru
(setq first nil) ;don't want to rewind anymore
(cond ( (= 68 (logand 68 (cdr (assoc 70 data)))) ;XREFed >AND< ref'd Block?
(setq
xrnm (cdr (assoc '2 data))
work (cons xrnm work)
)
);If "Yup", add name to list
)
)
work ;returns the list
)
;================================================= ==========================
(defun C:STMP
(/
td time j y d m ys ms ds hh hs mm mss ss sss ip ips scaf sca rot rotn
dwg data myxref xlist first ssa tdata tname ddata dname gdata gname
xdata xname sn n vw_ctr vw_tst vd vw xr_nm ck_xr ck_nx intl
)
;_________________________________________________ ________________________
;
; Donald Pirl CIS: 71174,1113 ;Internet: dpirl@crl.com
; with due credit to:
; Richard Henley 73260,2346 Scanlon and Associates, Albuquerque NM
; Jason Osgood 73417,1756 Alacrity BBS (206) 746-0680, Bellevue WA
; Lisp Routine to Place Current Time, Date, Drawing Name and operator's
; initials at selected location(s) and rotation (entered or picked).
; STMP.DWG accompanying this file must be in the ACAD path.
; Suggestions: insert STMP.DWG in your prototype drawing,
; include the command C:STMP in menu or keyboard save macros.
; To include operator's initials rather than login name, put the line
; set intl=XXX
; (where XXX is the operator's initials)
; in the autoexec.bat or acad.bat file
; Text will be L60 (.06") when plotting scale = stamp block insertion
; scale, but the routine can be easily modified to suit.
;
; Updated March 1995 to not include the line "Xrefs: none" if
; there are none and to include an additional line with the
; current view (if named), and the scale. Therefore STMP.DWG
; must contain 5 attributes rather than 4, but the routine will
; automatically replace the old STMP block. Just make sure that
; you either overwrite the old one on your hard drive, or the new
; one comes before the old one in your ACAD path.
;_________________________________________________ _________________________
;
(setq
td (getvar "date")
time (* 86400.0 (- td (setq j (fix td))))
j (- j 1721119.0)
y (fix (/ (1- (* 4 j)) 146097.0))
j (- (* j 4.0) 1.0 (* 146097.0 y))
d (fix (/ j 4.0))
j (fix (/ (+ (* 4.0 d) 3.0) 1461.0))
d (- (+ (* 4.0 d) 3.0) (* 1461.0 j))
d (fix (/ (+ d 4.0) 4.0))
m (fix (/ (- (* 5.0 d) 3) 153.0))
d (- (* 5.0 d) 3.0 (* 153.0 m))
d (fix (/ (+ d 5.0) 5.0))
y (+ (* 100.0 y) j)
)
(if (< m 10.0)
(setq m (+ m 3))
(progn
(setq
m (- m 9)
y (1+ y)
)
)
)
(setq
ys (rtos y 2 0)
ms (itoa m)
ds (itoa d)
hh (fix (/ time 3600.0))
hs (itoa hh)
time (- time (* hh 3600.0))
mm (fix (/ time 60.0))
mss (itoa mm)
ss (- time (* mm 60.0))
sss (rtos ss 2 0)
dt (strcat "Date: " ms "/" ds "/" ys)
dt2 (strcat "Time: " hs ":" mss ":" sss)
vw_ctr (cdr (assoc '10 (setq vd (tblnext "view" T))))
vw_tst (if vw_ctr (distance (getvar "viewctr") vw_ctr))
)
(while (and vd (/= 0 vw_tst))
(setq vd (tblnext "view"))
(if vd
(setq
vw_ctr (cdr (assoc '10 vd))
vw_tst (distance (getvar "viewctr") vw_ctr)
)
)
)
(setq
vw (if vd (strcat "View: " (strcase (cdr (assoc '2 vd))) " ") "")
vw (strcat vw
"Scale: 1=" (rtos (getvar "DIMscale") 2 0)
(if (= (getvar "tilemode") 0) "(PS)" "")
)
intl (getenv "INTL")
intl (if intl intl (getvar "LOGINNAME"))
dwg (strcat
"Drawing File: " (strcat
(if (wcmatch (getvar "dwgname") "*:*")
(substr (getvar "dwgname") 4)
(strcat (substr (getvar "dwgprefix") 4) (getvar "dwgname"))
)
" (" intl ")"))
myxref (listxref)
xlist (if myxref (strcat "Xrefs: ") "")
)
(mapcar
'(lambda (l)
(setq xlist (strcat xlist l ", "))
)
myxref
)
(if myxref (setq xlist (substr xlist '1 (- (strlen xlist) 2))))
(princ "\nSearching for existing stamp blocks...")
(setq ssa (ssget "X" '((0 . "INSERT") (2 . "STMP"))))
(cond
( ssa
(cond
( (/= 5 (bac "STMP"))
(rsd)(C:STMP)
)
)
(setq
n (sslength ssa)
sn (itoa n)
)
(while (> n 0)
(setq n (- n 1)
tname (entnext (ssname ssa n))
tdata (entget tname)
dname (entnext tname)
ddata (entget dname)
vname (entnext dname)
vdata (entget vname)
gname (entnext vname)
gdata (entget gname)
xname (entnext gname)
xdata (entget xname)
tdata (subst (cons '1 dt2) (assoc '1 tdata) tdata)
ddata (subst (cons '1 dt) (assoc '1 ddata) ddata)
vdata (subst (cons '1 vw) (assoc '1 vdata) vdata)
gdata (subst (cons '1 dwg) (assoc '1 gdata) gdata)
xdata (if (/= "N" ck_xr)
(subst (cons '1 xlist) (assoc '1 xdata) xdata))
)
(entmod tdata)
(entmod ddata)
(entmod vdata)
(entmod gdata)
(if (/= "S" ck_xr) (entmod xdata))
(entupd gname)
)
(princ (strcat "\n" sn " Stamp block(s) \"STMP\" updated."))
)
( (not ssa)
(princ "\nSTMP block not found - Now inserting.")
(setq c_lay (getvar "clayer"))
(command ".layer" "m" "title" "")
(setq ips (getpoint "\nInsertion point: <0.0,0.0,0.0> "))
(if (null ips) (setq ip (list 0.0 0.0 0.0)) (setq ip ips))
(setq scaf (getvar "DIMscale"))
(if (null scaf) (setq sca "1.0") (setq sca scaf))
(setq rotn (getangle ip "\nEnter Text Rotation: <0.0> "))
(if (null rotn) (setq rot "0.0") (setq rot (angtos rotn 0 6)))
(command ".INSERT" "STMP"
ip sca sca rot dt2 dt vw dwg xlist)
(command ".layer" "s" c_lay "")
)
)
(princ)
);defun C:STMP
;;================================================ =====================
(defun c:sv ()
(C:STMP)
(princ (strcat "\nSaving " (getvar "dwgname") "...\n"))
(command "._save" "")
(princ (strcat "\nDrawing "(getvar "dwgname")" has been saved.\n"))
(princ)
)
(defun BAC ; Block Attribute Count
(bn / bn bet ben nen bed cnt)
(setq
nen (cdr (assoc '-2 (tblsearch "block" bn)))
cnt 0
)
(while nen
(setq
bed (entget nen)
bet (cdr (assoc '0 bed))
cnt (if (= bet "ATTDEF") (1+ cnt) cnt)
nen (entnext nen)
)
)
cnt
)
(defun RSD ;Replace Stmp Drawing
(/ sr nss ec en ed ip xs ys ra ps tiled)
(setvar "attreq" 0)
(princ "\nConverting STMP block(s)...")
(setq
ec 0
nss ssa
ssa (ssadd)
en (ssname nss ec)
sr 0
)
(while en
(setq
ed (entget en)
ip (cdr (assoc '10 ed))
xs (cdr (assoc '41 ed))
ys (cdr (assoc '42 ed))
ra ( / (* 180 (cdr (assoc '50 ed))) pi)
ps (assoc '67 ed)
)
(if (= (getvar "tilemode") 1) (setq tiled T))
(if (not tiled) (command "._pspace"))
(cond
( (or (and ps (not tiled)) (and (not ps) tiled))
(entdel en)
(command "._insert" "stmp=c:\\acad\\support\\stmp" ip xs ys ra)
(setq
sr (1+ sr)
ssa (ssadd (entlast) ssa)
)
)
)
(setq
ec (1+ ec)
en (ssname nss ec)
)
)
(setvar "attreq" 1)
(princ (strcat (itoa sr) " converted."))
(princ)
)
(princ"\nSTMP1 loaded. STMP to run.")(princ)
; End Of File

*The problem with this one is being able to take out the get VAR of the username as I do not wish for it to be displayed in the file location line.




Here is the Second:

;PSTAMP.LSP Plot Stamp (c)2000, David Trotz, Jr.

(defun DXF (CODE ENAME)
(cdr (assoc CODE (entget ENAME)))
) ;_ end of defun
(defun CHG_PATH ()
(setq ENAME (ssname BLK 0))
(while (/= (DXF 0 ENAME) "SEQEND")
(setq ETYPE (DXF 0 ENAME))
(if (and (= ETYPE "ATTRIB")
(= (DXF 2 ENAME) "PATH")
) ;_ end of and
(setq EN ENAME)
) ;_ end of if
(setq ENAME (entnext ENAME))
) ;_ end of while
(SWITCH EN P_PATH 1)
) ;_ end of defun

(defun CHG_DWG-NAME ()
(setq ENAME (ssname BLK 0))
(while (/= (DXF 0 ENAME) "SEQEND")
(setq ETYPE (DXF 0 ENAME))
(if (and (= ETYPE "ATTRIB")
(= (DXF 2 ENAME) "FILENAME")
) ;_ end of and
(setq EN ENAME)
) ;_ end of if
(setq ENAME (entnext ENAME))
) ;_ end of while
(SWITCH EN P_DWGNAME 1)
) ;_ end of defun

(defun CHG_DATE ()
(setq ENAME (ssname BLK 0))
(while (/= (DXF 0 ENAME) "SEQEND")
(setq ETYPE (DXF 0 ENAME))
(if (and (= ETYPE "ATTRIB")
(= (DXF 2 ENAME) "DATE")
) ;_ end of and
(setq EN ENAME)
) ;_ end of if
(setq ENAME (entnext ENAME))
) ;_ end of while
(SWITCH EN P_DATE 1)
) ;_ end of defun
(defun CHG_TIME ()
(setq ENAME (ssname BLK 0))
(while (/= (DXF 0 ENAME) "SEQEND")
(setq ETYPE (DXF 0 ENAME))
(if (and (= ETYPE "ATTRIB")
(= (DXF 2 ENAME) "TIME")
) ;_ end of and
(setq EN ENAME)
) ;_ end of if
(setq ENAME (entnext ENAME))
) ;_ end of while
(SWITCH EN P_TIME 1)
) ;_ end of defun

(defun SWITCH (EN VAL CODE)
(setq ELIST (entget EN)
NEWITEM (cons CODE VAL)
OLDITEM (assoc CODE ELIST)
NEWLIST (subst NEWITEM OLDITEM ELIST)
) ;_ end of setq
(entmod NEWLIST)
(entupd EN)
) ;_ end of defun
(defun C:PSTAMP (/)
(setq
D (rtos (getvar "CDATE") 2 6)
YR (substr D 3 2)
MO (substr D 5 2)
DAY (substr D 7 2)
) ;_ end of setq
(setq P_DATE (strcat MO "/" DAY "/" YR))
(setq
D (rtos (getvar "CDATE") 2 6)
HR (substr D 10 2)
M (substr D 12 2)
S (substr D 14 2)
) ;_ end of setq
(setq P_TIME (strcat HR ":" M ":" S))
(setq P_PATH ((getvar "DWGPREFIX") getvar "DWGNAME"))
(setq P_DWGNAME (getvar "DWGNAME"))
(if
(setq BLK (ssget "x" '((0 . "INSERT") (2 . "P_STAMP"))))
(progn (CHG_PATH)
(CHG_TIME)
(CHG_DATE)
(CHG_DWG-NAME)
(prompt "\nUpdated the plot stamp sucessfully!")
) ;_ end of progn
(prompt "\nCouldn't find P_stamp block... You must first insert P_stamp.dwg in

current drawing, at the location of your choice.")
) ;_ end of if
(princ)
) ;_ end of defun
(princ "\nPlot Stamp Loaded Type Pstamp to run.")
(princ)

*I love the simplicity of this one, but yet I would need it to beable to show
the Path and the DwgName in the same line as the plot stamp lisp above does.



Any help would be greatly appreciated.

rkmcswain
31st Aug 2006, 06:45 pm
What AutoCAD version are you running?

PIERCE
31st Aug 2006, 09:32 pm
Using AutoCAD 05 and SurvCADD 06 add on.

The SurvCADD relies on the AutoCAD engine.

rkmcswain
31st Aug 2006, 10:18 pm
Using AutoCAD 05 and SurvCADD 06 add on.

The SurvCADD relies on the AutoCAD engine.

The reason I asked is with 2005 and up, you can use a FIELD to create just about any plot stamp that you want.

We dumped our "plot stamp lisp code" a long time ago and started using RTEXT, then moved to FIELDS in 2005. No code to maintain and it's built into AutoCAD.

PIERCE
1st Sep 2006, 06:34 pm
Well don't I feel left in the dark......

Thanks alot this should streamline my efforts and finally get this one problem taken care of.