[求助]急急急，哪位高手帮帮忙看看这段程序，为何在CAD2008和2009中运行不了，在视

userzhl

[求助]急急急，哪位高手帮帮忙看看这段程序，为何在CAD2008和2009中运行不了，在视口内操作也会出错。[br]

急急急，哪位高手帮帮忙看看这段程序，为何在CAD2008和2009中运行不了，在视口内操作也会出错。

(defun NB_makeblock (sset baspoint   name          /
             blkobj    activespace          BlockDef
             blocks    sArray       idx          doc
             vla-objects       regen_flag errorsave
            )
  (setq errorsave *error*)
  (defun *error* (msg)
    (setq *error* errorsave)
  )
  (setq baspoint (trans baspoint 1 0))
  (setq    doc    (vla-get-activedocument (vlax-get-acad-object))
    blocks (vla-get-blocks doc)
  )
  (setq    activespace
     (cond ((= (vla-get-activespace doc) 1) (vla-get-modelspace doc))
           ((= (vla-get-activespace doc) 0) (vla-get-paperspace doc))
     )
  )
  (setq    vla-objects
     '()
    idx -1
    regen_flag
     nil
    self_ref nil
  )
  (repeat (sslength sset)
    (setq vla-objects
       (append vla-objects
           (list
             (vlax-ename->vla-object (ssname sset (setq idx (1+ idx))))
           )
       )
    )
  )
  (if (not (vl-catch-all-error-p
         (vl-catch-all-apply 'vla-item (list blocks name))
       )
      )
    (progn
      (initget 1 "Yes No")
      (if
    (= (getkword
         (strcat "\n" name "已定义。是否重定义？ (Yes or No) ")
       )
       "Yes"
    )
     (progn
       (if
         (apply
           'or
           (mapcar
         '(lambda (x)
            (and (= (vla-get-objectname x) "AcDbBlockReference")
             (= (vla-get-name x) name)
            )
          )
         vla-objects
           )
         )
          (progn (princ (strcat "\n" name "自参照。建块失败。"))
             (exit)
          )
       )
       (setq regen_flag T)
       (setq BlockDef (vla-item blocks name))
       (vlax-for itm BlockDef
         (vla-delete itm)
       )
     )
     (progn
       (princ "\n函数被取消")
       (exit)
     )
      )
    )
  )
  (foreach itm vla-objects
    (vla-move itm
          (vlax-3d-point baspoint)
          (vlax-3d-point '(0 0 0))
    )
  )
  (setq
    blkobj (vla-add blocks (vlax-3d-point '(0 0 0)) name)
    sArray
       (vlax-safearray-fill
         (vlax-make-safearray
           vlax-vbObject
           (cons 0 (1- (length vla-objects)))
         )
         vla-objects
       )
  )
  (vla-copyobjects doc sArray blkobj)
  (mapcar 'vla-delete vla-objects)
  (if regen_flag
    (vla-regen doc acAllViewports)
  )
  (setq *error* errorsave)
  (vla-insertblock
    activespace
    (vlax-3d-point baspoint)
    (vla-get-name blkobj)
    1
    1
    1
    0
  )
 ;;返回块名
 (CDR (ASSOC 2 (ENTGET (vlax-vla-object->ename blkobj))))
)

这是一个制作图块的功能，我觉得非常的好用。

急急急，哪位高手帮帮忙！！！

userzhl

哪位高手关注一下呀。

userzhl

版主，请关注一下呀。

caoyin

我在cad2009测试没问题

userzhl

在视口内操作不行！！！

userzhl

在视口内操作不行！！！

userzhl

这是一个“给定选择集创建块或者匿名块”的程序。

userzhl

(NB_makeblock <选择集> pt <"块名"> )

caoyin

问题出在这里

(setq    activespace
     (cond ((= (vla-get-activespace doc) 1) (vla-get-modelspace doc))
           ((= (vla-get-activespace doc) 0) (vla-get-paperspace doc))
     )
  )

改为

  (if (and (= (vla-get-activespace doc) 0)
           (= (getvar "cvport") 2))
    (setq activespace (vla-get-paperspace doc))
    (setq activespace (vla-get-modelspace doc))
  )

userzhl

非常感谢caoyin！！！