;;;Adds words used in a drawing to Abbr.txt in the drawing's folder or ;;;creates Abbr.txt if it does not exist. Does not make duplicate entries. ;;;Run in every drawing to list all abbreviations and other words used ;;;across a project. Cannot recognize words in Xrefs or nested blocks. ;;; ;;; Author: Henry C. Francis ;;; 425 N. Ashe St. ;;; Southern Pines, NC 28387 ;;; ;;; http://www.paracadd.com ;;; All rights reserved. ;;; ;;; Edited: 11-23-2005 ;;; ;;;**************************************************************************** (DEFUN c:abbrlst (/ abbr_lst ss) (SETQ ss (SSGET "x" '((-4 . "") (-4 . "") (-4 . "AND>") (-4 . "OR>") ) ) ;_ end of ssget ) ;_ end of setq (IF ss (PROGN (SETQ sslen (SSLENGTH ss)) (SETQ count 0) (SETQ earall (ukword 1 "Add Create" "dd words to global list or reate/replace word list for this drawing?" (IF earall earall "Create" ) ;_ end of IF ) ;_ end of ukword ) ;_ end of SETQ (IF (> (LENGTH (CDR (DOS_STRTOKENS (CADR (DOS_SPLITPATH (GETVAR "dwgprefix"))) "\\"))) 2) ;set path one folder up from DWG files if possible (SETQ abbr_file_path (STRCAT (CAR (DOS_SPLITPATH (GETVAR "dwgprefix"))) "\\" (EVAL (CONS 'STRCAT (MAPCAR '(LAMBDA (x) (STRCAT x "\\")) (REVERSE (CDDR (REVERSE (CDR (DOS_STRTOKENS (CADR (DOS_SPLITPATH (GETVAR "dwgprefix"))) "\\"))) ) ;_ end of CDDR ) ;_ end of REVERSE ) ;_ end of MAPCAR ) ;_ end of CONS ) ;_ end of EVAL ) ;_ end of STRCAT ) ;_ end of SETQ (SETQ abbr_file_path (GETVAR "dwgprefix")) ) ;_ end of IF (SETQ abbr_file (IF (EQ earall "Create") (STRCAT (GETVAR "dwgprefix") (SUBSTR (GETVAR "dwgname") 1 (- (STRLEN (GETVAR "dwgname")) 4)) "-allword.txt" ) ;_ end of STRCAT (STRCAT abbr_file_path "allword.txt") ) ;_ end of IF ) ;_ end of SETQ (PRINC (STRCAT "\n" (ITOA sslen) " text objects will be examined.\n")) (PRINC) (IF abbr_lst NIL (IF (AND (NOT (EQ earall "Create")) (SETQ abbr_found (FINDFILE abbr_file))) (PROGN (SETQ abbr_in (OPEN abbr_found "r")) (WHILE (SETQ rd_lin (READ-LINE abbr_in)) (IF (AND abbr_lst (NOT (MEMBER (STRCASE rd_lin) abbr_lst))) (SETQ abbr_lst (APPEND abbr_lst (LIST (STRCASE rd_lin)))) (IF abbr_lst NIL (SETQ abbr_lst (LIST (STRCASE rd_lin))) ) ) ;_ end of if ) ;_ end of while (CLOSE abbr_in) ) ;_ end of progn ) ) ;_ end of if (WHILE (< count sslen) (SETQ curentnam (SSNAME ss count) curentdef (ENTGET curentnam) txt_item NIL ) ;_ end of SETQ (COND ((EQ (CDR (ASSOC 0 curentdef)) "INSERT") (SETQ blkent (TBLSEARCH "BLOCK" (CDR (ASSOC 2 curentdef)))) (IF (>= (CDR (ASSOC 70 blkent)) 4) NIL (PROGN (WHILE (AND curentdef (/= (CDR (ASSOC 0 curentdef)) "SEQEND")) (COND ((OR (EQ (CDR (ASSOC 0 curentdef)) "TEXT") (AND (EQ (CDR (ASSOC 0 curentdef)) "ATTRIB") ;These attribute tags are excluded (specific to "our" sheet title blocks and callouts) ;Add or remove tags to satisfy your own needs. (NOT (EQ (CDR (ASSOC 2 curentdef)) "SEC_DET_REF")) (NOT (EQ (CDR (ASSOC 2 curentdef)) "SHT_DRAWN_ON")) (NOT (EQ (CDR (ASSOC 2 curentdef)) "SCALE")) (NOT (EQ (CDR (ASSOC 2 curentdef)) "SHT_NO.")) ) ;_ end of AND (AND (EQ (CDR (ASSOC 0 curentdef)) "DIMENSION") (ASSOC 1 curentdef)) ) ;_ end of OR (IF txt_item (SETQ txt_item (STRCAT txt_item " " (CDR (ASSOC 1 curentdef)))) (SETQ txt_item (CDR (ASSOC 1 curentdef))) ) ;_ end of IF ) ((EQ (CDR (ASSOC 0 curentdef)) "MTEXT") (SETQ this_item (CDR (ASSOC 1 curentdef))) (WHILE (SETQ curentdef (MEMBER (ASSOC 3 curentdef) curentdef)) (SETQ this_item (STRCAT (CDR (ASSOC 3 curentdef)) this_item) curentdef (CDR curentdef) ) ) (mtxtsubr)) ) ;_ end of COND (IF (ASSOC -1 curentdef) (SETQ nxtentnam (ENTNEXT (CDR (ASSOC -1 curentdef)))) (SETQ nxtentnam NIL) ) (IF nxtentnam (SETQ curentdef (ENTGET nxtentnam)) (SETQ curentdef NIL) ) ;_ end of IF ) ;_ end of WHILE (additems) ) ;_ end of PROGN ) ;_ end of IF ) ((EQ (CDR (ASSOC 0 curentdef)) "MTEXT") (SETQ this_item (CDR (ASSOC 1 curentdef))) (WHILE (SETQ curentdef (MEMBER (ASSOC 3 curentdef) curentdef)) (SETQ this_item (STRCAT (CDR (ASSOC 3 curentdef)) this_item) curentdef (CDR curentdef) ) ) (mtxtsubr) (additems) ) ((EQ (CDR (ASSOC 0 curentdef)) "MULTILEADER") (IF txt_item (SETQ txt_item (STRCAT txt_item " " (CDR (ASSOC 304 curentdef)))) (SETQ txt_item (CDR (ASSOC 304 curentdef))) ) ;_ end of IF (additems) ) ((EQ (CDR (ASSOC 0 curentdef)) "LEADER") (SETQ curentdef (ENTGET (CDR (ASSOC 340 curentdef)))) (mtxtsubr) (additems) ) (T (SETQ txt_item (CDR (ASSOC 1 curentdef))) (additems)) ) ;_ end of COND (SETQ count (1+ count) begincnt 1 charcnt 1 ) ;_ end of setq ) ;_ end of while (IF (AND abbr_lst (EQ (TYPE abbr_lst) 'LIST)) (SETQ abbr_lst (ACAD_STRLSORT abbr_lst)) ) ;_ end of IF (IF abbr_lst (PROGN (SETQ abbr_out (OPEN abbr_file "w")) (FOREACH n abbr_lst (PRINC (STRCAT n "\n") abbr_out)) ) ;_ end of PROGN (PROGN (PRINC "\nNo words found! ") (PRINC)) ) ;_ end of IF (CLOSE abbr_out) ) ;_ end of PROGN (ALERT "There is nothing in this drawing to glean words from!") ) ;_ end of IF ) ;_ end of defun ;;;**************************************************************************** (DEFUN mtxtsubr () (IF this_item (SETQ txt_item this_item) ;;; (IF txt_item ;;; (SETQ txt_item (STRCAT txt_item " " (CDR (ASSOC 1 curentdef)))) (SETQ txt_item (CDR (ASSOC 1 curentdef))) ) ;_ end of IF ;;; (WHILE (SETQ nxt_txt (ASSOC 3 curentdef)) ;;; (SETQ txt_item (STRCAT txt_item (CDR nxt_txt)) ;;; curentdef (CDR (MEMBER nxt_txt curentdef)) ;;; ) ;_ end of SETQ ;;; ) ;_ end of WHILE (PRINC) ) ;_ end of defun ;;;**************************************************************************** (DEFUN abbrlst (earall / abbr_lst) (SETQ ss (SSGET "x" '((-4 . "") (-4 . "") (-4 . "AND>") (-4 . "OR>") ) ) ;_ end of ssget ) ;_ end of setq (SETQ sslen (SSLENGTH ss)) (SETQ count 0) (IF (> (LENGTH (CDR (DOS_STRTOKENS (CADR (DOS_SPLITPATH (GETVAR "dwgprefix"))) "\\"))) 2) ;set path one folder up from DWG files if possible (SETQ abbr_file_path (STRCAT (CAR (DOS_SPLITPATH (GETVAR "dwgprefix"))) "\\" (EVAL (CONS 'STRCAT (MAPCAR '(LAMBDA (x) (STRCAT x "\\")) (REVERSE (CDDR (REVERSE (CDR (DOS_STRTOKENS (CADR (DOS_SPLITPATH (GETVAR "dwgprefix"))) "\\")))) ) ;_ end of REVERSE ) ;_ end of MAPCAR ) ;_ end of CONS ) ;_ end of EVAL ) ;_ end of STRCAT ) ;_ end of SETQ (SETQ abbr_file_path (GETVAR "dwgprefix")) ) ;_ end of IF (SETQ abbr_file (IF (EQ earall "Create") (STRCAT (GETVAR "dwgprefix") (SUBSTR (GETVAR "dwgname") 1 (- (STRLEN (GETVAR "dwgname")) 4)) "-allword.txt" ) ;_ end of STRCAT (STRCAT abbr_file_path "allword.txt") ) ;_ end of IF ) ;_ end of SETQ (PROGN (IF abbr_lst NIL (IF (AND (NOT (EQ earall "Create")) (SETQ abbr_found (FINDFILE abbr_file))) (PROGN (SETQ abbr_in (OPEN abbr_found "r")) (WHILE (SETQ rd_lin (READ-LINE abbr_in)) (IF (AND abbr_lst (NOT (MEMBER (STRCASE rd_lin) abbr_lst))) (SETQ abbr_lst (APPEND abbr_lst (LIST (STRCASE rd_lin)))) (IF abbr_lst NIL (SETQ abbr_lst (LIST (STRCASE rd_lin))) ) ) ;_ end of if ) ;_ end of while (CLOSE abbr_in) ) ;_ end of progn ) ) ;_ end of if ) ;_ end of PROGN (WHILE (< count sslen) (SETQ curentnam (SSNAME ss count) curentdef (ENTGET curentnam) txt_item NIL this_item_lst NIL ) ;_ end of SETQ (COND ((EQ (CDR (ASSOC 0 curentdef)) "INSERT") (SETQ blkent (TBLSEARCH "BLOCK" (CDR (ASSOC 2 curentdef)))) (IF (>= (CDR (ASSOC 70 blkent)) 4) NIL (PROGN (WHILE (AND curentdef (/= (CDR (ASSOC 0 curentdef)) "SEQEND")) (COND ((OR (EQ (CDR (ASSOC 0 curentdef)) "TEXT") (AND (EQ (CDR (ASSOC 0 curentdef)) "ATTRIB") ;These attribute tags are excluded (specific to "our" sheet title blocks and callouts) ;Add or remove tags to satisfy your own needs. (NOT (EQ (CDR (ASSOC 2 curentdef)) "SEC_DET_REF")) (NOT (EQ (CDR (ASSOC 2 curentdef)) "SHT_DRAWN_ON")) (NOT (EQ (CDR (ASSOC 2 curentdef)) "SCALE")) (NOT (EQ (CDR (ASSOC 2 curentdef)) "SHT_NO.")) ) ;_ end of AND (AND (EQ (CDR (ASSOC 0 curentdef)) "DIMENSION") (ASSOC 1 curentdef)) ) ;_ end of OR (IF txt_item (SETQ txt_item (STRCAT txt_item " " (CDR (ASSOC 1 curentdef)))) (SETQ txt_item (CDR (ASSOC 1 curentdef))) ) ;_ end of IF ) ((EQ (CDR (ASSOC 0 curentdef)) "MTEXT") (SETQ this_item (CDR (ASSOC 1 curentdef))) (WHILE (SETQ curentdef (MEMBER (ASSOC 3 curentdef) curentdef)) (SETQ this_item (STRCAT (CDR (ASSOC 3 curentdef)) this_item) curentdef (CDR curentdef) ) ) (mtxtsubr)) ) ;_ end of COND (IF (ASSOC -1 curentdef) (SETQ nxtentnam (ENTNEXT (CDR (ASSOC -1 curentdef)))) (SETQ nxtentnam NIL) ) (IF nxtentnam (SETQ curentdef (ENTGET nxtentnam)) (SETQ curentdef NIL) ) ;_ end of IF ) ;_ end of WHILE (additems) ) ;_ end of PROGN ) ;_ end of IF ) ((EQ (CDR (ASSOC 0 curentdef)) "MTEXT") (SETQ this_item (CDR (ASSOC 1 curentdef))) (WHILE (SETQ curentdef (MEMBER (ASSOC 3 curentdef) curentdef)) (SETQ this_item (STRCAT (CDR (ASSOC 3 curentdef)) this_item) curentdef (CDR curentdef) ) ) (mtxtsubr) (additems) ) ((EQ (CDR (ASSOC 0 curentdef)) "MULTILEADER") (IF txt_item (SETQ txt_item (STRCAT txt_item " " (CDR (ASSOC 304 curentdef)))) (SETQ txt_item (CDR (ASSOC 304 curentdef))) ) ;_ end of IF (additems) ) ((EQ (CDR (ASSOC 0 curentdef)) "LEADER") (SETQ curentdef (ENTGET (CDR (ASSOC 340 curentdef)))) (mtxtsubr) (additems) ) (T (SETQ txt_item (CDR (ASSOC 1 curentdef))) (additems)) ) ;_ end of COND (SETQ count (1+ count) begincnt 1 charcnt 1 ) ;_ end of setq ) ;_ end of while (IF (AND abbr_lst (EQ (TYPE abbr_lst) 'LIST)) (SETQ abbr_lst (ACAD_STRLSORT abbr_lst)) ) ;_ end of IF (IF abbr_lst (PROGN (SETQ abbr_out (OPEN abbr_file "w")) (FOREACH n abbr_lst (PRINC (STRCAT n "\n") abbr_out)) ) ;_ end of PROGN (PROGN (PRINC "\nNo words found! ") (PRINC)) ) ;_ end of IF (CLOSE abbr_out) (SETQ last_abbr_lst abbr_lst) (PRINC) ) ;_ end of defun ;;;**************************************************************************** (DEFUN additems () (PRINC "\n\t\t") (PRINC txt_item) (SETQ this_item_lst (DOS_STRTOKENS (DOS_STRTRIMLEFT txt_item) " ,\t\n()!:;?{}\\" T)) (PRINC "\n\t\t\t") (PRINC this_item_lst) (PRINC) (IF this_item_lst (FOREACH n this_item_lst ;;; (IF (WCMATCH n "\\[ACHLPS]*") ;;; (SETQ n (SUBSTR n 3)) ;;; ) (IF (OR (NOT n) (EQ n "") (WCMATCH n "<>") (MEMBER (STRCASE n) abbr_lst)) NIL (SETQ abbr_lst (APPEND abbr_lst (LIST (STRCASE n)))) ) ;_ end of IF ) ;_ end of FOREACH (PROGN ) ) ;_ end of IF (SETQ this_item_lst NIL) (PRINC) ) ;_ end of defun ;;;**************************************************************************** (DEFUN C:ABBRFILES (/ str_found srch_list) (SETQ abbrfile_list (DOS_DIR (STRCAT (GETVAR "DWGPREFIX") "*ALLWORD.TXT"))) (SETQ a_list_file (OPEN (STRCAT (GETVAR "DWGPREFIX") "A-LIST.TXT") "r")) (IF (AND abbrfile_list a_list_file) (PROGN (WHILE (SETQ srch_word (READ-LINE a_list_file)) (SETQ srch_list (APPEND srch_list (LIST srch_word))) ) ;_ end of WHILE (CLOSE a_list_file) (SETQ abbr_shtlst (OPEN (STRCAT (GETVAR "DWGPREFIX") "abbr_shts.txt") "w")) (FOREACH srch_str srch_list (PRINC (STRCAT "\n" srch_str)) (WRITE-LINE srch_str abbr_shtlst) (snglabbrsrch srch_str) ) ;_ end of FOREACH (CLOSE abbr_shtlst) ) ;_ end of PROGN (COND (a_list_file (PRINC (strcat "\nRun the ABBRLST command or (abbrlst) function with the \"Create\" option on the sheets you want to check in " (getvar "dwgprefix") " " ) ;_ end of strcat ) ;_ end of PRINC ) (abbrfile_list (PRINC (strcat "\nCreate a file named \"A-LIST.TXT\" in " (getvar "dwgprefix") " containing your abbreviations, one abbreviation per line. " ) ;_ end of strcat ) ;_ end of PRINC ) (T (PRINC "\nCreate a file named \"A-LIST.TXT\" containing your abbreviations, one abbreviation per line. " ) ;_ end of PRINC (PRINC "\nRun the ABBRLST command or (abbrlst) function with the \"Add\" option on the sheets you want to check and then edit \"ALLWORD.TXT\". Save it as \"A-LIST.TXT\" " ) ;_ end of PRINC (PRINC "\nRun the ABBRLST command or (abbrlst) function with the \"Create\" option on the sheets you want to check " ) ;_ end of PRINC ) ) ;_ end of COND ) ;_ end of IF (PRINC) ) ;_ end of DEFUN ;;;**************************************************************************** (DEFUN C:ABBRSRCH (/ cl_srch) (SETQ srch_str (ustr 1 "\nEnter case sensitive abbreviation to search for. " srch_str T)) (SETQ cl_srch T) (snglabbrsrch srch_str) ) ;_ end of DEFUN ;;;**************************************************************************** (DEFUN snglabbrsrch (str /) (FOREACH n abbrfile_list (SETQ openabbr (OPEN (STRCAT (GETVAR "dwgprefix") n) "r")) (WHILE (SETQ abbr_rdln (READ-LINE openabbr)) (IF (WCMATCH abbr_rdln str) (SETQ str_found T) ) ;_ end of if ) ;_ end of while (CLOSE openabbr) (IF (AND str_found (NOT (WCMATCH (STRCASE n) "ALLWORD.TXT"))) (PROGN (PRINC "\n\t\t") (PRINC (SUBSTR n 1 (- (STRLEN n) 11))) (PRINC) (IF cl_srch NIL (WRITE-LINE (STRCAT "\t\t" (SUBSTR n 1 (- (STRLEN n) 11))) abbr_shtlst) ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of if (SETQ str_found nil) ) ;_ end of foreach ) ;_ end of DEFUN ;|«Visual LISP© Format Options» (120 2 15 2 T "end of " 100 9 2 0 nil nil nil T T) ;*** DO NOT add text below the comment! ***|;