明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 403|回复: 2

[提问] 求助,大侠帮我把"删除对象"的默认值改为"Yes"

[复制链接]
发表于 2021-12-5 09:17:27 | 显示全部楼层 |阅读模式
本菜鸟初学LISP,希望大侠出手帮忙我把"删除对象"的默认值改为"Yes",先谢谢了!  
下面代码是本论坛搜索的,如有冒犯,请多多关照!



;;;;;边界轮廓线
;;最后转成pline线

(defun C:bjlk (/       *error* blk     obj     MinPt   MaxPt   hiden
               pt      pl      unnamed_block   isRus   tmp_blk adoc
               blks    lays    lay     oname   sel     csp     loc
               sc      ec      ret     DS      osm     iNSpT
              )

   (defun *error* (msg)
     (princ msg)
     (mapcar '(lambda (x) (vla-put-visible x :vlax-true)) hiden)
     (vla-endundomark adoc)
     (if (and tmp_blk
              (not (vlax-erased-p tmp_blk))
              (vlax-write-enabled-p tmp_blk)
         ) ;_ end of and
       (vla-erase tmp_blk)
     ) ;_ end of if
     (if osm
       (setvar "OSMODE" osm)
     ) ;_ end of if
     (foreach x loc (vla-put-lock x :vlax-true))
   ) ;_ end of defun
   (vl-load-com)
   (setvar "CMDECHO" 0)
   (setq osm (getvar "OSMODE"))
   (if (zerop (getvar "WORLDUCS"))
     (progn (vl-cmdf "_.UCS" "") (vl-cmdf "_.Plan" ""))
   ) ;_ end of if
   (setq isRus (= (getvar "SysCodePage") "ANSI_1251"))
   (setq adoc (vla-get-activedocument (vlax-get-acad-object))
         blks (vla-get-blocks adoc)
         lays (vla-get-layers adoc)
   ) ;_ end of setq
   (vla-startundomark adoc)
   (if isRus
     (princ "\n选择做一个轮廓的对象")
     (princ "\n选择做一个轮廓的对象")
   ) ;_ end of if
   (vlax-for lay lays
     (if (= (vla-get-lock lay) :vlax-true)
       (progn (vla-put-lock lay :vlax-false)
              (setq loc (cons lay loc))
       ) ;_ end of progn
     ) ;_ end of if
   ) ;_ end of vlax-for
   (if (setq sel (ssget))
     (progn
       (setq sel (ssnamex sel))
;;;    (setq iNSpT(apply 'mapcar (cons 'min
;;;     (mapcar 'cadr (apply 'append (mapcar '(lambda(x)(vl-remove-if-not 'listp x)) sel))))))
       (setq iNSpT '(0 0 0))
       (setq sel (mapcar 'vlax-ename->vla-object
                         (vl-remove-if 'listp (mapcar 'cadr sel))
                 ) ;_ end of mapcar
       ) ;_ end of setq
       (setq csp (vla-objectidtoobject adoc (vla-get-ownerid (car sel))))
   ;;; (setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0. 0. 0.)) "*U"))
       (setq unnamed_block
              (vla-add (vla-get-blocks adoc)
                       (vlax-3d-point inspt)
                       "*U"
              ) ;_ end of vla-add
       ) ;_ end of setq
       (foreach x sel
         (setq oname (strcase (vla-get-objectname x)))
         (cond ((member oname
                        '("ACDBVIEWPORT"
                          "ACDBATTRIBUTEDEFINITION"
                          "ACDBMTEXT"
                          "ACDBTEXT"
                         )
                ) ;_ end of member
                nil
               )
               ((= oname "ACDBBLOCKREFERENCE")
                (vla-insertblock
                  unnamed_block
                  (vla-get-insertionpoint x)
                  (vla-get-name x)
                  (vla-get-xscalefactor x)
                  (vla-get-yscalefactor x)
                  (vla-get-zscalefactor x)
                  (vla-get-rotation x)
                ) ;_ end of vla-InsertBlock
                (setq blk (cons x blk))
               )
               (t (setq obj (cons x obj)))
         ) ;_ end of cond
       ) ;_foreach
       (setq lay (vla-item lays (getvar "CLAYER")))
       (if (= (vla-get-lock lay) :vlax-true)
         (progn (vla-put-lock lay :vlax-false)
                (setq loc (cons lay loc))
         ) ;_ end of progn
       ) ;_ end of if
       (if obj
         (progn (vla-copyobjects
                  (vla-get-activedocument (vlax-get-acad-object))
                  (vlax-make-variant
                    (vlax-safearray-fill
                      (vlax-make-safearray
                        vlax-vbobject
                        (cons 0 (1- (length obj)))
                      ) ;_ end of vlax-make-safearray
                      obj
                    ) ;_ end of vlax-safearray-fill
                  ) ;_ end of vlax-make-variant
                  unnamed_block
                ) ;_ end of vla-copyobjects
         ) ;_ end of progn
       ) ;_ end of if
       (setq obj (append obj blk))
       (if obj
         (progn
           (setq tmp_blk (vla-insertblock
                           csp
                           (vlax-3d-point inspt)
                           (vla-get-name unnamed_block)
                           1.0
                           1.0
                           1.0
                           0.0
                         ) ;_ end of vla-insertblock
           ) ;_ end of setq
           (vla-getboundingbox tmp_blk 'MinPt 'MaxPt)
           (setq MinPt (vlax-safearray->list MinPt)
                 MaxPt (vlax-safearray->list MaxPt)
                 DS    (max (distance MinPt (list (car MinPt) (cadr MaxPt)))
                            (distance MinPt (list (car MaxPt) (cadr MinPt)))
                       ) ;_ end of max
                 DS    (* 0.2 DS)                  ;1/5
                 DS    (max DS 10)
                 MinPt (mapcar '- MinPt (list DS DS))
                 MaxPt (mapcar '+ MaxPt (list DS DS))
           ) ;_ end of setq
           (lib:Zoom2Lst (list MinPt MaxPt))
           (setq sset (ssget "_C" MinPt MaxPt))
           (if sset
             (progn
               (setvar "OSMODE" 0)
               (setq hiden (mapcar 'vlax-ename->vla-object
                                   (vl-remove-if
                                     'listp
                                     (mapcar 'cadr (ssnamex sset))
                                   ) ;_ end of vl-remove-if
                           ) ;_ end of mapcar
                     hiden (vl-remove tmp_blk hiden)
               ) ;_ end of setq
               (mapcar '(lambda (x) (vla-put-visible x :vlax-false))
                       hiden
               ) ;_ end of mapcar
               (setq pt (mapcar '+ MinPt (list (* 0.5 DS) (* 0.5 DS))))
               (vl-cmdf "_.RECTANG" (trans MinPt 0 1) (trans MaxPt 0 1))
               (setq pl (vlax-ename->vla-object (entlast)))
               (setq sc (entlast))
               (if
                 (vl-catch-all-error-p
                   (vl-catch-all-apply
                     '(lambda ()
                        (vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
                        (while (> (getvar "CMDACTIVE") 0) (command ""))
                      ) ;_ end of lambda
                   ) ;_ end of VL-CATCH-ALL-APPLY
                 ) ;_ end of VL-CATCH-ALL-ERROR-P
                  (if isRus
                    (princ "\n这不是构造的轮廓")
                    (princ "\n这不是构造的轮廓")
                  ) ;_ end of if
               ) ;_ end of if
               (setq ec sc)
               (while (setq ec (entnext ec))
                 (setq ret (cons (vlax-ename->vla-object ec) ret))
                 )
                 (setq ret (vl-remove pl ret))
               (mapcar '(lambda (x) (vla-erase x) (vlax-release-object x))
                       (list pl tmp_blk)
               ) ;_ end of mapcar
               (setq pl nil
                     tmp_blk nil
               ) ;_ end of setq
               (setq
                 ret (mapcar '(lambda (x / mipt)
                                (vla-getboundingbox x 'MiPt nil)
                                (setq MiPt (vlax-safearray->list MiPt))
                                (list MiPt x)
                              ) ;_ end of lambda
                             ret
                     ) ;_ end of mapcar
               ) ;_ end of setq
               (setq ret (vl-sort ret
                                  '(lambda (e1 e2)
                                     (< (distance MinPt (car e1))
                                        (distance MinPt (car e2))
                                     ) ;_ end of <
                                   ) ;_ end of lambda
                         ) ;_ end of vl-sort
               ) ;_ end of setq
               (setq pl  (nth 1 ret)
                     ret (vl-remove pl ret)
               ) ;_ end of setq
               (mapcar 'vla-erase (mapcar 'cadr ret))
               (mapcar '(lambda (x) (vla-put-visible x :vlax-true))
                       hiden
               ) ;_ end of mapcar
               (foreach x loc (vla-put-lock x :vlax-true))
               (if pl
                 (progn
                   (initget "Yes No")
                   (if
                     (= (getkword (if isRus
                                    "\n删除对象? [Yes/No] <No> : "
                                    "\n删除对象? [Yes/No] <No> : "

                                  ) ;_ end of if
                        ) ;_ end of getkword
                        "Yes"
                     ) ;_ end of =
                      (mapcar '(lambda (x)
                                 (if (vlax-write-enabled-p x)
                                   (vla-erase x)
                                 ) ;_ end of if
                               ) ;_ end of lambda
                              obj
                      ) ;_ end of mapcar
                   ) ;_ end of if
                 ) ;_ end of progn
                 (if isRus
                   (princ "\n这不是构造的轮廓")
                   (princ "\n这不是构造的轮廓")
                 ) ;_ end of if
               ) ;_ end of if
             ) ;_ end of progn
           ) ;_ end of if
         ) ;_ end of progn
       ) ;_ end of if
       (vl-catch-all-apply
         '(lambda ()
            (mapcar 'vlax-release-object
                    (list unnamed_block tmp_blk csp blks lays)
            ) ;_ end of mapcar
          ) ;_ end of lambda
       ) ;_ end of VL-CATCH-ALL-APPLY
     ) ;_ end of progn
   ) ;_if not
   (foreach x loc (vla-put-lock x :vlax-true))
   (setvar "OSMODE" osm)
   (vla-endundomark adoc)
   (vlax-release-object adoc)
   (princ)
) ;_ end of defun
;;; ========== HELPER FUNCTION ==========================================
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
   (setq pt (trans pt 0 1))
   (setq VCTR  (getvar "VIEWCTR")
         Y_Len (getvar "VIEWSIZE")
         SSZ   (getvar "SCREENSIZE")
         X_Pix (car SSZ)
         Y_Pix (cadr SSZ)
         X_Len (* (/ X_Pix Y_Pix) Y_Len)
         Lc    (polar VCTR (dtr 180.0) (* 0.5 X_Len))
         Uc    (polar Lc 0.0 X_Len)
         Lc    (polar Lc (dtr 270.0) (* 0.5 Y_Len))
         Uc    (polar Uc (dtr 90.0) (* 0.5 Y_Len))
   ) ;_ end of setq
   (if (and (> (car pt) (car Lc))
            (< (car pt) (car Uc))
            (> (cadr pt) (cadr Lc))
            (< (cadr pt) (cadr Uc))
       ) ;_ end of and
     t
     nil
   ) ;_ end of if
) ;_ end of defun

