求各位大神帮我一个忙，平行和圆弧线生成中线

wayne_myles

求各位大神帮我一个忙，平行和圆弧线生成中线!!
全部由平行的直线和圆弧组成 求lsp自动生成中线!!!!
可以吗 是不是很难弄了!!!




自动生产如下效果的中线


谢谢指点和关注
===================================================
===================================================
                                     求改进我拼凑的代码(我生硬拼凑 一楼和三楼代码 求改进)
====================================================================================================
; tt(平行线中线)
(defun c:www()
  (if (and (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
           (= (sslength ss) 2)
      )
    (progn
      (setq s1 (ssname ss 0)
            s2 (ssname ss 1)
            p1 (vlax-curve-getStartPoint s1)
            p2 (vlax-curve-getStartPoint s2)
            pt (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)
            p1 (vlax-curve-getclosestpointto s1 pt)
            dd (distance pt p1)
      )      
      (command "offset" dd "")
      (command "offset" "" (list s1 p1) pt "")
      (command"chprop" (entlast) "" "c" 1 "")
    )
  )
  (princ)
)

;;;功能：连接首尾相连线条
;;;操作方式：点取一条，自动搜索相接对象，在分支处提示。
(defun c:xx (/ ss0 ss1 lst_en EN EN_BASE FIL I LET_EN LST LST_0        LST_1
             PT0 PT1 TMP)
  (princ "\n功能：连接首尾相连线条")


  ;;(or (setq *fuzz* (getdist "\n请输入连接精度<5>: "))
      (setq *fuzz* 0.2)
  ;;)
  ;; 生成首尾相连选集.
  (if (and (setq fil '((0 . "LINE,ARC,*POLYLINE")))
           (setq ss0 (ssget "x" fil))
           (princ "\n请点取一条线：")
           (setq ss1 (ssget ":S" fil))
      )
    (progn

      ;;1、得到首个对象
      (setq en_base (ssname ss1 0)
            pt0            (vlax-curve-getStartPoint en_base)
            pt1            (vlax-curve-getEndPoint en_base)
      )
      ;;2、获取lst_en
      (setq let_en '()
            i           0
            ss0           (ssdel en_base ss0)
      )
      (repeat (sslength ss0)
        (setq en     (ssname ss0 i)
              lst_en (cons en lst_en)
              i             (1+ i)
        )
      )
      ;;3、计算起点处
      (setq lst_0 (xx-find lst_en pt0 *fuzz*))
      ;;4、计算终点处
      (foreach en lst_0
        (setq lst_en (vl-remove en lst_en))
      )
      (setq lst_1 (xx-find lst_en pt1 *fuzz*))
      (print lst_0)
      (print lst_1)
      (setq lst (append (reverse lst_0) (list en_base) lst_1))
      ;;4、连接操作
      (command "_.undo" "be")
      (setq tmp (getvar "PEDITACCEPT"))
      (setvar "PEDITACCEPT" 1)

      ;;方式一
      (command "_.pedit" "m" en_base)
      (foreach en (append lst_0 lst_1)
        (command en)
      )
      (command "" "j" *fuzz* "")

    )
  )
  (princ)
)
;;;=================================================================*
;;;查找符合要求的图元。                                             *
;;;要求：首尾相连，允许误差为fuzz。                                 *
;;;★★特别的：按照坐标差值判断，而不是两点间距计算。               *
(defun xx-find (lst_en pt fuzz / lst_jg en pt0 pt1 tmp pt_next)
  (setq lst_jg '())
  (foreach en lst_en
    (setq pt0 (vlax-curve-getStartPoint en)
          pt1 (vlax-curve-getEndPoint en)
    )
    (cond ((equal pt0 pt fuzz)
           (setq tmp        (list en pt0 pt1)
                 lst_jg        (cons tmp lst_jg)
           )
          )
          ((equal pt1 pt fuzz)
           (setq tmp        (list en pt1 pt0)
                 lst_jg        (cons tmp lst_jg)
           )
          )
    )
  )
  ;;判断并返回
  ;;若找到多个，则需要人工干预
  (cond        ((= lst_jg nil)
         nil
        )
        ((= (length lst_jg) 1)
         (setq tmp     (car lst_jg)
               en      (nth 0 tmp)
               pt_next (nth 2 tmp)
               lst_en  (vl-remove en lst_en)
         )
         (cons en (xx-find lst_en pt_next fuzz))
        )
        ((> (length lst_jg) 1)
         (setq tmp     (xx-sel-only lst_jg)
               en      (nth 0 tmp)
               pt_next (nth 2 tmp)
               lst_en  (vl-remove en lst_en)
         )
         (cons en (xx-find lst_en pt_next fuzz))
        )
  )
)
;;;=================================================================*
;;;提醒用户选择分支中的一个。
;;;参数：lst 格式：'((en  pt0  pt1)(en  pt0  pt1)..)
;;;返回：(en  pt0  pt1)
(defun xx-sel-only (lst / lst_en en pt0 pt1 tmp)
  ;;移动对象到屏幕中心位置
  (command "-pan" (trans (cadar lst) 0 1) (getvar "VIEWCTR"))

  ;;逐个对象高亮显示
  (and ZL-DRAW-GRVECS-CIRCLE
       (progn (ZL-DRAW-GRVECS-CIRCLE (trans (cadar lst) 0 1) 10 1)
              (ZL-DRAW-GRVECS-CIRCLE (trans (cadar lst) 0 1) 15 2)
       )
  )
  (setq lst_en (mapcar 'car lst))
  (mapcar '(lambda (en) (redraw en 3)) lst_en)

  ;;提示用户选择
  (while (not (and (setq tmp (car (entsel "\n点取分支：")))
                   (setq tmp (assoc tmp lst))
              )
         )
    ()
  )
  ;;逐个对象取消高亮显示
  (mapcar '(lambda (en) (redraw en 4)) lst_en)
  ;;返回
  tmp
)
;;;==================


(defun c:111 ( )
    (c:xx)
    (c:xx)
    (c:www)
)

xyp1964

1. ;; tt(平行线中线)
   
2. (defun c:tt ()
   
3.   (if (and (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
   
4.            (= (sslength ss) 2)
   
5.       )
   
6.     (progn
   
7.       (setq s1 (ssname ss 0)
   
8.             s2 (ssname ss 1)
   
9.             p1 (vlax-curve-getStartPoint s1)
   
10.             p2 (vlax-curve-getStartPoint s2)
    
11.             pt (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)
    
12.             p1 (vlax-curve-getclosestpointto s1 pt)
    
13.             dd (distance pt p1)
    
14.       )      
    
15.       (command "offset" dd "")
    
16.       (command "offset" "" (list s1 p1) pt "")
    
17.       (command"chprop" (entlast) "" "c" 1 "")
    
18.     )
    
19.   )
    
20.   (princ)
    
21. )

;; tt(平行线中线)<br /> (defun c:tt ()<br />   (if (and (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))<br />            (= (sslength ss) 2)<br />       )<br />     (progn<br />       (setq s1 (ssname ss 0)<br />             s2 (ssname ss 1)<br />             p1 (vlax-curve-getStartPoint s1)<br />             p2 (vlax-curve-getStartPoint s2)<br />             pt (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)<br />             p1 (vlax-curve-getclosestpointto s1 pt)<br />             dd (distance pt p1)<br />       )      <br />       (command "offset" dd "")<br />       (command "offset" "" (list s1 p1) pt "")<br />       (command"chprop" (entlast) "" "c" 1 "")<br />     )<br />   )<br />   (princ)<br /> )

wayne_myles

找到一个类似帖子http://bbs.mjtd.com/forum.php?mod=viewthread&tid=93820&highlight=%D6%D0%CF%DF

有点问题求改进




求改进如下源码
(vl-load-com)
(defun C:zx( / dispt1 dispt2 dispt3 dispt4 e1 e2 i ii mindis obj1 obj2 pt1 pt2 pt3 pt4 ss sslen)
(setq SS (ssget '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE,SPLINE"))))
  (setq i 0)
  (setq sslen (sslength ss))
  (repeat (1- sslen)
    (setq E1 (ssname SS i))
    (setq ii (1+ i))
    (repeat (- sslen i)
      (setq E2 (ssname SS ii))
  (if (and
      E1
      E2
     (setq OBJ1 (vlax-ename->vla-object E1))
     (setq OBJ2 (vlax-ename->vla-object E2))
     (setq pt1 (vlax-curve-getstartpoint E1))
     (setq pt2 (vlax-curve-getEndPoint E1))
     (setq pt3 (vlax-curve-getstartpoint E2))
     (setq pt4 (vlax-curve-getEndPoint E2))
     (setq dispt1 (th-per pt1 obj2))
     (setq dispt2 (th-per pt2 obj2))
     (setq dispt3 (th-per pt3 obj1))
     (setq dispt4 (th-per pt4 obj1))
     (< (max dispt1 dispt2 dispt3 dispt4) 500)
     (> (setq mindis (min dispt1 dispt2 dispt3 dispt4)) 0)
      )
    (command "._OFFSET" (/ mindis 2) e1 pt3 "")
  )
      (setq ii (1+ ii))
      )
    (setq i (1+ i))
    )
  (princ)
)
;;; ==================================================================
;;; 返回(距离  垂足) 点pt到直线的距离和垂足.
;;; ==================================================================
(defun th-per (pt obj / pt2 dist)
  (if (and
        pt
        obj
      )
    (setq dist (distance pt (setq pt2 (vlax-curve-getclosestpointto obj pt t))))
  )
)

wayne_myles

xyp1964 发表于 2019-1-12 16:35

院长好厉害!谢谢
可否加入判断??!!!! ----点击一边直线自动转化合并相连为多线 然后再点击 另外一边直线自动转化合并相连为多线 然后再计算中线
可以吗
我搜索论坛qcw911大大 首尾相连代码挺不错
问题怎么加入院长大大的代码 求指点
=========================================================
=========================================================
;;;功能：连接首尾相连线条byqcw911
;;;操作方式：点取一条，自动搜索相接对象，在分支处提示。
(defun c:xx (/ ss0 ss1 lst_en EN EN_BASE FIL I LET_EN LST LST_0        LST_1
             PT0 PT1 TMP)
  (princ "\n功能：连接首尾相连线条")

  ;;
  (or (setq *fuzz* (getdist "\n请输入连接精度<5>: "))
      (setq *fuzz* 5.0)
  )
  ;; 生成首尾相连选集.
  (if (and (setq fil '((0 . "LINE,ARC,*POLYLINE")))
           (setq ss0 (ssget "x" fil))
           (princ "\n请点取一条线：")
           (setq ss1 (ssget ":S" fil))
      )
    (progn

      ;;1、得到首个对象
      (setq en_base (ssname ss1 0)
            pt0            (vlax-curve-getStartPoint en_base)
            pt1            (vlax-curve-getEndPoint en_base)
      )
      ;;2、获取lst_en
      (setq let_en '()
            i           0
            ss0           (ssdel en_base ss0)
      )
      (repeat (sslength ss0)
        (setq en     (ssname ss0 i)
              lst_en (cons en lst_en)
              i             (1+ i)
        )
      )
      ;;3、计算起点处
      (setq lst_0 (xx-find lst_en pt0 *fuzz*))
      ;;4、计算终点处
      (foreach en lst_0
        (setq lst_en (vl-remove en lst_en))
      )
      (setq lst_1 (xx-find lst_en pt1 *fuzz*))
      (print lst_0)
      (print lst_1)
      (setq lst (append (reverse lst_0) (list en_base) lst_1))
      ;;4、连接操作
      (command "_.undo" "be")
      (setq tmp (getvar "PEDITACCEPT"))
      (setvar "PEDITACCEPT" 1)

      ;;方式一
      (command "_.pedit" "m" en_base)
      (foreach en (append lst_0 lst_1)
        (command en)
      )
      (command "" "j" *fuzz* "")

    )
  )
  (princ)
)
;;;=================================================================*
;;;查找符合要求的图元。                                             *
;;;要求：首尾相连，允许误差为fuzz。                                 *
;;;★★特别的：按照坐标差值判断，而不是两点间距计算。               *
(defun xx-find (lst_en pt fuzz / lst_jg en pt0 pt1 tmp pt_next)
  (setq lst_jg '())
  (foreach en lst_en
    (setq pt0 (vlax-curve-getStartPoint en)
          pt1 (vlax-curve-getEndPoint en)
    )
    (cond ((equal pt0 pt fuzz)
           (setq tmp        (list en pt0 pt1)
                 lst_jg        (cons tmp lst_jg)
           )
          )
          ((equal pt1 pt fuzz)
           (setq tmp        (list en pt1 pt0)
                 lst_jg        (cons tmp lst_jg)
           )
          )
    )
  )
  ;;判断并返回
  ;;若找到多个，则需要人工干预
  (cond        ((= lst_jg nil)
         nil
        )
        ((= (length lst_jg) 1)
         (setq tmp     (car lst_jg)
               en      (nth 0 tmp)
               pt_next (nth 2 tmp)
               lst_en  (vl-remove en lst_en)
         )
         (cons en (xx-find lst_en pt_next fuzz))
        )
        ((> (length lst_jg) 1)
         (setq tmp     (xx-sel-only lst_jg)
               en      (nth 0 tmp)
               pt_next (nth 2 tmp)
               lst_en  (vl-remove en lst_en)
         )
         (cons en (xx-find lst_en pt_next fuzz))
        )
  )
)
;;;=================================================================*
;;;提醒用户选择分支中的一个。
;;;参数：lst 格式：'((en  pt0  pt1)(en  pt0  pt1)..)
;;;返回：(en  pt0  pt1)
(defun xx-sel-only (lst / lst_en en pt0 pt1 tmp)
  ;;移动对象到屏幕中心位置
  (command "-pan" (trans (cadar lst) 0 1) (getvar "VIEWCTR"))

  ;;逐个对象高亮显示
  (and ZL-DRAW-GRVECS-CIRCLE
       (progn (ZL-DRAW-GRVECS-CIRCLE (trans (cadar lst) 0 1) 10 1)
              (ZL-DRAW-GRVECS-CIRCLE (trans (cadar lst) 0 1) 15 2)
       )
  )
  (setq lst_en (mapcar 'car lst))
  (mapcar '(lambda (en) (redraw en 3)) lst_en)

  ;;提示用户选择
  (while (not (and (setq tmp (car (entsel "\n点取分支：")))
                   (setq tmp (assoc tmp lst))
              )
         )
    ()
  )
  ;;逐个对象取消高亮显示
  (mapcar '(lambda (en) (redraw en 4)) lst_en)
  ;;返回
  tmp
)
;;;==================

xyp1964

1. ;; tt(平行线中线)
   
2. (defun c:tt ()
   
3.   (if (and (setq s1 (car (entsel "\n选择线1: ")))
   
4.            (setq s2 (car (entsel "\n选择线2: ")))
   
5.            (not (equal s1 s2))
   
6.       )
   
7.     (progn
   
8.       (setq ss1        (xyp-CurveJoin s1 0)
   
9.             s1        (xyp-PeditJoin ss1 0)
   
10.             ss2        (xyp-CurveJoin s2 0)
    
11.             s2        (xyp-PeditJoin ss2 0)
    
12.             p1        (vlax-curve-getStartPoint s1)
    
13.             p2        (vlax-curve-getStartPoint s2)
    
14.             pt        (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)
    
15.             p1        (vlax-curve-getclosestpointto s1 pt)
    
16.             dd        (distance pt p1)
    
17.       )
    
18.       (command "offset" dd "")
    
19.       (command "offset" "" (list s1 p1) pt "")
    
20.       (command "chprop" (entlast) "" "c" 1 "")
    
21.     )
    
22.   )
    
23.   (princ)
    
24. )

;; tt(平行线中线)<br /> (defun c:tt ()<br />   (if (and (setq s1 (car (entsel "\n选择线1: ")))<br />            (setq s2 (car (entsel "\n选择线2: ")))<br />            (not (equal s1 s2))<br />       )<br />     (progn<br />       (setq ss1        (xyp-CurveJoin s1 0)<br />             s1        (xyp-PeditJoin ss1 0)<br />             ss2        (xyp-CurveJoin s2 0)<br />             s2        (xyp-PeditJoin ss2 0)<br />             p1        (vlax-curve-getStartPoint s1)<br />             p2        (vlax-curve-getStartPoint s2)<br />             pt        (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)<br />             p1        (vlax-curve-getclosestpointto s1 pt)<br />             dd        (distance pt p1)<br />       )<br />       (command "offset" dd "")<br />       (command "offset" "" (list s1 p1) pt "")<br />       (command "chprop" (entlast) "" "c" 1 "")<br />     )<br />   )<br />   (princ)<br /> )

wayne_myles

xyp1964 发表于 2019-1-13 19:04

再次谢谢院长大人出手相助!!!

panliang9

谢谢院长和楼主，受益良多！

hnzkhyyl

不知道为什么，CAd2020上用不了