[LISP程序]：给PFD8667的等分点连线程序!!

舟自横

不知道我说的你明不明白.现帮你随便写了一下不知道
能不能符合你的要求...
(defun c:linkline(/ en lisp 13list  i  24list )
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
(WHILE (NOT (setq en (car(entsel "\n請選擇一段線"))))
     (setq en (car(entsel "\n請選擇一段線"))))
  (hy_apline en)
  (setq lisp (hy_polpoint (entlast)))
  (setq i 0)
  (setq 13list '())
  (setq 24list '())
  (foreach item lisp (if i (progn (if (and (= (rem i 2) 0) (/= i 1))
                           (setq 13list (cons item 13list))
                           (setq 24list (cons item 24list))
                             )
                          (setq i (1+ i))
                             )
                       )
    )
  (command "pline")
  (foreach item 13list (command item))
  (command "")
  (command "change" (entlast) "" "p" "color" "1" "")
  (command "pline")
  (foreach item 24list (command item))
  (command "")
  (command "change" (entlast) "" "p" "color" "1" "")
  (princ "-------->> pline ok!! <<--------")
  (prin1)
  )
  (defun hy_polpoint(object / endata i endata_li)
  (setq point_list '())
  (setq endata (entget object))
  (setq i 0)
  (while (< i (length endata))
    (setq endata_li (nth i endata))
    (if (= (car endata_li) 10) (setq point_list (cons (cdr endata_li) point_list)))
    (setq i (1+ i))
    )
  (setq point_list (reverse point_list))
  )
(defun hy_apline(ename1 / vla-obj endpoint ename startpoint i ss1 nn ssm ssn itemx);;;選擇一條線串接與之相聯的圖元為多義線
  (if (= "LWPOLYLINE" (cdr(assoc 0 (entget ename1)))) (command "._explode" ename ""))
  (setq ename (entlast))
  (setq vla-obj (vlax-ename->vla-object ename))
   (setq startpoint (vlax-curve-getstartpoint vla-obj)
         endpoint (vlax-curve-getendpoint vla-obj))
;(safearray-value(vlax-variant-value(vla-get-endpoint vla-obj))))
  (if (OR (= "POLYLINE" (cdr(assoc 0 (entget ename))))
          (= "LWPOLYLINE" (cdr(assoc 0 (entget ename)))))
  (setq i 1)(SETQ I 0))
  (setq j 0);;計數器歸0
  (setq nn 0)
  (princ " ─── \r")
  (while (> (distance startpoint endpoint) 0.0000001);(= (vla-get-closed vla-obj) :vlax-false)
    ;(setq ss1 (ssget "x" (list (cons -4  "<or") (cons 10 endpoint)(cons 11 endpoint) (cons -4  "or>"))))
    (setq ss1 (ssadd))
    (setq ssn (ssget "f" (list endpoint (polar endpoint 0.8 0.1))))
    (foreach itemx (ap-sslist ssn)
      (if (or (< (distance endpoint (vlax-curve-getstartpoint (vlax-ename->vla-object itemx))) 0.0000001)
              (< (distance endpoint (vlax-curve-getendpoint (vlax-ename->vla-object itemx))) 0.0000001))
          (setq ss1 (ssadd itemx ss1))
        )
    )
   (setq ss2 (ssadd))
   (setq ssm (ssget "f" (list startpoint (polar startpoint 0.8 0.1))))
    (foreach itemx (ap-sslist ssm)
      (if (or (< (distance startpoint (vlax-curve-getstartpoint (vlax-ename->vla-object itemx))) 0.0000001)
              (< (distance startpoint (vlax-curve-getendpoint (vlax-ename->vla-object itemx))) 0.0000001))
          (setq ss2 (ssadd itemx ss2))
        )
    )
   (setq ssg (addss ss1 ss2))
   (if (= 0 i)(command "pedit" ename "y" "j" ssg "" "")
               (command "pedit" ename  "j" ssg "" ""))
    (setq ename (entlast))
    (setq vla-obj (vlax-ename->vla-object ename))
    (setq startpoint (vlax-curve-getstartpoint vla-obj)
         endpoint (vlax-curve-getendpoint vla-obj))
    (setq i (1+ i))
    (setq nn (1+ nn))
    (cond ((= nn 15)(princ  (strcat "線很長..正在串接中,請稍侯 ......  ───" "\r")))
          ((= nn 30)(princ  (strcat "線很長..正在串接中,請稍侯 ......  ﹨﹨﹨" "\r")))
          ((= nn 45)(princ  (strcat "線很長..正在串接中,請稍侯 ......  │││" "\r")))
          ((= nn 60)(princ  (strcat "線很長..正在串接中,請稍侯 ......  ∕∕∕" "\r")))
          )
    (if (> nn 60) (setq nn 1))
    (setq j (1+ j))
    (IF (and (= 1 (sslength ssg))(= (vla-get-closed vla-obj) :vlax-false))
          (setq startpoint '(0 0 0) endpoint '(0 0 0)));(alert "\n請注意!****串接不線不能封閉!")
    )
  (if (> j 1000)(prompt (strcat "\n恭喜你一共把" (itoa (+ (* 2 j) 3)) "條線串接成了一個封閉的復線!")))
  )
执行LINKLINE....

PFD8667

舟自横您好!
谢谢您的帮助,不好意思我没讲清楚,我一点都不懂编程,我每一条线都是单独的直线,但也各自相连的,这是一个展开图,形成后,将中间的线全部删除,形成一个轮廓图形,再创建成多义线或面域,但按您的思路编程,好像更复杂化了,我原这需用直线命令连接上就可以了,但现在却要
1...取得所有顶点做成一个列表
2...按奇偶数分为两个列表
请教能不能按我能一次或分上下二次就形成如图2的线段所示编个程,因而提高工作效率.

舟自横

我说的是编程的思路不是让你操作的方法
你可以先用一下我的程序看就知道了...
应该没问题..
具体方法:
1...先加载程序..相信你会吧
2...执行LINKLINE命令如果你不喜欢这个命令可以自己改
3..点选其中任何一段线,就可以了,程序就会帮你把线连好了....

PFD8667

先谢谢您的热心帮助,我将程序试了还是不行,不好意思,麻烦您帮再修改一下吧?我将需连的线的图传上.

ljpnb

(foreach itemx (ap-sslist ssn)中的ap-sslist函数在哪儿?

舟自横

哦,不好意思漏了一个,补上就好了!!
一起加载

狂刀

牛刀小试，就拿你这个题目来祭旗。
[php]
(defun c:zko (/ i pt i pts1 pts2 pts)
  (vl-cmdf ".undo" "be")
  (princ "\n 求多条首尾相接的线条展开图的轮廓--------by 狂刀.2005.4")
  (vl-cmdf ".pedit" "m" (ssget) "" "Y" "J" 1e-2 "")
  (setq i 0
        o (vlax-ename->vla-object(entlast)))
  (while (not(vl-catch-all-error-p(setq pt(vl-catch-all-apply 'vla-get-coordinate (list o i)))))
    (setq pt (vlax-safearray->list (vlax-variant-value pt)))
    (if (= 0 (rem i 2))
      (setq pts1 (cons pt pts1))
      (setq pts2 (cons pt pts2))
    )
    (setq i (1+ i))
  )
  (setq pts (append (reverse pts1) pts2))
  (vl-cmdf ".U")
  (vl-cmdf ".pline")
  (mapcar 'vl-cmdf pts)
  (vl-cmdf "cl")
  (vl-cmdf ".undo" "e")
  (princ)
)
[/php]

PFD8667

太谢谢狂刀兄了,您真是编程高手,也真正是狂刀,您真叫我高兴的发狂编的程序太好用了,我在这图形一扫,回车就形成了多段线的轮廓了,又省了我下一步形成多段线的步骤,再次表示感谢!
在此也对舟自横您表示谢意,您的程序,不知为什么我总是下不了载,我会再找时间下载,用后回复您对我的帮助.
总算下载了,不好意思,还是不行,但还是谢谢您的热心了.