明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 329|回复: 6

[讨论] 求各位大神帮我一个忙,平行和圆弧线生成中线

[复制链接]
发表于 2019-1-12 13:52 | 显示全部楼层 |阅读模式
本帖最后由 wayne_myles 于 2019-1-14 21:01 编辑

求各位大神帮我一个忙,平行和圆弧线生成中线!!
全部由平行的直线和圆弧组成 求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)
)









本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2019-1-12 16:35 | 显示全部楼层

  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. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x

评分

参与人数 1明经币 +1 收起 理由
wayne_myles + 1 院长大大好厉害!

查看全部评分

回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2019-1-12 14:13 | 显示全部楼层
找到一个类似帖子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))))
  )
)

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
 楼主| 发表于 2019-1-13 06:50 | 显示全部楼层
本帖最后由 wayne_myles 于 2019-1-13 07:17 编辑

院长好厉害!谢谢
可否加入判断??!!!! ----点击一边直线自动转化合并相连为多线 然后再点击 另外一边直线自动转化合并相连为多线 然后再计算中线
可以吗
我搜索论坛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
)
;;;==================


发表于 2019-1-13 19:04 | 显示全部楼层

  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. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
 楼主| 发表于 2019-1-13 21:10 | 显示全部楼层

再次谢谢院长大人出手相助!!!
发表于 2019-1-14 09:44 | 显示全部楼层
谢谢院长和楼主,受益良多!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2019-6-27 06:08 , Processed in 0.162209 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表