单线变双线能不能改成这样

wjnnan · 发表于 2014-7-5 22:48:46

本帖最后由 wjnnan 于 2014-7-20 20:33 编辑

这是论坛里以为兄弟的单线改双线的源码

;**********************************单线变双*************************
(defun c:bs (/ oldlayer dis o)
 (prompt "***单线变双线***")
 (command "undo" "be")
 (setq oldlayer (getvar "CLAYER"))
 (setvar "cmdecho" 0)
 (command "-layer" "M" "管径" "" "Color" 2 "" "l" "continous" "" "")
(setq dis (getreal "\n输入双线间的距离:"))
 (setq o 1)
 (while o
(setq o nil)
(setq o (entsel "\n选择要变双的线条< (右键退出)"))
(command "offset" (/ dis 2) o '(-9999999 -9999999) "")
(command "change" (ssget "l") "" "p" "la" "管径" "")
(command "offset" (/ dis 2) o '(9999999 9999999) "")
(command "change" (ssget "l") "" "p" "la" "管径" "")
(command "erase" o "")
 )
 (setvar "CLAYER" oldlayer)
 (command "undo" "e")
)

能不能改成这样，人工输入一条虚线（并自动归入自定义的图层1），以这条虚线为基准，再给出双线间的距离,形成的实线线型的pline线，线宽w 为30，（并归入自定义的图层2），完成以上操作后，以输入的虚线中点放大1.5倍，本人基础太差，现在还不能独立修改，那位帮帮忙，给改一下

具体见下图

李青松 · 发表于 2014-7-23 17:08:48

要是能改成批量修改双线就很好了。

xyp1964 · 发表于 2014-7-23 19:24:22

wjnnan · 发表于 2014-7-24 08:15:46

xyp1964 发表于 2014-7-23 19:24

院长大人程序一贯很好，能不能这样改一下，使用普通 lisp 函数编写，我的机器没有您的工具箱，贱人工具箱我的机器也用不了，另外虚线除了能选取外，最好再加上能人工输入，谢谢

love1030312 · 发表于 2014-7-24 09:16:42

院长的都是好程序好程序当然要好的底裤了哈哈

Bellahx · 发表于 2014-7-24 16:26:10

在楼主的要求下做了点修改，没能把生成的线变成pline线。对pline的命令不是很了解，有相关文章希望推荐一下下~ 多多指教

(defun c:bs (/ oldlayer o)
(prompt "***单线变双线***")
(command "undo" "be")
(setq oldlayer (getvar "CLAYER"))
(setvar "cmdecho" 0)
(if (not (tblobjname "ltype" "Dashed"))
(command "linetype" "l" "dashed" "" "")
)
(if (not (tblsearch "layer" "图层1"))
(command "layer" "n" "图层1" "c" "2" "图层1" "")
)
(command "layer" "l" "dashed" "图层1" "")
(if (not (tblsearch "layer" "管径"))
(command "layer" "n" "管径" "c" "2" "管径" "")
)
(command "layer" "l" "Continuous" "管径" "")
(command "layer" "lw" "30" "管径" "")
(if dis
(setq dis dis)
(setq dis 1)
)
(prompt "\n请输入双线间的距离<") (princ dis) (prompt ">:") (terpri)
(setq num (getreal ""))
(if num
(setq dis num)
)
(setq Lines (ssget '((0 . "LINE"))))
(setq LineNum (sslength Lines))
(setq i 0)
(repeat LineNum
(setq o (ssname Lines i))
(command "change" o "" "p" "la" "图层1" "")
(command "offset" (/ dis 2) o '(-9999999 -9999999) "")
(setq l1 (entlast))
(command "change" l1 "" "p" "la" "管径" "")
(command "offset" (/ dis 2) o '(9999999 9999999) "")
(setq l2 (entlast))
(command "change" l2 "" "p" "la" "管径" "")
(command "change" l2 "" "p" "LW" "30" "")
(setq Line (entget o))
(setq p10 (cdr (assoc 10 Line)))
(setq p11 (cdr (assoc 11 Line)))
(setq center (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p10 p11)))
(setq ss (ssadd))
(ssadd o ss)
(command "scale" ss "" center 1.5)
(setq i (+ i 1))
)
(setvar "CLAYER" oldlayer)
(command "undo" "e")
)

(defun c:bs (/ oldlayer o) 
    (prompt "***单线变双线***") 
    (command "undo" "be") 
    (setq oldlayer (getvar "CLAYER")) 
    (setvar "cmdecho" 0) 
    (if (not (tblobjname "ltype" "Dashed")) 
        (command "linetype" "l" "dashed" ""  "") 
        ) 
    (if (not (tblsearch "layer" "图层1")) 
        (command "layer" "n" "图层1" "c" "2" "图层1" "") 
        ) 
    (command "layer" "l" "dashed" "图层1"  "") 
    (if (not (tblsearch "layer" "管径")) 
        (command "layer" "n" "管径" "c" "2" "管径" "") 
        ) 
    (command "layer" "l" "Continuous" "管径"  "") 
    (command "layer" "lw" "30" "管径"  "") 
    (if dis 
        (setq dis dis) 
        (setq dis 1) 
        ) 
    (prompt "\n请输入双线间的距离<")    (princ dis)    (prompt ">:")    (terpri) 
    (setq num (getreal "")) 
    (if num 
        (setq dis num) 
        ) 
    (setq Lines (ssget '((0 . "LINE")))) 
    (setq LineNum (sslength Lines)) 
    (setq i 0) 
    (repeat LineNum 
        (setq o (ssname Lines i)) 
        (command "change" o "" "p" "la" "图层1" "") 
        (command "offset" (/ dis 2) o '(-9999999 -9999999) "") 
        (setq l1 (entlast)) 
        (command "change" l1 "" "p" "la" "管径" "") 
        
        (command "offset" (/ dis 2) o '(9999999 9999999) "") 
        (setq l2 (entlast)) 
        (command "change" l2 "" "p" "la" "管径" "") 
        (command "change" l2 "" "p" "LW" "30" "") 
 
        (setq Line (entget o)) 
        (setq p10 (cdr (assoc 10 Line))) 
        (setq p11 (cdr (assoc 11 Line))) 
        (setq center (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p10 p11))) 
        (setq ss (ssadd)) 
        (ssadd o ss) 
        (command "scale" ss "" center 1.5) 
        (setq i (+ i 1)) 
    ) 
    (setvar "CLAYER" oldlayer) 
    (command "undo" "e") 
)

wjnnan · 发表于 2014-7-24 16:55:46

Bellahx 发表于 2014-7-24 16:26
在楼主的要求下做了点修改，没能把生成的线变成pline线。对pline的命令不是很了解，有相关文章希望推荐一下 ...

感谢你的帮助，我在论坛里找到了一个相似的程序，希望对你有帮助，但是他的太复杂，我不需要，我只需要直线段的那一部分，其它的不需要，请你综合一下你们两个的程序，我的要求是输入或选取一条线（能判断图层1存在，不存在则建立），人工给出管径距离，这条线向两侧偏移0.5倍的管径距离，并偏移成 pine 线（能判断图层2存在，不存在则建立），选取或输入的那条线放大1.5倍，感谢了
以下是那位兄弟的程序，具体出处一时间找不到了，还请见谅，

(defun lineco(ss / scale1 index1 )
; (command "_Linetype" "Load" "CENTER" "" "")
(setq index1 0)
 (setvar "cmdecho" 0)
 (setq scale1 ( / 75 (getvar "LTSCALE")))

(repeat (sslength ss)
 (command "chprop" (ssname ss index1) "" "c" "red" "LT" "CENTER" "S" scale1 "" )
 (setq index1 (1+ index1))

)
(setvar "cmdecho" 1)
)

(defun arcsx(ename dist / bigarc entdata entdata1 newlayer rnew rnewlist roldlist smallarc scale1)
 (setvar "cmdecho" 0)
 (setq oldlayer (getvar "clayer"))
 (setvar "cecolor" "yellow")
 (setq entdata(entget ename))
 (setq roldlist(assoc 40 entdata)
rnew (cdr roldlist)
rnew (+ rnew (* dist 0.5))
rnewlist(cons 40 rnew)
newlayer(cons 8 (getvar "clayer"))
entdata1(subst rnewlist roldlist entdata)
entdata1(subst newlayer (assoc 8 entdata1) entdata1)
 )

 (entmake entdata1)
(command "_pedit" (entlast) "" "W" 0.6 "")
 (command "chprop" (entlast) "" "c" "yellow" "" )
 (setq bigarc (vlax-ename->vla-object(entlast)))
 (setq rnew (- rnew dist)
rnewlist(cons 40 rnew)
newlayer(cons 8 (getvar "clayer"))
entdata1(subst rnewlist roldlist entdata)
entdata1(subst newlayer (assoc 8 entdata1) entdata1)
 )
 (entmake entdata1)
(command "_pedit" (entlast) "" "W" 0.6 "")
(command "chprop" (entlast) "" "c" "yellow" "" )
 (setq scale1 ( / 75 (getvar "LTSCALE")))

 (command "chprop" ename "" "c" "red" "LT" "CENTER" "S" scale1 "" )
 (setvar "cecolor" oldcolor)
 (setvar "cmdecho" 0)
 (setq smallarc (vlax-ename->vla-object(entlast)))
 (list smallarc bigarc)
)

(defun linesx(ename dist / ang entdata pt1 pt2 sxpt1 sxpt2 sxpt3 sxpt4 xk)
;*****************************************

;************************************************8
(setq xk (* dist 0.5)
 entdata(entget ename)
 pt1 (cdr(assoc 10 entdata))
 pt2 (cdr(assoc 11 entdata))
 ang (+(angle pt1 pt2) (* 0.5 pi))
 sxpt1 (polar pt1 ang xk)
 sxpt2 (polar pt2 ang xk)
 entdata1 (assoc 0 entdata)
)
; (command "chprop" entdata1 "" "c" "red" "" )
; (entmake (list (cons 0 "LINE")(cons 10 sxpt1)(cons 11 sxpt2)(cons 8 (getvar "clayer"))))

(setvar "cmdecho" 0)
(setq oldcolor (getvar "cecolor"))
(setvar "cecolor" "yellow")
(command "pline" sxpt1 "width" 0.6 0.6 sxpt2 "" )
(setq ang (+ pi ang)
 sxpt3 (polar pt1 ang xk)
 sxpt4 (polar pt2 ang xk)
)
(command "pline" sxpt3 "width" 0.6 0.6 sxpt4 "" )
(command "pline" sxpt1 "width" 0.6 0.6 sxpt3 "" )
(command "pline" sxpt2 "width" 0.6 0.6 sxpt4 "" )
(setvar "cecolor" oldcolor)
(setvar "cmdecho" 1)
; (entmake (list (cons 0 "LINE")(cons 10 sxpt3)(cons 11 sxpt4)(cons 8 (getvar "clayer"))))
; (entmake (list (cons 0 "LINE")(cons 10 sxpt1)(cons 11 sxpt3)(cons 8 (getvar "clayer"))))
; (entmake (list (cons 0 "LINE")(cons 10 sxpt2)(cons 11 sxpt4)(cons 8 (getvar "clayer"))))
)

(defun pipefillet(ename1 ename2 r l dw / entdata1 entdata2 inter pt1 pt11 pt12 pt2 pt21 pt22 oldlayer acadobj ang pt3 pt4 pt5 pt6 xxpt1 xxpt2 xxpt3 xxpt4 xk1 r1 ang12 )
 (setq entdata1 (entget ename1)
entdata2 (entget ename2)
pt11 (cdr(assoc 10 entdata1))
pt12 (cdr(assoc 11 entdata1))
pt21 (cdr(assoc 10 entdata2))
pt22 (cdr(assoc 11 entdata2))
inter(inters pt11 pt12 pt21 pt22)
pt1 (if (> (distance pt11 inter)(distance pt12 inter)) pt11 pt12)
pt2 (if (> (distance pt21 inter)(distance pt22 inter)) pt21 pt22)
pt3 (polar inter (angle inter pt1) (* r 1.0))
pt4 (polar inter (angle inter pt2) (* r 1.0))
;*****************
ang12 (/ (abs (-(angle inter pt1) (angle inter pt2))) 2)
 )
 ( if ( > l 0)
 (progn
 (if (> ang12 1.57079) (setq ang12 (- 6.283185307 ang12)) )

 (setq
 r1 (* r (/ (cos ang12) (sin ang12)) )
pt5 (polar inter (angle inter pt1) (+(* r1 1.0) l))
pt6 (polar inter (angle inter pt2) (+(* r1 1.0) l))
 ang (+(angle inter pt1) (* 0.5 pi))
 xk1 (* dw 0.5)
xxpt1 (polar pt5 ang xk1)
 ang (+ pi ang)
xxpt2 (polar pt5 ang xk1)
 ang (+(angle inter pt2) (* 0.5 pi))
xxpt3 (polar pt6 ang xk1)
 ang (+ pi ang)
xxpt4 (polar pt6 ang xk1)

 )
 )
)
 (setvar "filletrad" r)
 (setq acadobj (vlax-get-acad-object))
 (vla-zoomcenter acadobj (vlax-3d-point inter) (* r 4.0))
 (setq oldlayer (getvar "clayer"))
 (setvar "cmdecho" 0)
;****************
( if ( > l 0)
 (progn
 (command "color" "yellow")
 (command "pline" xxpt1 "width" 0.6 0.6 xxpt2 "" )
 (command "pline" xxpt3 "width" 0.6 0.6 xxpt4 "" )
 )
)

 (setq oldlytpe (getvar "celtype"))
 (setq oldcolor (getvar "cecolor"))


 (setvar "clayer" (cdr (assoc 8 entdata1)))
 (command "fillet" pt3 pt4)


 (setvar "clayer" oldlayer)

 (setvar "cmdecho" 1)
 (entlast)
)

(defun pipesfillet(liness r l dw / ename1 ename2 entdata1 entdata2 index1 index2 pt1 pt2 pt3 pt4)
 (setq index1 0)
 (setq arcss (ssadd))
 (setq acadobj (vlax-get-acad-object))
 (setq acdoc (vla-get-activedocument acadobj))
 (vla-startundomark acdoc)
 (repeat (- (sslength liness) 1)
(setq ename1 (ssname liness index1))
(setq entdata1 (entget ename1))
(setq pt1 (cdr(assoc 10 entdata1)))
(setq pt2 (cdr(assoc 11 entdata1)))
(setq index2 (1+ index1))

(while (< index2 (sslength liness))
 (setq ename2 (ssname liness index2))
 (setq index2 (1+ index2))
 (setq entdata2(entget ename2))
 (setq pt3 (cdr (assoc 10 entdata2)))
 (setq pt4 (cdr (assoc 11 entdata2)))
 (if (inters pt1 pt2 pt3 pt4) (setq arcss (ssadd (pipefillet ename1 ename2 r l dw ) arcss)))
)
(setq index1 (1+ index1))
 )

 (vla-endundomark acdoc)
 arcss
)

;;;主函数选择中心线变为管道
(defun c:pd( / arcss dw dw_index dw_list ename index linetype pipess r r_list l dw )
 (vl-load-com)

 (setq dw (getreal "输入管道外径<219>: "))
 (if (null dw) (setq dw 219.0))

 (setq r (getreal "\n输入弯头转弯半径<350>: "))
 (if (null r) (setq r 350.0))
 (setq l (getreal "\n输入弯头直管段长度<0>: "))
 (if (null l) (setq l 0.0))

;;; (if (null r)(setq r (nth dw_index r_list)))

 (princ "\n请选择管道中心线: ")
 (setq pipess (ssget (list (cons 0 "line"))))
 (setq arcss (pipesfillet pipess r l dw ))
 (setq index 0)

 (lineco pipess)
 (repeat (sslength pipess)
(setq ename (ssname pipess index)
 index (1+ index)
 linetype (cdr(assoc 0 (entget ename)))
)


(if (= linetype "LINE")
 (linesx ename dw)
 (arcsx ename dw)
)
 )
 (setq index 0)
 (repeat (sslength arcss)
(setq ename (ssname arcss index)
 index (1+ index)
 linetype (cdr(assoc 0 (entget ename)))
)

(arcsx ename dw)
 )
 (princ)

)

Bellahx · 发表于 2014-7-26 21:24:08

wjnnan 发表于 2014-7-24 16:55
感谢你的帮助，我在论坛里找到了一个相似的程序，希望对你有帮助，但是他的太复杂，我不需要，我只需要直 ...

首先，你选择的线是line还是pline？
其次，你确定测试过我写的代码了么？

wjnnan · 发表于 2014-7-28 08:50:22

Bellahx 发表于 2014-7-26 21:24
首先，你选择的线是line还是pline？
其次，你确定测试过我写的代码了么？

感谢你的回复，选择的是line线，或者直接画line线，您的代码我测试过，总体来讲不错，但还有一些bug，
偏移形成的线的信息如下：
命令:  LIST
选择对象: 找到 1 个

选择对象:
               直线       图层: 管径
                        空间: 模型空间
线型比例 = 73.504
               句柄 = 82bb
               自点， X=1213669.737  Y=741500.002  Z= 0.000
               到点， X=1228370.560  Y=741500.002  Z= 0.000
      长度 =14700.823，在 XY 平面中的角度 =  0.000
               增量 X =14700.823，增量 Y =    0.000，增量 Z = 0.000

命令:  LIST
选择对象: 找到 1 个

选择对象:
               直线       图层: 管径
                        空间: 模型空间
               线宽: 2.11 毫米
线型比例 = 73.504
               句柄 = 82bc
               自点， X=1213669.737  Y=741800.002  Z= 0.000
               到点， X=1228370.560  Y=741800.002  Z= 0.000
      长度 =14700.823，在 XY 平面中的角度 =  0.000
               增量 X =14700.823，增量 Y =    0.000，增量 Z = 0.000

希望在程序前边能改成选线或画线，偏移之后形成的线能是pline线，我找的那段代码，希望对您有帮助，我自己lisp基础差，试着改了一下，结果面目全非，惨不忍睹，希望您能再帮着改改，谢谢

wjnnan · 发表于 2014-8-8 11:09:41

wjnnan 发表于 2014-7-28 08:50
感谢你的回复，选择的是line线，或者直接画line线，您的代码我测试过，总体来讲不错，但还有一些bug，
偏 ...

问题已解决，虽然还差了一点，但不影响使用了，下面是源码

(defun c:bs()
(command "undo" "be")
(command "celtype" "dashed2")
  (if  (=  (tblsearch "layer" "管中心线") nil)
      (command "layer" "m" "管中心线" "c" "2" "" "")
)
  (if  (=  (tblsearch "layer" "管壁") nil)
      (command "layer" "m" "管壁" "c" "2" "" "")
)
(setq pt1 (getpoint "请选择第1点"))
(princ "\n")
(setq pt2 (getpoint "请选择第2点"))
(princ "\n")
(command "line" pt1 pt2 "")
(setq o1 (entlast))
(command "change" o1 "" "p" "la" "管中心线" "")
(command "celtype" "Continuous")
(setq dis (getreal "\n输入双线间的距离:"))
(command "pline" pt1 "w" 30 30 pt2 "")
(setq o (entlast))

(command "offset" (/ dis 2) o '(-9999999 -9999999) "")
(command "change" (entlast) "" "p" "la" "管壁" "")
(command "offset" (/ dis 2) o '(9999999 9999999) "")
(command "change" (entlast) "" "p" "la" "管壁" "")
(command "erase" o "")

(command "scale" o1 "" (middle pt1 pt2) 1.5)
)

(defun middle(pt1 pt2)
(setq x (/ (+ (car pt1)    (car pt2)) 2))
(setq y (/ (+ (cadr pt1) (cadr pt2)) 2))
(setq z (/ (+ (caddr pt1) (caddr pt2)) 2))
(list x y z)
)

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

[已解答] 单线变双线能不能改成这样

相关帖子

本帖子中包含更多资源

点评

点评