AutoCAD LISP 22
tfind2fun.lsp = поиск и замена
zam.lsp = поиск и замена
b2e.lsp = из AutoCAD в Excel = может НЕ работать
Интеграция ArchiCAD перевод в AutoCAD индексация DWG
архив многих LISP пол-мегабайта
http://kenokeno.ucoz.ru/dwg/LISP.rar
tfind2fun.lsp = поиск и замена
;-============-;
;- Text Find -;
;- *~* -;
; Written by -;
; Mark Mercier ;
; 05-06-09 ;
;-============-;
(defun tfind2fun (inputF inputR caseSn / goto goWhile strinF strinR selSet selTxt searep case count error)
; 01 Create selection set. GOTO 02 if success, or GOTO 08 if fail
; 02 Check passed input. If both nil, GOTO 03. If first string and second nil, GOTO 06. If both strings, GOTO 07. Otherwise, return error and GOTO 08
; 03 Display menus and obtain data from user. If Search, GOTO 04. If Replace, GOTO 05
; 04 Search option selected. Prompt user for single search term. GOTO 06
; 05 Replace option selected. Prompt user for search term and replace term. GOTO 07
; 06 One string has been passed. Assume automatic search. GOTO FINISH
; 07 Two strings have been passed. Assume automatic replace. GOTO FINISH
; 08 FINISH. Return errors or messages if needed.
(vl-load-com)
(setq goTo 1)
(setq goWhile 1)
(setq count 0)
(if (not (mlml (list caseSn) (list 0 1)))
(progn (setq goWhile nil) (princ "\nCase selection not recognized."))
) ;_ end of if
(if (= caseSn 0)
(setq case "N")
(setq case "Y")
) ;_ end of if
(while goWhile
(cond
((= goTo 1)
(if (setq selSet (extTxtPt (ssget "X")))
(setq goTo 2)
(setq error "\nSelection set not found."
goTo 8
) ;_ end of setq
) ;_ end of if
)
((= goTo 2)
; Check input, pass to whatever.
(cond
((and (= inputF nil) (= inputR nil))
(setq goTo 3)
)
((and (= (type inputF) 'STR) (= inputR nil))
(setq strinF inputF)
(setq goTo 6)
)
((and (= (type inputF) 'STR) (= (type inputR) 'STR))
(setq strinF inputF)
(setq strinR inputR)
(setq goTo 7)
)
(t
(setq error "\nPassed arguments are not accepted.")
(setq goTo 8)
)
) ;_ end of cond
)
((= goTo 3)
; Obtain desired option from user
(while (not
(mlml (list (setq searep (strcase (getstring nil "\nSelect option [Find/Replace/Quit/Case]: "))))
(list "F" "FIND" "R" "REPLACE" "Q" "QUIT" "C" "CASE")
) ;_ end of mlml
) ;_ end of not
) ;_ end of while
(cond
((mlml (list searep) (list "F" "FIND"))
(setq goTo 4)
)
((mlml (list searep) (list "R" "REPLACE"))
(setq goTo 5)
)
((mlml (list searep) (list "Q" "QUIT"))
(setq goTo 8)
)
((mlml (list searep) (list "C" "CASE"))
(while (not (mlml (list (setq case (strcase (getstring nil "\nCase sensitive? [Yes/No]: "))))
(list "Y" "YES" "N" "NO")
) ;_ end of mlml
) ;_ end of not
) ;_ end of while
)
) ;_ end of cond
)
((= goTo 4)
; Obtain search string from user, set to strinF
(while (eq "" (setq strinF (getstring t "\nEnter search term: "))))
(setq goTo 6)
)
((= goTo 5)
; Obtain search string and replace string from user, set to strinF and strinR respectively
(while (eq "" (setq strinF (getstring t "\nEnter find term: "))))
(while (eq "" (setq strinR (getstring t "\nEnter replace term: "))))
(setq goTo 7)
)
((= goTo 6)
; Search drawing for strinF
(cond
((mlml (list case) (list "Y" "YES"))
; Compare using (vl-string-search strinF input), view selection
; use "while" to get all search occurances
(foreach selVar selSet
(if (vl-string-search strinF (nth 0 selVar))
(progn
(setq count (1+ count))
(if (/= (getvar "ctab") (caddr selVar))
(command "ctab" (caddr selVar))
) ;_ end of if
(command "zoom" "c" (trans (cadr selVar) 0 1) (* 32 (nth 3 selVar)))
(getstring "\nPress 'Enter' to continue: ")
) ;_ end of progn
) ;_ end of if
) ;_ end of foreach
)
((mlml (list case) (list "N" "NO"))
; Compare using (vl-string-search (strcase strinF) (strcase input)), view selection
; use "while" to get all search occurances
(foreach selVar selSet
(if (vl-string-search (strcase strinF) (strcase (nth 0 selVar)))
(progn
(setq count (1+ count))
(if (/= (getvar "ctab") (caddr selVar))
(command "ctab" (caddr selVar))
) ;_ end of if
(command "zoom" "c" (trans (cadr selVar) 0 1) (* 32 (nth 3 selVar)))
(getstring "\nPress 'Enter' to continue: ")
) ;_ end of progn
) ;_ end of if
) ;_ end of foreach
)
) ;_ end of cond
(if (= count 0)
(setq error "\nNo matches found.")
(setq error (strcat (itoa count) " matches found."))
) ;_ end of if
(setq goTo 8)
)
((= goTo 7)
; Replace strinF with strinR
(cond
((mlml (list case) (list "Y" "YES"))
; Compare using (vl-search-string strinF input), modify using (vl-string-subst) within a while loop
(foreach selVar selSet
(setq selTxt (nth 0 selVar))
(setq seaLoc 0)
(while (setq seaLoc (vl-string-search strinF selTxt seaLoc))
(setq selTxt (vl-string-subst strinR strinF selTxt seaLoc))
(setq seaLoc (+ seaLoc (strlen strinR)))
(setq count (1+ count))
) ;_ end of while
(vla-put-textstring (vlax-ename->vla-object (nth 4 selVar)) selTxt)
) ;_ end of foreach
)
((mlml (list case) (list "N" "NO"))
; Compare using (vl-string-search (strcase strinF) (strcase input)), modify using (vl-string-subst) within a while loop
(foreach selVar selSet
(setq selTxt (nth 0 selVar))
(setq seaLoc 0)
(while (setq seaLoc (vl-string-search (strcase strinF) (strcase selTxt) seaLoc))
(setq selTxt (strcat (substr selTxt 1 seaLoc) strinR (substr selTxt (+ 1 seaLoc (strlen strinF)))))
(setq seaLoc (+ seaLoc (strlen strinR)))
(setq count (1+ count))
) ;_ end of while
(vla-put-textstring (vlax-ename->vla-object (nth 4 selVar)) selTxt)
) ;_ end of foreach
)
) ;_ end of cond
(if (= count 0)
(setq error "\nNo occurances found.")
(setq error (strcat (itoa count) " occurances modified."))
) ;_ end of if
(setq goTo 8)
)
((= goTo 8)
(if error
(princ error)
) ;_ end of if
(setq goWhile nil)
)
) ;_ end of cond
) ;_ end of while
(princ)
) ;_ end of defun
(defun mlml (inSMLChar inSMLStri / returnVarMS toCheck chkWith)
(setq returnVarMS nil)
(if (and (= (type inSMLChar) 'list)
(= (type inSMLStri) 'list)
) ;_ end of and
(progn
(foreach toCheck inSMLStri
(foreach chkWith inSMLChar
(if (eq toCheck chkWith)
(setq returnVarMS t)
) ;_ end of if
) ;_ end of foreach
) ;_ end of foreach
) ;/progn
) ;_ end of if
returnVarMS
) ; Checks a list to see if a member of that list is the same as a member of another list. Returns T or nil
(defun extTxtPt (ssList / subVar getEnt entTyp entTxt entPnt entLay entHgt grp66 entAtt getEntAtt entAttTyp uniLst)
(setq uniLst nil)
(setq subVar 0)
(if ssList
(repeat (sslength ssList)
(setq getEnt (entget (cadr (car (ssnamex ssList subVar)))))
(setq entTyp (cdr (assoc 0 getEnt)))
(cond
((or (= entTyp "TEXT") (= entTyp "MTEXT"))
(setq entTxt (cdr (assoc 1 getEnt)))
(setq entPnt (cdr (assoc 10 getEnt)))
(setq entHgt (cdr (assoc 40 getEnt)))
(setq entLay (cdr (assoc 410 getEnt)))
(setq entNam (cdr (assoc -1 getEnt)))
(setq uniLst (append uniLst (list (list entTxt entPnt entLay entHgt entNam))))
)
((= entTyp "INSERT")
(setq grp66 (assoc 66 getEnt))
(if grp66
(progn
(setq entAtt (entnext (cdr (assoc -1 getEnt))))
(setq getEntAtt (entget entAtt))
(setq entAttTyp (cdr (assoc 0 getEntAtt)))
) ;_ end of progn
) ;_ end of if
(while (= entAttTyp "ATTRIB")
(setq entTxt (cdr (assoc 1 getEntAtt)))
(setq entPnt (cdr (assoc 10 getEntAtt)))
(setq entHgt (cdr (assoc 40 getEntAtt)))
(setq entLay (cdr (assoc 410 getEntAtt)))
(setq entNam (cdr (assoc -1 getEntAtt)))
(setq uniLst (append uniLst (list (list entTxt entPnt entLay entHgt entNam))))
; Get next entity.
(setq entAtt (entnext (cdr (assoc -1 getEntAtt))))
; Get ent and ent type
(setq getEntAtt (entget entAtt))
(setq entAttTyp (cdr (assoc 0 getEntAtt)))
) ;_ end of while
)
(t
)
) ;_ end of cond
(setq subVar (1+ subVar))
) ;_ end of repeat
) ;_ end of if
uniLst
) ; Return list of all text-based objects (Text, MText, Attribute) in the current drawing
zam.lsp = поиск и замена
(defun c:zam ()
(tfind2fun "dn 300 A" "%%c300" 1)
(tfind2fun "dn 250 A" "%%c250" 1)
(tfind2fun "dn 200 A" "%%c200" 1)
(tfind2fun "dn 150 A" "%%c150" 1)
(tfind2fun "dn 125 A" "%%c125" 1)
(tfind2fun "dn 100 A" "%%c100" 1)
(tfind2fun "dn 80 A" "%%c80" 1)
(tfind2fun "dn 65 A" "%%c65" 1)
(tfind2fun "dn 50 A" "%%c50" 1)
(tfind2fun "dn 40 A" "%%c40" 1)
(tfind2fun "dn 32 A" "%%c32" 1)
(tfind2fun "dn 25 A" "%%c25" 1)
(tfind2fun "dn 20 A" "%%c20" 1)
(tfind2fun "dn 15 A" "%%c15" 1)
(tfind2fun "dn 10 A" "%%c20" 1)
(tfind2fun "dn 0 A" "расчет" 1)
(tfind2fun "L " "Lm " 1)
(tfind2fun ".00" "" 1)
)
b2e.lsp = из AutoCAD в Excel = может НЕ работать
;;;CADALYST 04/06 Tip2107: acad table to excel.lsp AutoCAD Excel Interface (c) 2006 Q.J. Chen
;; The Aim of the Rountine: To transfer the acad table to excel
;; Notes: Now the program can only deal with the table drawed by line or lwpolyline, and the
;; table grid are N*M, not irregular, the rountine is tested under office97
;; and I think it can also run under the after office version.
;; The command name :b2e
; by qjchen at http://www.xdcad.net 2006.02.07
;; South China University of Technology, Architecture Department
;; Some code taken from a Korea Friend, Thanks to them
;; The main program
(defun c:b2e (/ p1 p2 p3 p4 p1a p2a p1b p4b pvlist phlist palllist newpvlist
i j column row ss palist en ed ttext fn fh
)
(setvar "osmode" 33)
(setq p1 (getpoint "\nThe left Up corner point:"))
(setq p3 (getpoint "\nThe Right Bottom corner point:"))
(setvar "osmode" 0)
(setq p2 (list (car p1) (car (cdr p3)) 0))
(setq p4 (list (car p3) (car (cdr p1)) 0))
(setq p1a (polar p1 0 1))
(setq p2a (polar p2 0 1))
(setq p1b (polar p1 (* pi 1.5) 1))
(setq p4b (polar p4 pi 1))
; Get the Table's horizontal and vertical line's place
(setq pvlist (vl-Get-Int-Pt p1a p2a))
(setq pvlist (mapcar
'(lambda (x)
(polar x pi 1)
)
pvlist
)
)
(setq phlist (vl-Get-Int-Pt p1b p4b))
(setq palllist (list pvlist))
(setq i 1)
(repeat (- (length phlist) 1)
(setq newpvlist (mapcar
'(lambda (x)
(list (car (nth i phlist)) (car (cdr x))
(car (cddr x))
)
)
pvlist
)
)
(setq palllist (append
palllist
(list newpvlist)
)
)
(setq i (1+ i))
)
(setq column (length palllist))
(setq row (length (nth 0 palllist)))
(setq j 0)
(setq finallist nil)
(repeat (- row 1)
(setq i 0
rowlist nil
)
(repeat (- column 1)
(setq pa1 (nth j (nth i palllist)))
(setq pa2 (nth (1+ j) (nth i palllist)))
(setq pa3 (nth (1+ j) (nth (1+ i) palllist)))
(setq pa4 (nth j (nth (1+ i) palllist)))
(setq palist (list pa1 pa2 pa3 pa4))
(SETQ SS (SSGET "WP" palist))
(if (/= ss nil)
(progn
(SETQ EN (SSNAME SS 0))
(SETQ ED (ENTGET EN))
(setq ttext (cdr (assoc 1 ed)))
(setq rowlist (append
rowlist
(list ttext)
)
)
)
(setq rowlist (append
rowlist
(list " ")
)
)
)
(setq i (1+ i))
)
(setq finallist (append
finallist
(list rowlist)
)
)
(setq j (1+ j))
)
;;Now all the N horizontal and M vertical lines' intersecting points(N*M) are obtained
(setq outlist finallist)
;;The subrounine to tranfer text to excel
(2xl outlist)
)
;;; A subrountine from a Korea Friend for obtaining the intersection point of a line through 2 points with many other object
(defun vl-Get-Int-Pt (FirstPoint SecondPoint / acadDocument mSpace SSetName
SSets SSet reapp ex obj Baseline
)
(vl-load-com)
(setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq mSpace (vla-get-ModelSpace acadDocument))
(setq SSetName "MySSet")
(setq SSets (vla-get-SelectionSets acadDocument))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets
SSetName
)
)
)
(vla-clear (vla-Item SSets SSetName))
)
(setq SSet (vla-Item SSets SSetName))
(setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)
(vlax-3d-point SecondPoint)
)
)
(vla-SelectByPolygon SSet acSelectionSetFence
(kht:list->safearray (append
FirstPoint
SecondPoint
) 'vlax-vbdouble
)
)
(vlax-for obj sset (if (setq ex (kht-intersect
(vlax-vla-object->ename BaseLine)
(vlax-vla-object->ename obj)
)
)
(setq reapp (append
reapp
ex
)
)
)
)
(vla-delete BaseLine)
(setq reapp (vl-sort reapp '(lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
reapp
)
;;; My modify to omitting the text objects' intersection
(defun kht-intersect (en1 en2 / a b x ex ex-app c d e)
(vl-load-com)
(setq c (cdr (assoc 0 (entget en1)))
d (cdr (assoc 0 (entget en2)))
)
(if (or
(= c "TEXT")
(= d "TEXT")
)
(setq e -1)
)
(setq En1 (vlax-ename->vla-object En1))
(setq En2 (vlax-ename->vla-object En2))
(setq a (vla-intersectwith en1 en2 acExtendNone))
(setq a (vlax-variant-value a))
(setq b (vlax-safearray-get-u-bound a 1))
(if (= e -1)
(setq b e)
)
(if (/= b -1)
(progn
(setq a (vlax-safearray->list a))
(repeat (/ (length a) 3)
(setq ex-app (append
ex-app
(list (list (car a) (cadr a) (caddr a)))
)
)
(setq a (cdr (cdr (cdr a))))
)
ex-app
)
nil
)
)
(defun kht:list->safearray (lst datatype)
(vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0
(1-
(length lst)
)
)
) lst
)
)
;;; End of the Korea Friend's Subrountine
(defun TerminaExcel ()
(vlax-release-object *cells*)
(vlax-release-object *item*)
(vlax-release-object *workbooks*)
(vlax-release-object *Excel*)
)
(defun IniciaExcel (/ m)
(vl-load-com)
(setq m (vlax-get-or-create-object "excel.application"))
(if (= (vla-get-visible m) :Vlax-false)
(vla-put-visible (vlax-get-or-create-object "excel.application") T)
)
(setq *Excel* (vlax-get-or-create-object "excel.application"))
(if (= (vlax-get-property *Excel* "activeworkbook") nil)
(progn
(setq *workbooks* (vlax-get-property *Excel* "workbooks"))
(vlax-invoke-method *workbooks* "add")
(setq deltaRow nil)
)
)
(setq *workbooks* (vlax-get-property *Excel* "activeworkbook")
*item* (vlax-get-property *workbooks* "activesheet")
*cells* (vlax-get-property *item* "cells")
)
(if (= (vlax-get-object "Excel.Application") nil)
(progn
(vla-put-visible *Excel* T)
)
)
)
;; My subrounine to transfer the Table to excel
(defun 2xl (outlist / temp val cll rll cel ccel ccell curid curval curcell)
(IniciaExcel)
(setq list1 (conexcelcolumn))
(setq curRow 1)
(if (= deltaRow nil) (setq deltaRow 0))
(repeat (length outList)
(setq temp 1)
(repeat (length (nth 0 outlist))
(setq val (nth (1- temp) (nth (- curRow 1) outList)))
(setq cll (nth temp list1))
(setq rll (itoa (+ curRow deltaRow)))
(setq cel (strcat cll rll))
(setq curId (strcat (nth temp list1) (itoa (+ curRow deltaRow)))
curCell (vlax-variant-value (vlax-invoke-method *item* "Evaluate"
curId
)
)
curVal (nth (1- temp) (nth (- curRow 1) outList))
)
(vlax-put-property curCell "Formula" curVal)
(vlax-release-object curCell)
(setq temp (1+ temp))
)
(setq curRow (1+ curRow))
)
(setq deltaRow (+ deltaRow (- curRow 0)))
(TerminaExcel)
(princ)
)
;;;Subrouine to produce a list corresponding to the Excel's Column, For Example:A,B,...Z,AA,AB,....
(defun conexcelcolumn (/ a b list1)
(setq a 65)
(setq list1 nil)
(repeat 26
(setq list1 (append
list1
(list (chr a))
)
)
(setq a (1+ a))
)
(setq a 65)
(repeat 26
(setq b 65)
(repeat 26
(setq list1 (append
list1
(list (strcat (chr a) (chr b)))
)
)
(setq b (1+ b))
)
(setq a (1+ a))
)
list1
)
(prompt "\nCopyright (c) 2006 qjchen\n")
(prompt "Enter b2e to start.")
(princ)
|
