cadiehl
Industrial
- May 12, 2001
- 29
Can anyone figure out why this code will not work in ACAD2000i? I had it working fine in R14... I need this stamp to be on the elec drawings, that is why I do not want to use the plot stamp tool in R2000...
Thanks in advance for all of your help...
CD
OPEN YOUR ACAD.MNL OR ACADFULL.MNL FILE IN NOTEPAD.
COPY AND PASTE THE BELOW TEXT AT THE VERY END OF YOUR ACAD.MNL OR ACADFULL.MNL FILE, MAKE SURE YOU PLACE THE NAMEDATE.DWG FILE IN YOUR ACADR14 "SUPPORT" SUB-DIRECTORY.
(DEFUN INSDAT ()
(SETQ INSPT (GETPOINT "\nSELECT INSERTION POINT FOR STAMP: "
)
(COMMAND "LAYER" "M" "NDATE" "" "INSERT" "NAMEDATE" INSPT (ISCC) (ISCC) 0 ))
(VMON)
(setvar "cmdecho" 1)
;************************MODIFIED END ROUTINE************************
(DEFUN ISCC ()
(* (GETVAR "TEXTSIZE"
58)
);END DEFUN
(DEFUN C:END ()
(setvar "cmdecho" 0)
(M_STIR)
(SETQ BLK1 "NAMEDATE"
(SETQ BENT (SSGET "X" (LIST (CONS 2 BLK1))))
(IF BENT
(PROGN
(PROMPT "\nUpdating Time/Date Stamp..."
(PRINC)
(UPD)(princ)
)
(progn
(princ "NAME/DATE STAMP NOT FOUND"
(INSDAT)
(UPD)
)
)
(SETVAR "EXPERT" 2)
(M_STIR)
; (C:CSAVE)
(COMMAND ".SAVE" (STRCAT drive ":" DWG))
(SETVAR "EXPERT" 1)
(COMMAND ".END"
)
;****************************MODIFIED SAVE ROUTINE***************************
(DEFUN C:SAVE ()
(setvar "cmdecho" 0)
(M_STIR)
(SETQ BLK1 "NAMEDATE"
(SETQ BENT (SSGET "X" (LIST (CONS 2 BLK1))))
(IF BENT
(PROGN
(PROMPT "\nUpdating Time/Date Stamp..."
(PRINC)
(SETQ C (SSNAME BENT 0))
(SETQ B2 (ENTNEXT C))
(SETQ B3 (ENTNEXT B2))
(UPD)(princ)
)
(progn
(princ "NAME/DATE STAMP NOT FOUND"
(setq mastsf (ISCC))
(SETVAR "ATTREQ" 0)
(INSDAT)
(SETVAR "ATTREQ" 1)
(SETQ BENT (SSGET "X" (LIST (CONS 2 BLK1))))
(UPD)
)
)
;(C:CSAVE)
(SETVAR "EXPERT" 2)
(COMMAND ".SAVE" ""
(princ)
(SETVAR "EXPERT" 1)
)
;(DEFUN C:CSAVE ()
; (SETQ DIREC (GETVAR "DWGPREFIX" ))
; (SETQ PATH (STRCAT DIREC "\R12DWGS" "\\"
)
; (SETQ SAVPATH (STRCAT PATH DWG))
; (COMMAND ".SAVEASR12" SAVPATH "Y"
; )
(DEFUN C:QSAVE ()
; (C:CSAVE)
(C:SAVE)
)
;***************SUBROUTINE CALLED BY END & SAVE ROUTINES*********************
(DEFUN UPD ()
(SETQ C (SSNAME BENT 0))
(SETQ B2 (ENTNEXT C))
(SETQ B3 (ENTNEXT B2))
(FT)
(SETQ B2 (entget B2))
(SETQ D (CDR (SETQ H (ASSOC 1 B2))))
(SETQ SF11 (GETVAR "DIMSCALE"
)
(SETQ SF11 (RTOS SF11 2 1))
(SETQ D1 (CONS (CAR H) CD))
(SETQ B1 (SUBST D1 H B2))
(ENTMOD B1)
(SETQ G CD)
(M_STIR)
(SETQ CD (STRCASE DWG))
(SETQ B2 B3)
(SETQ B2 (entget B2))
(SETQ D (CDR (SETQ H (ASSOC 1 B2))))
(SETQ G CD)
(SETQ G (STRCAT G " " SF11))
(SETQ D1 (CONS (CAR H) G))
(SETQ B1 (SUBST D1 H B2))
(ENTMOD B1)
(ENTUPD C)(PRINC)
)
;****************SUBROUTINE CALLED BY SAVE & END ROUTINES****************
(defun FT (/ CD1 CD2 LN1 SF2 PT1 PT3 WIDTH2 HEIGHT2 PT2 SS1)
(setvar "cmdecho" 0)
(SETQ CD1 (RTOS (GETVAR "CDATE"
2 0))
(SETQ CD2 (RTOS (GETVAR "CDATE"
2 6))
(SETQ LN1 (STRCAT
(SUBSTR CD2 10 2) ":"
(SUBSTR CD2 12 2)
))
(SETQ CD (STRCAT
LN1 " "
(SUBSTR CD1 5 2)
"/"
(SUBSTR CD1 7 2)
"/"
(SUBSTR CD1 3 2)
)
)
)
;********************STRIPS PATH FROM DRAWING NAME******************
(DEFUN M_STIR (/ A B1 N K)
(SETQ A (GETVAR "DWGNAME"
)
(SETQ DWG "" B1 "" N "YES" K (STRLEN A))
(WHILE (= N "YES"
(SETQ B1 (SUBSTR A K 1))
(IF (= B1 (CHR 92))
(PROGN (SETQ N "NO"
)
(PROGN
(SETQ K (- K 1))
(SETQ DWG (STRCAT B1 DWG))))
(IF (= K 0)(SETQ N "NO"
))
)
;**************************AUTO LOADING LISP FUNTIONS***********************
(defun s::startup ()
(setvar "cmdecho" 0)
(command "undefine" "end"
(command "undefine" "save"
(command "undefine" "qsave"
)
;*********************************************************************
;*********************************************************************
;*********************************************************************
;MISC ROUTINES
(LOAD"AI_UTILS"
;;;
(DEFUN CUR_LAY ()
(SETQ CUR_LAY (GETVAR "CLAYER"
)
);END DEFUN
;;;;
(DEFUN SET_LAY ()
(SETVAR "CLAYER" CUR_LAY)
);END DEFUN
;;;
;;;;;;
(DEFUN ISC ()
(/ (GETVAR "LTSCALE"
36)
);END DEFUN
;;;;;;
(DEFUN EX_CHL()
(SETQ SS1 (SSGET "L"
)
(SETQ INDEX 0)
(SETQ ENT1(ENTGET(SSNAME SS1 INDEX)))
(SETQ NLAY (ASSOC 8 ENT1))
(SETQ NL (CDR NLAY))
(COMMAND "EXPLODE" "L"
(COMMAND "CHANGE" "P" "" "P" "LA" NL ""
);CLOSE DEFUN
Thanks in advance for all of your help...
CD
OPEN YOUR ACAD.MNL OR ACADFULL.MNL FILE IN NOTEPAD.
COPY AND PASTE THE BELOW TEXT AT THE VERY END OF YOUR ACAD.MNL OR ACADFULL.MNL FILE, MAKE SURE YOU PLACE THE NAMEDATE.DWG FILE IN YOUR ACADR14 "SUPPORT" SUB-DIRECTORY.
(DEFUN INSDAT ()
(SETQ INSPT (GETPOINT "\nSELECT INSERTION POINT FOR STAMP: "
(COMMAND "LAYER" "M" "NDATE" "" "INSERT" "NAMEDATE" INSPT (ISCC) (ISCC) 0 ))
(VMON)
(setvar "cmdecho" 1)
;************************MODIFIED END ROUTINE************************
(DEFUN ISCC ()
(* (GETVAR "TEXTSIZE"
);END DEFUN
(DEFUN C:END ()
(setvar "cmdecho" 0)
(M_STIR)
(SETQ BLK1 "NAMEDATE"
(SETQ BENT (SSGET "X" (LIST (CONS 2 BLK1))))
(IF BENT
(PROGN
(PROMPT "\nUpdating Time/Date Stamp..."
(UPD)(princ)
)
(progn
(princ "NAME/DATE STAMP NOT FOUND"
(INSDAT)
(UPD)
)
)
(SETVAR "EXPERT" 2)
(M_STIR)
; (C:CSAVE)
(COMMAND ".SAVE" (STRCAT drive ":" DWG))
(SETVAR "EXPERT" 1)
(COMMAND ".END"
)
;****************************MODIFIED SAVE ROUTINE***************************
(DEFUN C:SAVE ()
(setvar "cmdecho" 0)
(M_STIR)
(SETQ BLK1 "NAMEDATE"
(SETQ BENT (SSGET "X" (LIST (CONS 2 BLK1))))
(IF BENT
(PROGN
(PROMPT "\nUpdating Time/Date Stamp..."
(SETQ C (SSNAME BENT 0))
(SETQ B2 (ENTNEXT C))
(SETQ B3 (ENTNEXT B2))
(UPD)(princ)
)
(progn
(princ "NAME/DATE STAMP NOT FOUND"
(setq mastsf (ISCC))
(SETVAR "ATTREQ" 0)
(INSDAT)
(SETVAR "ATTREQ" 1)
(SETQ BENT (SSGET "X" (LIST (CONS 2 BLK1))))
(UPD)
)
)
;(C:CSAVE)
(SETVAR "EXPERT" 2)
(COMMAND ".SAVE" ""
(SETVAR "EXPERT" 1)
)
;(DEFUN C:CSAVE ()
; (SETQ DIREC (GETVAR "DWGPREFIX" ))
; (SETQ PATH (STRCAT DIREC "\R12DWGS" "\\"
; (SETQ SAVPATH (STRCAT PATH DWG))
; (COMMAND ".SAVEASR12" SAVPATH "Y"
; )
(DEFUN C:QSAVE ()
; (C:CSAVE)
(C:SAVE)
)
;***************SUBROUTINE CALLED BY END & SAVE ROUTINES*********************
(DEFUN UPD ()
(SETQ C (SSNAME BENT 0))
(SETQ B2 (ENTNEXT C))
(SETQ B3 (ENTNEXT B2))
(FT)
(SETQ B2 (entget B2))
(SETQ D (CDR (SETQ H (ASSOC 1 B2))))
(SETQ SF11 (GETVAR "DIMSCALE"
(SETQ SF11 (RTOS SF11 2 1))
(SETQ D1 (CONS (CAR H) CD))
(SETQ B1 (SUBST D1 H B2))
(ENTMOD B1)
(SETQ G CD)
(M_STIR)
(SETQ CD (STRCASE DWG))
(SETQ B2 B3)
(SETQ B2 (entget B2))
(SETQ D (CDR (SETQ H (ASSOC 1 B2))))
(SETQ G CD)
(SETQ G (STRCAT G " " SF11))
(SETQ D1 (CONS (CAR H) G))
(SETQ B1 (SUBST D1 H B2))
(ENTMOD B1)
(ENTUPD C)(PRINC)
)
;****************SUBROUTINE CALLED BY SAVE & END ROUTINES****************
(defun FT (/ CD1 CD2 LN1 SF2 PT1 PT3 WIDTH2 HEIGHT2 PT2 SS1)
(setvar "cmdecho" 0)
(SETQ CD1 (RTOS (GETVAR "CDATE"
(SETQ CD2 (RTOS (GETVAR "CDATE"
(SETQ LN1 (STRCAT
(SUBSTR CD2 10 2) ":"
(SUBSTR CD2 12 2)
))
(SETQ CD (STRCAT
LN1 " "
(SUBSTR CD1 5 2)
"/"
(SUBSTR CD1 7 2)
"/"
(SUBSTR CD1 3 2)
)
)
)
;********************STRIPS PATH FROM DRAWING NAME******************
(DEFUN M_STIR (/ A B1 N K)
(SETQ A (GETVAR "DWGNAME"
(SETQ DWG "" B1 "" N "YES" K (STRLEN A))
(WHILE (= N "YES"
(SETQ B1 (SUBSTR A K 1))
(IF (= B1 (CHR 92))
(PROGN (SETQ N "NO"
(PROGN
(SETQ K (- K 1))
(SETQ DWG (STRCAT B1 DWG))))
(IF (= K 0)(SETQ N "NO"
)
;**************************AUTO LOADING LISP FUNTIONS***********************
(defun s::startup ()
(setvar "cmdecho" 0)
(command "undefine" "end"
(command "undefine" "save"
(command "undefine" "qsave"
)
;*********************************************************************
;*********************************************************************
;*********************************************************************
;MISC ROUTINES
(LOAD"AI_UTILS"
;;;
(DEFUN CUR_LAY ()
(SETQ CUR_LAY (GETVAR "CLAYER"
);END DEFUN
;;;;
(DEFUN SET_LAY ()
(SETVAR "CLAYER" CUR_LAY)
);END DEFUN
;;;
;;;;;;
(DEFUN ISC ()
(/ (GETVAR "LTSCALE"
);END DEFUN
;;;;;;
(DEFUN EX_CHL()
(SETQ SS1 (SSGET "L"
(SETQ INDEX 0)
(SETQ ENT1(ENTGET(SSNAME SS1 INDEX)))
(SETQ NLAY (ASSOC 8 ENT1))
(SETQ NL (CDR NLAY))
(COMMAND "EXPLODE" "L"
(COMMAND "CHANGE" "P" "" "P" "LA" NL ""
);CLOSE DEFUN