社区 › AutoLISP/Visual LISP 编程技术 › 快速建块的问题 知道的进

xman00 发表于 2012-10-14 22:04:06

快速建块的问题 知道的进

本版关于快速建块的贴已有一些，其插入点多为原点或手动指定点。
现求一LSP，达到快速建块的功能，插入点自动获取为选择集中心点，块名为时间点。

因本人道行太浅，不懂啊。仅提供一点思路供大神思考：

此处最难应为获取选择集中心点，赋值为插入点坐标。本人思路为先根据选择集确定其最小包围盒，再根据包围盒计算其中心坐标(块插入点坐标）。

附上本版找到的最小包围盒的LSP，本人机器上测试有缺陷，不能运行，需先行修正或检查（未知是否CAD版本影响，本人08）。

PS：为减小运行错误，及考虑实用价格，先择集对象可考虑过滤放射线及构造线（错误处理）。

大神们努力啊，此LSP应为广大实际应用。本人静待佳音。

langjs 发表于 2013-9-30 11:08:43

试试这个，以前编的，觉得还算方便

(defun c:qk (/ i maxpoint maxx maxx0 maxy maxy0 minpoint minx minx0 miny miny0 name pmax pmin pt ss)
(vl-load-com)
(setvar "cmdecho" 0)
(setq ss (ssget))
(if ss
    (progn
      (command ".undo" "be")
      (setq pt (getpoint "\n指定块插入基点:<中心>"))
      (if (= pt nil)
        (progn
          (setq minx0 1e6miny0 1e6 maxx0 -1e6maxy0 -1e6 )
          (repeat (setq i (sslength ss))
          (setq name (ssname ss (setq i (1- i))))
          (vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
          (setq pmax (vlax-safearray->list maxpoint)pmin (vlax-safearray->list minpoint))
          (setq minx (car pmin)maxx (car pmax)miny (cadr pmin)maxy (cadr pmax))
          (if (> minx0 minx) (setq minx0 minx))
          (if (> miny0 miny) (setq miny0 miny))
          (if (< maxx0 maxx) (setq maxx0 maxx))
          (if (< maxy0 maxy) (setq maxy0 maxy) )
          )
          (setq pt (list (/ (+ minx0 maxx0) 2) (/ (+ miny0 maxy0) 2) 0.0))
        )
      )
      (setq snap (getvar "osmode"))
      (setvar "osmode" 0)
      (setq name (substr (rtos (getvar "CDATE") 2 8) 10 17))
      (command "block" name pt ss "")
      (command "INSERT" name pt 1 1 0)
      (princ (strcat "\n已新建块名为 \"" name "\" 的图块"))
      (setvar "osmode" snap)
      (command ".undo" "e")
    )
)
(princ)
)

namezg 发表于 2012-10-16 20:32:36

本帖最后由 namezg 于 2012-10-17 20:49 编辑

按你的要求写了一个。
;快速创建块
;块名为当前时间(如"2012101620161699"),块基点为选择集中心点
;命令：ZG_MakeBlock

USER2128 发表于 2013-9-30 07:57:41

本帖最后由 USER2128 于 2013-9-30 08:01 编辑

zhengxq7 发表于 2013-9-29 17:35 static/image/common/back.gif
楼上的程序很好，我很需要，但是程序在输入快名的时候出错。能不能整理一下，干脆取消输入快名行了，只要自 ...
;;;________________________________________________________________
;;; 将所选实体转为块（指定插入点），并自动赋名（优化版）。
;;; 作者: USER2128于bbs.mjtd.com, 20130930
(defun c:BB (/ pt ss ent name)
(if (and (setq pt (getpoint "\n请指定将要制成的块的插入点："))
         (princ "\n请选取要制成块的那些实体：")
         (setq ss (ssget))
         )
    (progn
      (command "._copybase" "_non" pt ss "")
      (command "._PASTEBLOCK" "_non" pt)
      (command "._erase" ss "")
      (setq ent (entget (entlast))
            name (cdr (assoc 2 ent))
            )
      (princ "\n制块成功！块名＝") (princ name)
      )
      
    (princ "\n未指定插入点或未选取实体!")
    )
(princ))
;;;________________________________________________________________

namezg 发表于 2012-10-15 20:39:07

本帖最后由 namezg 于 2012-10-16 13:56 编辑

;功能：返回选择集包围盒
;参数: ss--选择集
;返回值：选择集所有实体做为整体的包围盒
;(setq ssbox (GetSSBoundingbox (setq ss (ssget))))
(defun GetSSBoundingbox (ss / i ssn ll rr box ptlist ssbox)
      (if ss
                (progn
                        (setq i -1)
                        (repeat (sslength ss)
                              (setq ssn (ssname ss (setq i (1+ i))))
                              (vla-GetBoundingBox (vlax-ename->vla-object ssn) 'll 'rr);得到对象的包围盒
                              (setq box (list (vlax-safearray->list ll) (vlax-safearray->list rr)))
                              (setq ptlist (append box ptlist))
                        )
                        (setq ssbox (mapcar '(lambda (x) (apply 'mapcar (cons x ptlist))) (list 'min 'max)))
                )
      )
)
中心点
(setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2)) (car ssbox) (cadr ssbox)))
或
(setq midpt (apply 'mapcar (cons (function (lambda (a b) (/ (+ a b) 2))) ssbox)))

liu_kunlun 发表于 2012-10-14 22:36:27

在0，0，0处建块及insert实体，取得其大小尺寸，再修改其定义点或重新建块

xman00 发表于 2012-10-14 22:40:17

请楼上写出代码，本人对此不通啊。求助

清风明月名字 发表于 2012-10-15 08:42:14

这个代码是很有价值，可惜我也不懂

myjping 发表于 2012-10-15 08:59:45

我的快速建块，空击即是

xman00 发表于 2012-10-15 12:23:24

myjping 发表于 2012-10-15 08:59 static/image/common/back.gif
我的快速建块，空击即是

老兄，这个重点是块差入点的位置哈

xman00 发表于 2012-10-15 19:24:18

xman00 发表于 2012-10-15 12:23 static/image/common/back.gif
老兄，这个重点是块差入点的位置哈

老兄，整个源码上来啊，版内给你发信息没反应的哇

xman00 发表于 2012-10-15 22:21:12

本帖最后由 xman00 于 2012-10-15 22:22 编辑

namezg 发表于 2012-10-15 20:39 static/image/common/back.gif
;功能：返回选择集包围盒
;参数: ss--选择集
;返回值：选择集所有实体做为整体的包围盒

老兄，我是不懂LSP的，拜托就写出来嘛，要求更改了一点点，就是块插入选择集下沿中心点，这里好像算法要稍变动一下。

USER2128 发表于 2012-10-16 09:12:31

;;;________________________________________________________________
;;; 将所选实体转为块（指定插入点），并自动赋名（可改名）。
(defun c:bb (/ osmode cmdecho pt ss ent name txt)
(setq osmode(getvar "osmode")
        cmdecho (getvar "cmdecho")
        )
(if (and (setq pt (getpoint "\n请指定将要制成的块的插入点："))
           (princ "\n请选取要制成块的那些实体：")
           (setq ss (ssget))
           )
    (progn
      (setvar "osmode" 0)
      (setvar "cmdecho" 0)
      (command "._copybase"pt ss "")
      (command "._PASTEBLOCK" pt)
      (command "._erase" ss "")
      (setq ent (entget (entlast))
          name (cdr (assoc 2 ent))
          )
      (setq txt "请输入块名或接受原块名:")
      (while txt
        (setq txt (dos_getstring "输入块名" txt name))
        (if (and txt (/= (strcase name) (strcase txt)))
          (if (not (tblsearch "BLOCK" txt))
          (progn
              (command "._rename" "_block" name txt)
              (setq name txt
                  txtnil)
              )
          (setq txt "与图中的已有的块名重名，请重输块名：")
          )
          (setq txt nil)
          ))
      (setvar "cmdecho" cmdecho)
      (setvar "osmode"osmode)
      (princ "\n制块成功！块名＝") (princ name)
      )
    (princ "\n未指定插入点或未选取实体!")
    )
(princ))
;;;________________________________________________________________

查看完整版本: 快速建块的问题 知道的进