你能帮我提高我的英语水平吗
你好我制作了一个lisp，它通过创建一个块来创建快照，并删除不需要的元素。
他工作得很好，但我希望在任何情况下都能有所改进。
如果可能的话，添加一个进度条。
谢谢你的打扮。
(defun c:fdp (/ doc dictcoll dictlst mspcoll dictcoll contour ss lst ssall bbox file)
(vl-load-com)
;;;;;; create undo mark
(setq Doc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark Doc)
(vla-StartUndoMark Doc)
;;;;;; purge shx
(vl-load-com)
(vlax-for item
(vla-get-textstyles
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(if
(not
(vl-filename-extension (setq fname (vla-get-fontfile item)))
)
(setq fname (strcat fname ".shx"))
)
(cond ((findfile fname) nil)
((findfile (strcat (getenv "WINDIR") "\\FONTS\\" fname))
nil
)
(t
(vla-put-fontfile item "ltypeshp.shx")
)
)
)
;;;;;;;; clean up dict
(setq dictcoll (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for di dictcoll
(setq dictlst (cons (vl-catch-all-apply 'vla-get-name (list di)) dictlst))
)
(setq dictlst (reverse dictlst))
(princ dictlst)
(textscr)
(princ)
;;;;;; detach all xref
(vl-load-com)
(vl-cmdf "_.-xref" "D" "*")
(vl-cmdf "_.-image" "D" "*")
(setq mspcoll (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for ent mspcoll
(if
(or
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbDwfReference")
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbPdfReference")
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbDgnReference")
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbOle2Frame")
)
(vla-delete ent)
)
)
(setq dictcoll (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for di dictcoll
(if
(or
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_IMAGE_DICT")
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_PDFDEFINITIONS")
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_DGNDEFINITIONS")
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_DWFDEFINITIONS")
)
(progn
(vlax-for d di
(vla-delete d)
)
(vla-delete di)
)
)
)
;;;;;; purge all
(command "_purge" "_all" "*" "n")
;;;;;; zoom etendue
(command "zoom" "et")
;;;;;; create text of layer
(if
(and
(setq pt (getpoint "\nChoisr un point d'insertion "))
(setq pt (trans pt 1 0) i -1
sp (* 1.5 (getvar 'TEXTSIZE))
)
)
(while (setq df (tblnext "LAYER" (null df)))
(entmake
(list
(cons 0 "TEXT")
(cons 7 (getvar 'TEXTSTYLE))
(cons 8 (cdr (assoc 2 df)))
(cons 6 "ByLayer")
(cons 39 0.0)
(cons 62 256)
(cons 10 (setq p1 (polar pt (* 1.5 pi) (* (setq i (1+ i)) sp))))
(cons 40 (getvar 'TEXTSIZE))
(cons 1 (cdr (assoc 2 df)))
(cons 370 -1)
)
)
)
)
;;;;;; delete layers of your choice
(prompt "\nChoisir des objects pour supprimer les calques ")
(if (setq ssL (ssget))
(repeat (setq nL (sslength ssl))
(if (setq l_name (cdr (assoc 8 (entget (ssname ssL (setq nL (1- nL)))))))
(progn
(setq ssE (ssget "_X" (list (cons 8 l_name))))
(repeat (setq nE (sslength ssE))
(entdel (ssname ssE (setq nE (1- nE))))
)
)
)
)
)
;;;;;; zoom precedent
(command "zoom" "et")
;;;;;; erase text and mtext
(setq sstext (ssget "_X"'((0 . "TEXT,MTEXT,LEADER"))))
(command "_erase" sstext "")
;;;;;; make layer and set it current
(entmake
(list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 2 "FDP")
(cons 70 0)
(cons 62
))
(setvar "CLAYER" "FDP")
;;;;;; ortho activated
(setvar 'orthomode 1)
;;;;;; create a contour
(command "_pline"(while (> (getvar 'cmdactive) 0) (command pause)))
;;;;;; trim just you want
(setq contour (entlast))
(if
(wcmatch (cdr (assoc 0 (entget contour))) "*POLYLINE")
(progn
(setq bbox (ACET-ENT-GEOMEXTENTS contour))
(setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
(setq lst (ACET-GEOM-OBJECT-POINT-LIST contour 1e-3))
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list contour)))
(command "_.Zoom" "0.95x")
(if (null etrim)(load "extrim.lsp"))
(etrim contour (polar
(car bbox)
(angle (car bbox)(cadr bbox))
(* (distance (car bbox)(cadr bbox)) 1.1)))
(if (and
(setq ss (ssget "_CP" lst))
(setq ssall (ssget "_X" (list (assoc 410 (entget contour)))))
)
(progn
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach e1 lst (ssdel e1 ssall))
(ACET-SS-ENTDEL ssall)
)
)
)
)
;;;;;; layer merge
(vlax-for laylist
(vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object)))
(command "._laymrg" "N" (vla-get-Name laylist) "" "N" "FDP" "Y")
)
;;;;;; make block
(setq file (strcat (vl-filename-base (getvar 'DWGNAME)) "_X"))
(if (tblsearch "BLOCK" file)
(command "_.-block" (setq file (strcat file "X")) "0,0" "_All" "")
(command "_.-block" file "0,0" "_All" "")
)
(command "_.insert" file "_S" 1 "0,0" "")
;;;;;; rename block
(command "_.rename" "b" file "fdp")
;;;;;; nested block t 0
(if (setq sel (ssget "_X"'((0 . "INSERT"))))
(repeat (setq idx (sslength sel))
(block->0 (cdr (assoc 2 (entget (ssname sel (setq idx (1- idx)))))))
)
)
(command "_.regen")
;;;;;; end undo mark
(vla-EndUndoMark Doc)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun block->0 ( blk / ent enx )
(cond
( (member blk lst))
( (setq ent (tblobjname "block" blk))
(while (setq ent (entnext ent))
(entmod (subst-append 8 "0" (subst-append 62 256 (setq enx (entget ent)))))
(if (= "INSERT" (cdr (assoc 0 enx)))
(block->0 (cdr (assoc 2 enx)))
)
)
(setq lst (cons blk lst))
)
)
)
(defun subst-append ( key val lst / itm )
(if (setq itm (assoc key lst))
(subst (cons key val) itm lst)
(append lst (list (cons key val)))
)
) 进度条示例http://www.afralisp.net/dialog-control-language/tutorials/progress-bar.php
页:
[1]