5币求画线截断直线程序，要源码
理想功能：用鼠标指定两点，然后将鼠标两点之间的所有直线截断并删除断开的某边，删除方向可选理想使用方法：1.鼠标左键指定两点 2.鼠标左键指定删除哪一边（类似于执行偏移命令时选择方向）
半听可乐 发表于 2012-7-7 00:08 static/image/common/back.gif
非常感谢！但还有bug：当截断多条线时有些线截断不了，还没找到规律性~~望好人继续完善
(defun c:ltr (/ CMDECHO F3 OS F8 OTH P1 LOOP GR P2 DP SE2 SE1 N K EN ENL)
(defun *error* (s)
(princ s)
(setvar 'cmdecho cmdecho)
(setvar 'osmode os)
(setvar 'ORTHOMODE oth)
)
(setq cmdecho (getvar 'cmdecho))
(setq f3 (getvar 'osmode) os f3)
(setq f8 (getvar 'ORTHOMODE) oth f8)
(setvar 'cmdecho 0)
(initget 7)
(setq p1 (getpoint "\n第一点:"))
(setq loop t)
(while loop
(setq gr (grread t 15))
(redraw)
(cond
((= 5 (car gr))
(setq p2 (cadr gr))
(if (= 1 f8)
(progn
(setq
dp (mapcar '-
(apply 'mapcar (cons 'max (list p1 p2)))
(apply 'mapcar (cons 'min (list p1 p2)))
)
)
(if (> (car dp) (cadr dp))
(setq p2 (list (car p2) (cadr p1)))
(setq p2 (list (car p1) (cadr p2)))
)
)
)
(grdraw p1 p2 1 -1)
)
((= 3 (car gr))
(setq loop nil)
(setq p2 (cadr (grread t 15)))
(if (= 1 f8)
(progn
(setq
dp (mapcar '-
(apply 'mapcar (cons 'max (list p1 p2)))
(apply 'mapcar (cons 'min (list p1 p2)))
)
)
(if (> (car dp) (cadr dp))
(setq p2 (list (car p2) (cadr p1)))
(setq p2 (list (car p1) (cadr p2)))
)
)
)
)
((equal gr '(2 6));F3切换捕捉开关
(if (< f316384)
(progn (setq f3 (+ f3 16384))(prompt "\n<对象捕捉 关>"))
(progn (setq f3 (- f3 16384))(prompt "\n<对象捕捉 开>"))
)
(setvar "OSMODE" f3)
)
((equal gr '(2 15));F8切换正交开关
(if (= f8 0)
(progn(setq f8 1)(prompt "\n<正交 开>"))
(progn(setq f8 0)(prompt "\n<正交 关>"))
)
(setvar "orthomode" f8)
)
)
)
(setq se2 (ssget "f" (list p1 p2)))
(if (null se2) (abcdefg))
(command "line" "non" p1 "non" p2 "")
(setq se1 (entlast))
(grdraw p1 p2 1 -1)
(initget 7 "")
(setq p1 (getpoint "\n剪切哪一边？："))
(if (= "" p1) (abcdefg))
(setq n (sslength se2) k 0)
(repeat n
(progn
(setq en (ssname se2 k)
enl (list en p1)
)
(command "trim" se1 "" enl "")
(setq k (1+ k))
)
)
(entdel se1)
(redraw)
(setvar 'cmdecho cmdecho)
(setvar 'osmode os)
(setvar 'ORTHOMODE oth)
(princ)
)
本帖最后由 Andyhon 于 2012-7-6 18:25 编辑
(defun C:/= ()
(prompt "\n鼠标左键指定两点...")
(setq p1 (getpoint "\n 1st 点: ")
p2 (getpoint p1 "\n 2nd 点: ")
)
(cond
((setq ss (ssget "C" p1 p2))
(setq p3 (getpoint "\n鼠标左键指定删除哪一边: ")
i0
)
(while (setq ee (ssname ss i))
(setq dat (entget ee)
pa (cdr (assoc 10 dat))
pb (cdr (assoc 11 dat))
px (inters p1 p2 pa pb nil)
pt (PerToLine p3 pa pb) ; http://bbs.mjtd.com/thread-89548-1-1.html
i (1+ i)
)
(cond
((equal (distance pa px) (+ (distance pa pt) (distance pt px)) 1e-4)
(setq dp 10)
)
((equal (distance pb px) (+ (distance pb pt) (distance pt px)) 1e-4)
(setq dp 11)
)
((equal (distance pt px) (+ (distance pt pa) (distance pa px)) 1e-4)
(setq dp 10)
)
((equal (distance pt px) (+ (distance pt pb) (distance pb px)) 1e-4)
(setq dp 11)
))
(entmod (subst (cons dp px) (assoc dp dat) dat))
)))
)
不合需求时请上传调试用 Dwg 文件
(defun c:jd()
(setq pt1 (getpoint "/n指定第1点："))
(setq pt2 (getpoint "/n指定第2点："))
(setq pt3 (getpoint "/n指定第3点："))
(command "line" pt1 pt2 "")
(setq tg (entLast))
(command "trim" tg "" "f" pt1 pt3 pt2 "" "")
(entdel tg)
) Andyhon ，子函数PERTOLINE补充一下码 Andyhon 发表于 2012-7-6 16:57 static/image/common/back.gif
不合需求时请上传调试用 Dwg 文件
CAD2004提醒：错误: no function definition: PERTOLINE 好像类似于画线剪切。。。 半听可乐 发表于 2012-7-6 17:16 static/image/common/back.gif
CAD2004提醒：错误: no function definition: PERTOLINE
(PerToLine p3 pa pb) ; http://bbs.mjtd.com/thread-89548-1-1.html
PerToLine 在 http://bbs.mjtd.com/thread-89548-1-1.html
本帖最后由 半听可乐 于 2012-7-6 17:39 编辑
hao3ren 发表于 2012-7-6 17:11 http://bbs.mjtd.com/static/image/common/back.gif
(defun c:jd()
(setq pt1 (getpoint "/n指定第1点："))
(setq pt2 (getpoint "/n指定第2点："))
功能很接近了，美中不足的是指定前面两点时没有两点间的预览线（截断前的预览，配合正交开关能把直线截得横平竖直^_^ 下图演示中我指的“预览线”比较明显），希望朋友能改进一下 (defun c:jd()
(setq pt1 (getpoint "\n指定第1点："))
(setq pt2 (getpoint pt1 "\n指定第2点："))
(setq pt3 (getpoint "\n指定第3点："))
(command "line" pt1 pt2 "")
(setq tg (entLast))
(command "trim" tg "" "f" pt1 pt3 pt2 "" "")
(entdel tg)
)