论坛 › 每日插件 › 文字加下划线（同时转换成属性块）和 下划线更新 插件

Lispboy 发表于 2018-9-12 01:17:08

文字加下划线（同时转换成属性块）和 下划线更新 插件

**** Hidden Message *****

下划线更新：




(defun c:xdtb_textulineupd (/ atts insert box mat xdir ydir p1 p2 p3 p4 p5 p6 dist h el blks)
(defun _update (blk)
    (setq insert (ssname (ssget "x" (list (cons 2 blk))) 0)
          atts       (xdrx_getpropertyvalue insert "attributeentities")
          box       (xdrx_entity_box atts (cadr (xdrx_entity_getecs insert)))
          mat       (xdrx_matrix_block2wcs insert)
          mat       (xdrx_matrix_inverse mat)
          box       (xdrx_points_transform box mat)
          xdir       '(1 0 0)
          ydir       '(0 1 0)
          p1       (car box)
          p2       (cadr box)
          dist       (distance p1 p2)
          p1       (mapcar '+ p1 (xdrx_vector_product xdir (- (* #ext dist))))
          p2       (mapcar '+ p2 (xdrx_vector_product xdir (* #ext dist)))
          h       (distance (car box) (last box))
          p3       (mapcar '+ p1 (xdrx_vector_product ydir (- (* 0.3333 h))))
          p4       (mapcar '+ p2 (xdrx_vector_product ydir (- (* 0.3333 h))))
          p5       (mapcar '+
                       p3
                       (xdrx_vector_product
                           ydir
                           (- (setq wid (xd::var:getdrawratio)))
                       )
               )
          p6       (mapcar '+ p4 (xdrx_vector_product ydir (- wid)))
    )
    (xdrx_entity_delete ents)
    (setq el (xdrx_block_getentities blk '((0 . "*polyline"))))
    (xdrx_setpropertyvalue
      (car el)
      "setpointat"
      (list 0 p3)
      "setpointat"
      (list 1 p4)
    )
    (xdrx_setpropertyvalue
      (cadr el)
      "setpointat"
      (list 0 p5)
      "setpointat"
      (list 1 p6)
    )
)
(if (setq ss (ssget "x"
                      (list '(0 . "INSERT") (cons 2 "xd_text_xiahua_*"))
             )
      )
    (progn (setq blks (xdrx_entity_getproperty ss "blocktablerecord")
               blks (xd::list:groupbyindex (mapcar 'car blks) 0)
           )
           (mapcar '(lambda (x) (_update (car x))) blks)
    )
)
(princ)
)

liuyj 发表于 2018-9-12 02:17:32

更新这个功能不错

renyonghua2014 发表于 2018-9-12 03:02:13

看看楼主的程序，谢谢提供。

longer88 发表于 2018-9-12 08:41:36

不错，很有用处

spp_wall 发表于 2018-9-12 08:41:50

每日插件 每日新鲜！！！！！！！

cfc123456 发表于 2018-9-12 08:44:26

每日新鲜，每天更新！

Come_ezIzp 发表于 2018-9-12 08:49:43

这个很强大~

searinon 发表于 2018-9-12 09:47:20

可以，相当完美。

lw5297590 发表于 2018-9-12 14:06:18

看看楼主的程序，谢谢提供。

knife0930 发表于 2018-9-12 17:01:47

看看楼主的程序，谢谢提供。

Michael527 发表于 2018-9-13 06:46:36

非常实用的功能，谢谢

86533045 发表于 2018-10-11 01:10:34

谢谢分享。

changqmtt 发表于 2018-10-30 08:37:13

一直在找下划线的插件，谢谢了

wacy1902 发表于 2018-10-30 13:44:38

非常实用的功能，谢谢

hf423 发表于 2018-11-30 12:15:49

用了反应器吧？

查看完整版本: 文字加下划线（同时转换成属性块）和 下划线更新 插件