求在多条多义线的两侧5个CAD单位的块参照“GCD”上写文字画圆的代码

清风明月10 · 发表于 2014-1-17 22:20:41

本帖最后由清风明月10 于 2014-1-18 10:30 编辑

求在多条多义线的两侧5个CAD单位的块参照“GCD”上写文字画圆的代码

我在地形图上布了很多剖切线。这张图是用名为“GCD”的块参照的插入点Z值来表达高程的。我希望在这些剖切线两侧5个单位内的每个GCD块参照的插入点上画一个圆（直径2个单位，在“000高程”图层上，圆的Z值为高程），还要写上一个单行文本，文本内容为高程，其Z值点亦为高程。我发上“求在多线两侧5米范围内的块参照GCD的插入点上画圆写文字.dwg”，代码可以在此处调试。要理解我上面话的意思，也可以参看此文件。

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:求在多线两侧5米范围内的块参照GCD的插入点上画圆写文字.rar
下载次数:13 文件大小:843.5 KB
下载权限: 不限以上 [免费赚D豆]

st788796 · 发表于 2014-1-17 22:20:42

清风明月10 发表于 2014-1-18 09:55
有始有终，完善一下，好吗？求你了！

(defun c:tt (/ ss s box tf)
(if (setq ss (ssget '((0 . "lwpolyline") (8 . "000剖切线"))))
(progn
(XD::Doc:DisableOsmode)
(setq box (xdrx_entity_box ss))
(if (apply 'xdrx_document_isPtOutScreen box)
(progn
(setq tf t)
(xdrx_document_zoomw (car box) (caddr box))
)
)
(XD::Begin)
(if (not (tblsearch "layer" "000高程"))
(xdrx_layer_make "000高程" 1)
)
(xdrx_setmark)
(mapcar
'(lambda (x / pl1 pl2 pts s)
(setq pl1 (xdrx_curve_offset x 5.)
pl2 (xdrx_curve_offset x -5.)
pts (append pl1 (reverse pl2))
)
(if (setq s (ssget "CP" pts '((2 . "GC200"))))
(progn
(mapcar '(lambda (a / p)
(setq p (xdrx_getpropertyvalue a "Position"))
(xdrx_circle_make p 1.)
(xdrx_text_make
p
(rtos (last p) 2 3)
8 ;_字高
(xdrx_getpropertyvalue a "Roatation")
)
)
(xdrx_pickset->ents s)
)
)
)
)
(xdrx_pickset->ents ss)
)
(if (setq s (xdrx_getss))
(xdrx_entity_setlayer
s
"000高程"
)
)
(if tf
(vl-cmdf ".zoom" "p")
)
(XD::End)
(XD::Doc:EnableOsMode)
)
)
(princ)
)

(defun c:tt (/ ss s box tf) 
  (if (setq ss (ssget '((0 . "lwpolyline") (8 . "000剖切线")))) 
    (progn 
      (XD::Doc:DisableOsmode) 
      (setq box (xdrx_entity_box ss)) 
      (if (apply 'xdrx_document_isPtOutScreen box) 
        (progn 
          (setq tf t) 
          (xdrx_document_zoomw (car box) (caddr box)) 
        ) 
      ) 
      (XD::Begin) 
      (if (not (tblsearch "layer" "000高程")) 
        (xdrx_layer_make "000高程" 1) 
      ) 
      (xdrx_setmark) 
      (mapcar 
        '(lambda (x / pl1 pl2 pts s) 
           (setq pl1 (xdrx_curve_offset x 5.) 
                 pl2 (xdrx_curve_offset x -5.) 
                 pts (append pl1 (reverse pl2)) 
           ) 
           (if (setq s (ssget "CP" pts '((2 . "GC200")))) 
             (progn 
               (mapcar '(lambda        (a / p) 
                          (setq p (xdrx_getpropertyvalue a "Position")) 
                          (xdrx_circle_make p 1.) 
                          (xdrx_text_make 
                            p 
                            (rtos (last p) 2 3) 
                            8 ;_字高 
                            (xdrx_getpropertyvalue a "Roatation") 
                          ) 
                        ) 
                       (xdrx_pickset->ents s) 
               ) 
             ) 
           ) 
         ) 
        (xdrx_pickset->ents ss) 
      ) 
      (if (setq s (xdrx_getss)) 
        (xdrx_entity_setlayer 
          s 
          "000高程" 
        ) 
      ) 
      (if tf 
        (vl-cmdf ".zoom" "p") 
      ) 
      (XD::End) 
      (XD::Doc:EnableOsMode) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2014-1-18 09:30:52

本帖最后由 st788796 于 2014-1-18 09:34 编辑

仅适用楼主样图

(defun c:tt (/ e pl1 pl2 pts ss s box)
(if (setq e (car (xdrx_entsel
"\nPick Pline: "
'((0 . "lwpolyline") (8 . "线路"))
)
)
)
(progn
(setq pl1 (xdrx_curve_offset e 5.)
pl2 (xdrx_curve_offset e -5.)
pts (append pl1 (reverse pl2))
box (xdrx_entity_box e)
)
(if (apply 'xdrx_document_isPtOutScreen box)
(xdrx_document_zoomw (car box) (caddr box))
)
(XD::Doc:DisableOsmode)
(if (setq ss (ssget "CP" pts '((2 . "GC200"))))
(progn
(XD::Begin)
(if (not (tblsearch "layer" "000高程"))
(xdrx_layer_make "000高程" 1)
)
(xdrx_setmark)
(mapcar '(lambda (x / p)
(setq p (xdrx_getpropertyvalue x "Position"))
(xdrx_circle_make p 1.)
(xdrx_text_make
p
(rtos (last p) 2 3)
8 ;_字高
(xdrx_getpropertyvalue x "Roatation")
)
)
(xdrx_pickset->ents ss)
)
(if (setq s (xdrx_getss))
(xdrx_entity_setlayer
s
"000高程"
)
)
(XD::End)
)
)
(XD::Doc:EnableOsMode)
)
)
(princ)
)

(defun c:tt (/ e pl1 pl2 pts ss s box) 
  (if (setq e (car (xdrx_entsel 
                     "\nPick Pline: " 
                     '((0 . "lwpolyline") (8 . "线路")) 
                   ) 
              ) 
      ) 
    (progn 
      (setq pl1        (xdrx_curve_offset e 5.) 
            pl2        (xdrx_curve_offset e -5.) 
            pts        (append pl1 (reverse pl2)) 
            box        (xdrx_entity_box e) 
      ) 
      (if (apply 'xdrx_document_isPtOutScreen box) 
        (xdrx_document_zoomw (car box) (caddr box)) 
      ) 
      (XD::Doc:DisableOsmode) 
      (if (setq ss (ssget "CP" pts '((2 . "GC200")))) 
        (progn 
          (XD::Begin) 
          (if (not (tblsearch "layer" "000高程")) 
            (xdrx_layer_make "000高程" 1) 
          ) 
          (xdrx_setmark) 
          (mapcar '(lambda (x / p) 
                     (setq p (xdrx_getpropertyvalue x "Position")) 
                     (xdrx_circle_make p 1.) 
                     (xdrx_text_make 
                       p 
                       (rtos (last p) 2 3) 
                       8 ;_字高 
                       (xdrx_getpropertyvalue x "Roatation") 
                     ) 
                   ) 
                  (xdrx_pickset->ents ss) 
          ) 
          (if (setq s (xdrx_getss)) 
            (xdrx_entity_setlayer 
              s 
              "000高程" 
            ) 
          ) 
          (XD::End) 
        ) 
      ) 
      (XD::Doc:EnableOsMode) 
    ) 
  ) 
  (princ) 
)

清风明月10 · 发表于 2014-1-18 09:48:02

st788796 发表于 2014-1-18 09:30
仅适用楼主样图

对不起，图发错了，可能是我修改后没有保存好的原故，发上去的不是我想要的图。是下面这张图。是多条剖切线同时处理。这些剖切线都位于“000剖切线”图层，反过来也成立，所有在“000剖切线”图层中的多线都是剖切线

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:求在多线两侧5米范围内的块参照GCD的插入点上画圆写文字(多条剖切线).rar
下载次数:4 文件大小:851.1 KB
下载权限: 不限以上 [免费赚D豆]

st788796 · 发表于 2014-1-18 09:50:49

清风明月10 发表于 2014-1-18 09:48
对不起，图发错了，可能是我修改后没有保存好的原故，发上去的不是我想要的图。是下面这张图。是多条剖切 ...

把过滤条件修改以下, 有单选了, 批量就是增加一层 mapcar xdrx_pickset->ents

清风明月10 · 发表于 2014-1-18 09:55:53

st788796 发表于 2014-1-18 09:50
把过滤条件修改以下, 有单选了, 批量就是增加一层 mapcar xdrx_pickset->ents

有始有终，完善一下，好吗？求你了！

清风明月10 · 发表于 2014-1-18 10:26:32

st788796 发表于 2014-1-18 10:02

我发现有三个问题：第1个问题是我没有说准确，就是剖切线不一定在“000剖切线”上，它由我点选的一根剖切线所在的图层决定;
第二个问题，可能是你没有用我的发的图去调试代码，因为代码实际是无法运行出结果的。
第三个问题，我希望不只是"lwpolyline"，而是“*line”,不知道能否成立？我的愿望是让剖切线可以容纳更多的线的种类

st788796 · 发表于 2014-1-18 10:33:30

清风明月10 发表于 2014-1-18 10:26
我发现有三个问题：第1个问题是我没有说准确，就是剖切线不一定在“000剖切线”上，它由我点选的一根剖切 ...

1 自己增加一个拾取获取图层步骤
2 你发的图绿线修改为 000剖切线
3 修改 ssget 过滤表

st788796 · 发表于 2014-1-18 10:41:07

(defun c:tt (/ e lyr ss s box tf)
(if (and (setq e (car (xdrx_entsel "\n拾取样本图层实体: ")))
(setq lyr (xdrx_getentdxf 8))
(setq ss (ssget (list '(0 . "*line") (cons 8 lyr))))
)
(progn
(XD::Doc:DisableOsmode)
(setq box (xdrx_entity_box ss))
(if (apply 'xdrx_document_isPtOutScreen box)
(progn
(setq tf t)
(xdrx_document_zoomw (car box) (caddr box))
)
)
(XD::Begin)
(if (not (tblsearch "layer" "000高程"))
(xdrx_layer_make "000高程" 1)
)
(xdrx_setmark)
(mapcar
'(lambda (x / pl1 pl2 pts s)
(setq pl1 (xdrx_curve_offset x 5.)
pl2 (xdrx_curve_offset x -5.)
pts (append pl1 (reverse pl2))
)
(if (setq s (ssget "CP" pts '((2 . "GC200"))))
(progn
(mapcar '(lambda (a / p)
(setq p (xdrx_getpropertyvalue a "Position"))
(xdrx_circle_make p 1.)
(xdrx_text_make
p
(rtos (last p) 2 3)
8 ;_字高
(xdrx_getpropertyvalue a "Roatation")
)
)
(xdrx_pickset->ents s)
)
)
)
)
(xdrx_pickset->ents ss)
)
(if (setq s (xdrx_getss))
(xdrx_entity_setlayer
s
"000高程"
)
)
(if tf
(vl-cmdf ".zoom" "p")
)
(XD::End)
(XD::Doc:EnableOsMode)
)
)
(princ)
)

(defun c:tt (/ e lyr ss s box tf) 
  (if (and (setq e (car (xdrx_entsel "\n拾取样本图层实体: "))) 
           (setq lyr (xdrx_getentdxf 8)) 
           (setq ss (ssget (list '(0 . "*line") (cons 8 lyr)))) 
      ) 
    (progn 
      (XD::Doc:DisableOsmode) 
      (setq box (xdrx_entity_box ss)) 
      (if (apply 'xdrx_document_isPtOutScreen box) 
        (progn 
          (setq tf t) 
          (xdrx_document_zoomw (car box) (caddr box)) 
        ) 
      ) 
      (XD::Begin) 
      (if (not (tblsearch "layer" "000高程")) 
        (xdrx_layer_make "000高程" 1) 
      ) 
      (xdrx_setmark) 
      (mapcar 
        '(lambda (x / pl1 pl2 pts s) 
           (setq pl1 (xdrx_curve_offset x 5.) 
                 pl2 (xdrx_curve_offset x -5.) 
                 pts (append pl1 (reverse pl2)) 
           ) 
           (if (setq s (ssget "CP" pts '((2 . "GC200")))) 
             (progn 
               (mapcar '(lambda        (a / p) 
                          (setq p (xdrx_getpropertyvalue a "Position")) 
                          (xdrx_circle_make p 1.) 
                          (xdrx_text_make 
                            p 
                            (rtos (last p) 2 3) 
                            8 ;_字高 
                            (xdrx_getpropertyvalue a "Roatation") 
                          ) 
                        ) 
                       (xdrx_pickset->ents s) 
               ) 
             ) 
           ) 
         ) 
        (xdrx_pickset->ents ss) 
      ) 
      (if (setq s (xdrx_getss)) 
        (xdrx_entity_setlayer 
          s 
          "000高程" 
        ) 
      ) 
      (if tf 
        (vl-cmdf ".zoom" "p") 
      ) 
      (XD::End) 
      (XD::Doc:EnableOsMode) 
    ) 
  ) 
  (princ) 
)

清风明月10 · 发表于 2014-1-18 11:04:14

st788796 发表于 2014-1-18 10:41

这9楼的代码有BUG，只能得到其中一条多线的结果，并没有对整个图层的线进行循环动作。

st788796 · 发表于 2014-1-18 11:08:48

清风明月10 发表于 2014-1-18 11:04
这9楼的代码有BUG，只能得到其中一条多线的结果，并没有对整个图层的线进行循环动作。

点选后要再次选择的，如果不要框选 ssge 后用 "x" 选项

清风明月10 · 发表于 2014-1-18 11:27:03

st788796，谢谢您！

快乐小子春天 · 发表于 2014-1-19 13:05:22

要是我会写这些，那该多好呢

账号		自动登录	找回密码
密码			立即注册

[已解决] 求在多条多义线的两侧5个CAD单位的块参照“GCD”上写文字画圆的代码

最佳答案

点评

点评

评分

点评

点评

点评

点评