Cad图块中线型比例修改

fzlinrong

屏录软件下载地址在哪？

ferious

软件名就是这个，之前下载的清理了。百度有很多资源的。

ferious

liuhe 发表于 2023-4-18 13:09
关于 entmod 函数所作的修改有一些限制：

不能改变一个图元的类型和句柄。如果一定要这样做，只能先调 ...

你好，首先非常遗憾，还是不灵，虽然没有报错！

提示输入线型比例，50.再选择块，然后炸开块，原来块内直线比例还是1？？？
能帮忙试下？
文件样板和动态效果见附件。
BEST  REGARDS!

huisguiji

谢谢分享，，，，，，，，，，，

liuhe

ferious 发表于 2023-4-18 19:52
你好，首先非常遗憾，还是不灵，虽然没有报错！

提示输入线型比例，50.再选择块，然后炸开块，原来块 ...

代码没有问题，问题是你没有看懂。我是根据你的代码增加了对(=  "DASHED"(vla-GEt-linetype obj ))，很显然你没有把它删掉，才导致没有修改

ferious

不谢，水平有限，暂时还没搞定cad块内线型比例修改。

ferious

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

你好，能不能帮忙调试好，成品源码发出来？

ferious

感谢河流之王支持，帮忙调试好，无私奉献源码如下。
可修改单个线型改为设置输入的线型比例
另外大家有需求的，可以找河流大神定制。专业且态度好

(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)

lxl217114

谢谢分享，点赞收藏。