AfraLisp Blog

The AutoLisp/Visual Lisp/VBA Resource Website

AfraLisp Blog

Home Newsletter Utter Rubbish Coding Tips AutoCAD Tips Contact Downloads WAUN

Further to earv's question last week about XREF stamping of drawings, I offer the following code that I have been using.
This code has been cut down from a program I wrote in 1998 which stamped
the drawing with the user name, time and date, file name and AutoCAD
version.
Being a cut down program, the code is a bit clumsy and probably contains
elements that are not really required - But it works for me!
The program is manual in that you have to remember to type in 'stampx' to
stamp the drawing with all the XREFs. All you have to do next is point to
the top left hand corner of the drawing frame. (The program looks for the
end of the line.)
Users may like to customise the xloc and ftl to suit their own drawing
frame. Also the font iso3098b could be changed to the user preferred font.
Users should note the warning on the bottom of the program. Because the
drawing places text on the stamps layer, this layer is erased when the
program is run - Actually, only text with the style 'stamps' on the
'stamps' layer is erased, so the program is reasonably safe.
I am sure there are better ways of doing this (eg with attributes etc), but
I have been using this method for years with no problems.
BY THE WAY - I would be interested in knowing if there is a similar way of
stamping a drawing with IMAGE files attached to the drawing! I can't see
how to do it.

Regards

Craig Green

;CODING START HERE
; stampx.lsp - Stamps drawing with xrefs list.
; C Green 10/12/2001
;
; LAYER USAGE:
; STAMPX Used for xref stamping of drawings
;
(defun c:stampx()
;
(command "zoom" "E")
(setq tl (osnap (getpoint "\nPoint to Top Left of drawing frame...")
"end"))
(setq ds (getreal "\nDrawing scale? <1>: "))
(if (= ds nil) (setq ds 1.0))
(setq txts (* 2.0 ds))
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
;
; Standard sheet default locations:
; Stamp locations
(setq xloc (list 25.2 574.49 0.0)) ; Xref list location
(setq ftl (list 24.5 579.0 0.0)) ; Top left of drawing frame
; Polar vectors for stamps

(setq xdist (distance ftl xloc))
(setq xang (angle ftl xloc))
;
(setq scmde (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq layer (getvar "clayer"))
(setq tstyle (getvar "textstyle"))
(setq tsize (getvar "textsize"))
(setq cecol (getvar "cecolor"))
(setq celt (getvar "celtype"))
(command "regenmode" "0")
(command "color" "7")
(setq prec (getvar "LUPREC"))
(setvar "LUPREC" 4)
(command "linetype" "set" "continuous" "")
(command "style" "stamps" "iso3098b" txts "1" "0" "n" "n" "n")
;
; Make the STAMPS layer and clear it
(command "LAYER" "MAKE" "STAMPS" "COLOR" "WHITE" "" "")
(setq r (getstring "Erase the stamp layer? <y>: "))
(setq r (strcase r))
(if (/= r "N")
(progn
(command "ERASE" (ssget "X" (list (cons 8 "STAMPS") (cons 0 "TEXT")
(cons 7 "STAMPS") )) "")
)
)
;
; Stamp the sheet with xrefs
;
(setq pt1 (polar tl xang (* xdist ds)))
(command "text" "style" "stamps" "j" "tl" pt1 "0" "%%uXREF LIST:")
(setq entl (tblnext "block" t))
(while (/= entl nil)
(setq xref (assoc 1 entl))
(if (/= xref nil)
(progn
(setq xref (cdr xref))
(command "text" "" xref)
)
)
(setq entl (tblnext "block"))
)
; Terminate the program
(command "zoom" "P")
(setvar "LUPREC" prec)
(if (= layer "STAMPS") (setq layer "0"))
(command "layer" "s" layer "")
(command "color" cecol)
(command "style" tstyle "iso3098b" tsize "1" "0" "n" "n" "n")
; RESET FONT & TWF etc?
(command "regenmode" "1")
(setvar "cmdecho" scmde)
(setvar "osmode" osm)
(prompt "\nW A R N I N G: Do not draw on the layer 'STAMPS'!")
(prin1)
)
;CODING ENDS HERE

The AutoLisp/Visual Lisp/VBA Resource Website

Copyright © 1999-Perpetuity by AfraLisp

All rights reserved.
Information in this document is subject to change without notice.
Site created and maintained by Kenny Ramage

The AutoLisp/Visual Lisp/VBA Resource Website