(defun DTR (a) (* pi (/ a 180.0)))

(defun lib:pt_extents (vlist / tmp)

   (setq
     tmp (mapcar
           '(lambda (x) (vl-remove-if 'null x))
           (mapcar
             '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist))
             '(0 1 2)
           ) ;_ end of mapcar
         ) ;_ end of mapcar
   ) ;_setq

   (list (mapcar '(lambda (x) (apply 'min x)) tmp)
         (mapcar '(lambda (x) (apply 'max x)) tmp)
   ) ;_ end of list
) ;_defun

(defun lib:Zoom2Lst (vlist / bl tr Lst OS)

   (setq Lst (lib:pt_extents vlist)
         bl  (car Lst)
         tr  (cadr Lst)
   ) ;_ end of setq
   (if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr)))
     (progn (setq OS (getvar "OSMODE"))
            (setvar "OSMODE" 0)
            (command "_.Zoom"
                     "_Window"
                     (trans bl 0 1)
                     (trans tr 0 1)
                     "_.Zoom"
                     "0.95x"
            ) ;_ end of command
            (setvar "OSMODE" OS)
            t
     ) ;_ end of progn
     NIL
   ) ;_ end of if
) ;_ end of defun
发表于 2021-12-6 09:42:11 | 显示全部楼层
把下面几句:
(= (getkword (if isRus
                                                         "\n删除对象? [Yes/No] <No> : "
                                                         "\n删除对象? [Yes/No] <No> : "
                                                 ) ;_ end of if
         ) ;_ end of getkword
        "Yes"
)

变成这个试试:

(or
        (= (setq keyw (getkword (if isRus
                                                                                                                "\n删除对象? [Yes/No] <Yes> : "
                                                                                                                "\n删除对象? [Yes/No] <Yes> : "
                                                                                                        ) ;_ end of if
                                                                );_ end of getkword
                 )
                nil
        )
        (= keyw "Yes")
)
 楼主| 发表于 2021-12-6 11:18:06 | 显示全部楼层
谢谢大师傅,已经可以了.
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-15 07:15 , Processed in 0.173873 second(s), 24 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表