[弹指神通]：[弹指神通]：不打散图块 复制图块中的图元到图形中

yunzhong80

;复制图块中的图元到图形中(不打散图块)
;;; 执行命令：bcopy砤

(defun LispError (It / Count)
(princ (strcat "\n出错: " It "\n"))
(if (tblsearch "BLOCK" BlockName) (command "_.purge" "_b" BlockName "_y" "_y"))
(if LockLayer (command "_.-layer" "_lock" (getvar "clayer") ""))
(if Global
(repeat (setq Count (sslength Global))
  (setq Count (1- Count))
  (redraw (ssname Global Count) 4)
)
)
(if Global (command "_.erase" Global ""))
(command "_.undo" "_end")
(setq *error* Olderr)
(if OldVars
(mapcar 'setvar '("cmdecho" "highlight" "explmode") OldVars)
)
(princ)
);end LispError

(defun CreateObject (Val)
  (if (not LtName)
   (setq New (append New '((6 . "BYLAYER"))))
  )
  (if (not Color)
   (setq New (append New '((62 . 256))))
  )
(cond
(Val (entmake New)
      (setq LastObj (entlast))
)
(T (foreach Item (last Elem)
      (MakeBlock New (entget Item))
    )
)
)
);end CreateObject

(defun Makeblock (Obj Insert / Count)
(entmake (list  '(0 . "BLOCK") '(2 . "*U") '(70 . 1) '(10 0.0 0.0 0.0)))
(if (not LastObj)
(entmake Obj)
(entmake (entget LastObj))
);end if
(setq BlockName (entmake '((0 . "ENDBLK"))))
(entmake
(list  '(0 . "INSERT") (cons 2 BlockName) (cons 10 (dxf 10 Insert))
         (cons 50 (Dxf 50 Insert)) (cons 41 (dxf 41 Insert))
         (cons 42 (dxf 42 Insert)) (cons 43 (dxf 43 Insert))
)
)
(command "_.explode" (entlast))
(if(> (sslength (ssget "_P")) 1)
(command "_.pedit" (entlast) "_y" "_j" (ssget "_P") "" "")
)
(setq LastObj (entlast))
(command "_.purge" "_b" BlockName "_y" "_y")
);end Makeblock

(defun CopyElem (Old / New LtName Color)
(setq LtName (Dxf 6 (setq New (vl-remove (assoc 5 Old) Old)))
      Color (Dxf 62 New)
)

(if(= (Dxf 0 New) "ATTRIB") (setq New (At2Txt New)))
(cond
((= (length Elem) 2)
  (CreateObject T)
)
((not (FindPath)) (CreateObject nil))
(T (setq New (subst (cons 8 (getvar "clayer")) (assoc 8 New) New)
          ObjDbx (vla-getInterfaceObject (vlax-get-acad-object)
                 "ObjectDBX.AxDbDocument")
    )
    (vla-open ObjDbx (FindPath))
    (setq LayerDbx (VLAObj (TakeName (Dxf 8 Old)) (vla-get-layers ObjDbx)))
    (cond
     ((not LtName) (setq LtName (vla-get-linetype LayerDbx))
     )
     (T (setq LtName (TakeName LtName))
     )
    )
   (if (not Color) (setq New (append New (list (cons 62 (vla-get-color LayerDbx))))))
   (if (assoc 6 New)
    (setq New (subst (cons 6 LtName) (assoc 6 New) New))
    (setq New (append New (list (cons 6 LtName))))
   )
   (if (not (member (strcase LtName) (LtypeList)))
     (CopyLtype LtName)
   )      
    (foreach Item (last Elem)
            (MakeBlock New (entget Item))
    )
)
)

(if Global
(ssadd LastObj Global)
(setq Global (ssadd LastObj))
)
(redraw LastObj 3)
(setq  LastObj nil)
);end CopyElem

(defun TakeName (Name)
(if (wcmatch Name "*|*")
(cond
  ((= (substr Name 1 1) "|") (substr Name 2))
  (T (TakeName (substr Name 2)))
)
Name
)
);end TakeName

(defun LtypeList (/ Out)
(vlax-for Each (vla-get-linetypes (vla-get-ActiveDocument (vlax-get-acad-object)))
   (if (snvalid (vla-get-Name Each))
    (setq Out (cons (vla-get-Name Each) Out))
   )
)
  (mapcar 'strcase (acad_strlsort Out))
);end LtypeList


(defun VLAObj (Name Obj / Out)
(vlax-for Item Obj
   (if (= (strcase (vla-get-Name Item)) (strcase Name))
    (setq Out Item)
   )
)
Out
);end VLAObj


(defun CheckLockLayer (NLayer)
(equal 4
(logand 4
  (cdr (assoc 70
   (entget (tblobjname "layer" NLayer))
  )    )
)
)
);end CheckLockLayer

(defun Dxf (Index Value)
(cdr (assoc Index Value))
);end Dxf

(defun At2Txt (Atr / Obj)
(setq Obj '((0 . "TEXT")))
(foreach Item '(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11)
(if (assoc Item Atr)
  (setq Obj (cons (assoc Item Atr) Obj))
)
)
(setq Obj (subst (cons 73 (cdr (assoc 74 Atr))) (assoc 72 Obj) Obj))
(reverse Obj)
);end At2Txt

(defun FindPath (/ Objs Path)
(setq  Objs (last Elem))
(while (and Objs (not Path))
(setq Path
(cdr
  (assoc 1
   (tblsearch "BLOCK"
    (Dxf 2 (entget (car Objs)))
   )
  )
)
)
(setq Objs (cdr Objs))
);end while
(if (and Path (not (setq Path (findfile Path))))
(setq Path (findfile (strcat (vl-filename-base Path) ".dwg")))
)
Path
);end FindPath

(defun CopyLtype (Name)
(vla-CopyObjects
  ObjDbx
  (vlax-safearray-fill
   (vlax-make-safearray
     vlax-vbObject
     '(0 . 0)
   )
   (list (VLAObj Name (vla-get-linetypes ObjDbx)))
  )
  (vla-get-linetypes (vla-get-ActiveDocument (vlax-get-acad-object)))
)
);end CopyLtype

(defun c:bcopy (/ OldVars Olderr LockLayer Elem LastObj Global ObjDbx LayerDbx)
(vl-load-com)
(setq OldVars (mapcar 'getvar '("cmdecho" "highlight" "explmode")))
(mapcar 'setvar '("cmdecho" "highlight" "explmode") '(0 1 1))
(setq Olderr *error* *error* LispError)

(command "_.undo" "_be")

(if (setq LockLayer (CheckLockLayer (getvar "clayer")))
(command "_.-layer" "_unlock" (getvar "clayer") "")
)

(while (setq Elem (nentsel "\n选择图元: "))
(CopyElem (entget (car Elem)))
);end while

(if Global
(progn
(prompt "\n选择基点和位移: ")
(command "_.move" Global ""
  (while (not (zerop (getvar "cmdactive")))(command pause))
)
)
)
(if LockLayer (command "_.-layer" "_lock" (getvar "clayer") ""))
(command "_.undo" "_end")
(setq *error* Olderr)
(mapcar 'setvar '("cmdecho" "highlight" "explmode") OldVars)
(princ)
);end file
(prompt "\n完成。 ")
(princ)

zxmmelly

ET里面就有这个功能呀

狂刀

说是不打散，其实是在程序里面打散了：）