寻找交点，并且填充

wjnnan

先看样图，单选或框选线，自动寻找颜色相同的线交点，在交点处自动画一个等腰三角形（直角边可以人工输入），形成等腰三角形后，由鼠标控制选择三角形的形成方向，在选择方向后，自动填充与线相同的颜色，以前都是手工画，然后复制粘贴，实在是太累了，不知那位能帮着写一个程序，先谢谢了

风树

建议一下啊，都是不同专业的
都经过中国式的应试教育，做题做得了无滋味了，
描述得挺好，但能否把你专业方向，问题的应用对象，这个是什么图来的说说呢？
作为背景资料也好啊，要不热心的人给你建议了，过后都不知道这是干嘛的，
是不是啊

wjnnan

风树 发表于 2014-7-5 23:35
建议一下啊，都是不同专业的
都经过中国式的应试教育，做题做得了无滋味了，
描述得挺好，但能否把你专业 ...

主要是变电所设计时，连接电缆用的，相同颜色表示一根或多根电缆最后归于同一处

langjs

连个测试图都没有

wjnnan

langjs 发表于 2014-7-6 23:32
连个测试图都没有

单位的图纸都是加密的，我也没有办法啊，其实这个对cad版本没有要求，图层可以用当前层或指定到“电缆层”，毕竟原来都是在纯cad环境下画图，希望大家能帮忙，谢谢

langjs

;;; 画直线焦点三角形    by:langjs
;;;============================
(defun c:ww (/ co ent i j lst lst1 lst2 lst3 pt pt1 pt2 pt3 pt4 pt5 r ss ss1 zh)
  (setvar "cmdecho" 0)
  (setq zh (getvar "ORTHOMODE"))
  (setvar "ORTHOMODE" 0)
  (setq pt1 (getpoint "\n框选直线对象:")pt2 (getcorner pt1 "\指定对角点:")pt3 (list (car pt1) (cadr pt2))pt4 (list (car pt2) (cadr pt1))
        ss (ssget "CP" (list pt1 pt3 pt2 pt4 pt1) '((0 . "LINE"))))
  (repeat (setq i (sslength ss)) (redraw (ssname ss (setq i (1- i))) 3))
  (setq pt5 (getpoint pt1 "\指定方向:")        r (+ (* (fix (/ (angle pt1 pt5) (* 0.5 pi))) 0.5 pi) (* 0.25 pi))lst '())
  (repeat (setq i (sslength ss))
    (setq ent (entget (ssname ss (setq i (1- i))))  co (cdr (assoc 62 ent)))
    (if (not (member co lst))
      (progn
        (setq lst (cons co lst)  lst1 '() lst2 '() ss1 (ssget "CP" (list pt1 pt3 pt2 pt4 pt1) (list (cons 62 co) '(0 . "LINE"))))
        (repeat (setq j (sslength ss1))
          (setq ent (entget (ssname ss1 (setq j (1- j))))lst1 (cons (list (cdr (assoc 10 ent)) (cdr (assoc 11 ent))) lst1)))
        (setq lst3 lst1)
        (while lst3
          (setq pt5 (car lst3))
          (foreach j lst1
            (if (and (setq pt (inters  (car pt5)(cadr pt5)(car j)(cadr j))) (not (member pt lst2)))
              (progn
                (setq lst2 (cons pt lst2))
                (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 62 co) '(100 . "AcDbPolyline") '(90 . 2)
                               (cons 10 pt) (cons 40 0.0) (cons 41 14.14) (cons 10 (polar pt r 7.07)))))));14.14为三角形长边, 7.07为长边一半
          (setq lst3 (cdr lst3))))))
  (repeat (setq i (sslength ss)) (redraw (ssname ss (setq i (1- i))) 4))
  (setvar "ORTHOMODE" zh)
  (princ)
)

xyp1964

love1030312

院长比较强悍

xyp1964

没62码时获取其所在图层的颜色

wjnnan

langjs 发表于 2014-7-7 10:47
;;; 画直线焦点三角形    by:langjs
;;;============================
(defun c:ww (/ co ent i j lst ls ...

先感谢您的热心，我刚刚试了一下，我用的是CAD2008，加载vlisp，ww后,有以下提示“框选直线对象:指定对角点:指定方向:; 错误: ssget 列表值错误”，不知道还能改一下吗，谢谢