Cad图块中线型比例修改

ferious · 发表于 2023-4-17 20:20:35

对图块进行操作时，在不炸开图块的情况下，如何修改图块内子图元的线型比例？；比如说：我在CAD图中插入一已经做好的图块，但由于绘图设置原因，在有的图中此图块中虚线比例太小，几乎看不清楚，想再编写一程序能修改图块中子图元的线型比例。就不知如何下手，折磨我好几天了？

谢谢你的帮助，从明经这几天的学习中，我自已慢慢摸索出如下方法，测试后能满足我工作的需要，但不知我这样编写的思路是不是太繁锁，希望论坛里的哪位大侠帮我再优化一下。万分感谢
(defun c:xg (/ ss sslen sname snlast n tk tl)
  (vl-load-com)
  (setq old_cm (getvar "cmdecho"))
  (setq old_os (getvar "osmode"))
  (setq old_bl (getvar "blipmode"))
  (setvar "cmdecho" 0)
  (setvar "osmode" 39)
  (setvar "blipmode" 0)
  (prompt "\n请选择要修改的图块...")
  (setq ss (ssget  (list '(0 . "INSERT"))))
  (if (null ss)
(alert "\n没有选中任何要修改的图块...")
(progn
   (repeat (setq sslen (sslength ss))
      (setq sname (ssname ss (setq sslen (1- sslen))))
      (setq
      snlast (tblobjname "Block" (cdr (assoc 2 (entget sname))))
      )
      (while
      (/= (cdr (assoc 6 (entget (setq snlast (entnext snlast)))))
            "DASHED"
      )
      )
      (setq n (getdist "\n请输入要修改的线型比例"))
      (setq
      tk (vla-put-linetypescale (vlax-ename->vla-object snlast) n)
      )
      (setq tl (vla-put-color (vlax-ename->vla-object snlast) 40))
      (entmod (entget sname))
      (redraw sname 1)
   )
)
  )
  (setvar "cmdecho" old_cm)
  (setvar "osmode" old_os)
  (setvar "blipmode" old_bl)
  (princ)
)

为何总是报错？有大神能帮忙完善了此贴？

ferious · 发表于 2023-4-20 14:01:22

感谢河流之王支持，帮忙调试好，无私奉献源码如下。

可修改单个线型改为设置输入的线型比例

另外大家有需求的，可以找河流大神定制。专业且态度好

(defun c:lts (/ lts:processed idx scl sel LINENAME)
 (initget 6)
 (if (not scl2)
(setq scl2 20)
 )
 (if (NOT (setq scl
 (getreal (STRCAT "\n 请输入线性型比例<" (rtos scl2 2 0) ">")
 )
 )
 )
(SETQ SCL SCL2)
(SETQ SCL2 SCL)
 )
 (PRINC "\n 选择源线型和修改图形")
 (if (setq sel (ssget))
(PROGN
 (repeat (setq idx (sslength sel))
(SETQ E (ssname sel (setq idx (1- idx))))
(IF (/= "INSERT" (CDR (ASSOC 0 (ENTGET E))))
 (PROGN
 (SETQ LINENAME
 (vl-catch-all-apply
 'vla-GEt-linetype
 (LIST (vlax-ename->vla-object E))
 )
 )
 (IF (= LINENAME "ByLayer")
 (SETQ LINENAME
 (CDR (ASSOC
 6
 (tblsearch "LAYER"
 (CDR (ASSOC 8 (ENTGET E)))
 )
 )
 )
 )
 )
 )
)
 )
 (repeat (setq idx (sslength sel))
(lts:obj
 (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
 scl
 LINENAME
)
 )
)
 )
 (vla-regen lts:acdoc acallviewports)
 (princ)
)
(defun lts:blk (obj scl / bln)
 (if (not (member (setq bln (vla-get-name obj)) lts:processed))
(progn
 (vlax-map-collection
(vla-item lts:acblk bln)
'(lambda (obj) (lts:obj obj scl LINENAME))
 )
 (setq lts:processed (cons bln lts:processed))
)
 )
)
(defun lts:obj (obj scl LINENAME / LINENAME1)
 (IF (= (vla-GEt-linetype obj) "ByLayer")
(SETQ LINENAME1
 (CDR
 (ASSOC
 6
 (tblsearch "LAYER"
 (CDR (ASSOC 8 (ENTGET (vlax-vla-object->ename obj))))
 )
 )
 )
)
(SETQ LINENAME1 (vla-GEt-linetype obj))
 )
 (if (and (vlax-write-enabled-p obj)
 (vlax-property-available-p obj 'linetypescale t)
 (= LINENAME LINENAME1)
 )

(vla-put-linetypescale obj scl)
 )
 (if (= "AcDbBlockReference" (vla-get-objectname obj))
(lts:blk obj scl)
 )
)
(setq lts:acdoc (vla-get-activedocument (vlax-get-acad-object))
 lts:acblk (vla-get-blocks lts:acdoc)
)
(vl-load-com)
(princ)

liuhe · 发表于 2023-4-18 13:09:38

本帖最后由 liuhe 于 2023-4-18 13:31 编辑

(defun c:lts ( / lts:processed idx scl sel )
(initget 6)
(if (setq scl (getreal "\n 请输入线性型比例"))
(if (setq sel (ssget "_:L"))
(repeat (setq idx (sslength sel))
(lts:obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) scl)
)
)
)
(vla-regen lts:acdoc acallviewports)
(princ)
)
(defun lts:blk ( obj scl / bln )
(if (not (member (setq bln (vla-get-name obj)) lts:processed))
(progn
(vlax-map-collection (vla-item lts:acblk bln) '(lambda ( obj ) (lts:obj obj scl)))
(setq lts:processed (cons bln lts:processed))
)
)
)
(defun lts:obj ( obj scl )
(if (and (vlax-write-enabled-p obj) (vlax-property-available-p obj 'linetypescale t)(= "DASHED"(vla-GEt-linetype obj )));;;;只更改"DASHED"的
(vla-put-linetypescale obj scl)
)
(if (= "AcDbBlockReference" (vla-get-objectname obj))
(lts:blk obj scl)
)
)
(setq lts:acdoc (vla-get-activedocument (vlax-get-acad-object))
lts:acblk (vla-get-blocks lts:acdoc)
)
(vl-load-com) (princ)
;;;;代码来至于LeeMac

(defun c:lts ( / lts:processed idx scl sel ) 
    (initget 6) 
    (if (setq scl (getreal "\n 请输入线性型比例")) 
        (if (setq sel (ssget "_:L")) 
            (repeat (setq idx (sslength sel)) 
                (lts:obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) scl) 
            ) 
        ) 
    ) 
    (vla-regen lts:acdoc acallviewports) 
    (princ) 
) 
(defun lts:blk ( obj scl / bln ) 
    (if (not (member (setq bln (vla-get-name obj)) lts:processed)) 
        (progn 
            (vlax-map-collection (vla-item lts:acblk bln) '(lambda ( obj ) (lts:obj obj scl))) 
            (setq lts:processed (cons bln lts:processed)) 
        ) 
    ) 
) 
(defun lts:obj ( obj scl ) 
    (if (and (vlax-write-enabled-p obj) (vlax-property-available-p obj 'linetypescale t)(=  "DASHED"(vla-GEt-linetype obj )));;;;只更改"DASHED"的 
        (vla-put-linetypescale obj scl) 
    ) 
    (if (= "AcDbBlockReference" (vla-get-objectname obj)) 
        (lts:blk obj scl) 
    ) 
) 
(setq lts:acdoc (vla-get-activedocument (vlax-get-acad-object)) 
      lts:acblk (vla-get-blocks lts:acdoc) 
) 
(vl-load-com) (princ) 
;;;;代码来至于LeeMac

关于 entmod 函数所作的修改有一些限制：

不能改变一个图元的类型和句柄。如果一定要这样做，只能先调用 entdel 函数删除它，然后调用 command 或 entmake 函数创建新图元。
entmod 函数不能修改内部域，如 SEQEND 图元的 -2 组中的图元名，如果试图作这样的修改，将会被系统忽略。
不能使用 entmod 函数修改视口图元。
可以将图元的空间可见性改为 0 或 1（视口对象除外）。如果用 entmod 函数修改了块定义中的图元，该修改会影响图形中该块的所有实例。

在用 entmod 函数修改顶点图元前，应先读出或写入多段线的头部。如果最近处理的多段线图元不是该顶点所在的多段线，可能会丢失宽度信息（40 和 41 组）。

警告！可以用 entmod 函数修改块定义中的图元，但这样做可能会生成引用自身的块，导致 AutoCAD 系统崩溃。

(vla-Update lineObj)

ferious · 发表于 2023-4-18 16:52:23

加班画图敲码必备解压经典世界名曲，自提不谢file:///C:\Users\Administrator\AppData\Roaming\Tencent\QQTempSys\G@YVKCPZR)X}3UKB(_VF`LW.gif
链接：file:///C:\Users\Administrator\AppData\Roaming\Tencent\QQTempSys\%W@GJ$ACOF(TYDYECOKVDYB.pnghttps://pan.baidu.com/s/1sABJ7kVlrzfVNOAo4XENBA
提取码：1111

kucha007 · 发表于 2023-4-17 21:16:47

要学会自己搜索啊= =http://bbs.mjtd.com/thread-186469-1-1.html

ferious · 发表于 2023-4-17 21:44:21

kucha007 发表于 2023-4-17 21:16
要学会自己搜索啊= =http://bbs.mjtd.com/thread-186469-1-1.html

连接中LEE的源码复制，运行不了呢

ferious · 发表于 2023-4-17 21:45:30

你的是修改过的吗？运行什么效果？没有GIF？

ferious · 发表于 2023-4-17 21:47:59

是这个效果吗

ferious · 发表于 2023-4-17 21:52:40

是这样吗？

liuhe · 发表于 2023-4-18 13:33:46

你的while 循环是没用的，你直接屏蔽掉就不报错了

ferious · 发表于 2023-4-18 16:54:55

各位有幸到访者，请查看录制动态gif教程，方便注明插件功能！

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

Cad图块中线型比例修改

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源