单线变双线,保留原线为中心线

aggdqty · 发表于 2023-3-21 23:08

本帖最后由 aggdqty 于 2023-3-24 17:10 编辑

附件是论坛一位大神写的单线变双线的程序，麻烦帮修改一下，将原线变成中心线，线形为cnter,颜色为1，谢谢。

(defun c:Sx (/ getds0 obj)
(if (null vlax-dump-object) (vl-load-com) )
(SETVAR "CMDECHO" 0)
(or *getds* (setq *getds* 90))
(setq getds0 (getdist (strcat"\n输入宽度<"(rtos *getds* 2 3)">：")))
(if getds0 (setq *getds* getds0))
(while (setq obj (entsel))
(setq obj (vlax-ename->vla-object(car obj)))
(vla-offset obj (* 0.5 *getds*))
(vla-offset obj (* 0.5 *getds* -1))
)
(SETVAR "CMDECHO" 1)
(princ)
)

已调好，感谢各位

liuhe · 发表于 2023-3-22 08:50

(defun c:Sx (/ ACADOBJECT ACADDOCUMENT FOUND LINETYPESEL GETDS0 OBJ)
(setq AcadObject (vlax-get-acad-object)
　　AcadDocument (vla-get-ActiveDocument Acadobject)
)
(setq found :vlax-false)
(setq LinetypeSel (vla-get-Linetypes AcadDocument))　
(VLAX-FOR entry LinetypeSel　
(IF (= (VLA-GET-NAME ENTRY) "CENTER")
　　
(SETQ FOUND :VLAX-TRUE)
)
)
(IF (= FOUND :VLAX-FALSE) 　　
(VLA-LOAD LINETYPESEL "CENTER" "ACAD.LIN")
)
(if (null vlax-dump-object)
(vl-load-com)
)
(SETVAR "CMDECHO" 0)
(or *getds* (setq *getds* 90))
(setq
getds0 (getdist (strcat "\n输入宽度<" (rtos *getds* 2 3) ">："))
)
(if getds0
(setq *getds* getds0)
)
(while (setq obj (entsel))
(setq obj (vlax-ename->vla-object (car obj)))
(vla-offset obj (* 0.5 *getds*))
(vla-offset obj (* 0.5 *getds* -1))
(vla-put-color obj 1)
(vla-put-Linetype Obj "CENTER")
)
(SETVAR "CMDECHO" 1)
(princ)
)

(defun c:Sx (/ ACADOBJECT ACADDOCUMENT FOUND LINETYPESEL GETDS0 OBJ) 
  (setq        AcadObject         (vlax-get-acad-object) 
        　　AcadDocument (vla-get-ActiveDocument Acadobject) 
  ) 
  (setq found :vlax-false) 
  (setq LinetypeSel (vla-get-Linetypes AcadDocument))　 
  (VLAX-FOR entry LinetypeSel　 
    (IF        (= (VLA-GET-NAME ENTRY) "CENTER") 
      　　 
      (SETQ FOUND :VLAX-TRUE) 
    ) 
  ) 
  (IF (= FOUND :VLAX-FALSE)  　　 
    (VLA-LOAD LINETYPESEL "CENTER" "ACAD.LIN") 
  ) 
  (if (null vlax-dump-object) 
    (vl-load-com) 
  ) 
  (SETVAR "CMDECHO" 0) 
  (or *getds* (setq *getds* 90)) 
  (setq 
    getds0 (getdist (strcat "\n输入宽度<" (rtos *getds* 2 3) ">：")) 
  ) 
  (if getds0 
    (setq *getds* getds0) 
  ) 
  (while (setq obj (entsel)) 
    (setq obj (vlax-ename->vla-object (car obj))) 
    (vla-offset obj (* 0.5 *getds*)) 
    (vla-offset obj (* 0.5 *getds* -1)) 
    (vla-put-color obj 1) 
    (vla-put-Linetype Obj "CENTER") 
  ) 
  (SETVAR "CMDECHO" 1) 
  (princ) 
)

wzg356 · 发表于 2023-3-22 22:02

本帖最后由 wzg356 于 2023-3-22 22:05 编辑

(defun c:sx ( / e ps p)
(if(setq e(ssget ":E:S" '((0 . "*line"))))(progn
 (setq e(ssname e 0))
 (setq ps(outcurvept e))
 (setq d(if(setq d(getdist "\n输入偏移宽度<20>"))d 20))
 (setvar "cmdecho" 0)
 (vl-cmdf "mline" "j" "z" "ST" "STANDARD" "S" d)
 (foreach p ps (vl-cmdf "non" p))
 (vl-cmdf "")
 (vl-cmdf "change" e "" "p" "lt" "CENTER" "c" "1" "")
 (setvar "cmdecho" 1)
))(princ)
)

函数outcurvept在http://bbs.mjtd.com/thread-182691-1-1.html

aggdqty · 发表于 2023-3-24 13:23

wzg356 发表于 2023-3-22 22:02
(defun c:sx ( / e ps p)
(if(setq e(ssget ":E:S" '((0 . "*line"))))(progn
(setq e(ssname e ...

谢谢

vitalgg · 发表于 2023-3-22 09:16

本帖最后由 vitalgg 于 2023-3-22 09:20 编辑

https://www.bilibili.com/video/BV1Jv4y157X3/

源码：
https://gitee.com/atlisp/packages/blob/main/at-curve/at-curve.lsp
最底下那个函数。

aggdqty · 发表于 2023-3-22 09:22

liuhe 发表于 2023-3-22 08:50

谢谢。如果改变中心线的图层怎么设置

aggdqty · 发表于 2023-3-22 09:26

vitalgg 发表于 2023-3-22 09:16
https://www.bilibili.com/video/BV1Jv4y157X3/

谢谢，

Klein · 发表于 2023-3-22 14:48

liuhe 发表于 2023-3-22 08:50

16-18行的加载扩展库放在第二行是不是好一点啊，前面已经用到了vlax函数了，如果没加载可能会报错的吧

liuhe · 发表于 2023-3-22 15:08

Klein 发表于 2023-3-22 14:48
16-18行的加载扩展库放在第二行是不是好一点啊，前面已经用到了vlax函数了，如果没加载可能会报错的吧

我就随便复制了组合代码，没思考这么多

aggdqty · 发表于 2023-3-22 15:39

liuhe 发表于 2023-3-22 08:50

报语法错误

p-3-ianlcc · 发表于 2023-3-22 15:51

奇怪，我运行是正常的～没有报错误～

广易精通 · 发表于 2023-3-22 20:12

aggdqty 发表于 2023-3-22 09:22
谢谢。如果改变中心线的图层怎么设置

(vla-put-layer obj "DOTE")

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

单线变双线,保留原线为中心线

本帖子中包含更多资源

评分