如何将选择的线段结合成pl线呢(已经解决)并执行vba的程序？(新手跪求)

qcw911 · 发表于 2011-10-17 18:35:01

本帖最后由 qcw911 于 2011-10-20 19:42 编辑

复制代码

(defun c:tt (/ gxl-Sel-ReDrawSel
gxl-Sel-SSsub gxl-Sel-SSJoin
gxl-sel-SSgetLineatPoint
getline
)
(defun gxl-Sel-ReDrawSel (Sel mode / m n)
(setq m (sslength Sel)
n 0
)
(repeat m
(redraw (ssname Sel n) mode)
(setq n (1+ n))
) ;repeat
)
(defun gxl-Sel-SSsub (ss1 ss2 / ss n)
(cond
((and ss1 ss2)
(setq n 0)
(repeat (sslength ss2)
(ssdel (ssname ss2 n) ss1)
(setq n (1+ n))
)
)
((and ss1 (not ss2))
ss1
)
(T
(setq ss1 nil)
)
)
ss1
)
(defun gxl-Sel-SSJoin (ss1 ss2 / ename ss cnt)
(if ss1
(progn
(if (= (type ss1) 'ENAME)
(progn
(setq
ename ss1
ss1 (ssadd)
)
(ssadd ename ss1)
)
)
)
)
(if ss2
(progn
(if (= (type ss2) 'ENAME)
(progn
(setq
ename ss2
ss2 (ssadd)
)
(ssadd ename ss2)
)
)
)
)
(setq ss (ssadd))
(if (and ss1 ss2)
(progn
;(setq ss ss2 cnt 0)
(setq cnt 0)
(repeat (sslength ss2)
(ssadd (ssname ss2 cnt) ss)
(setq cnt (1+ cnt))
)
(setq cnt 0)
(repeat (sslength ss1)
(ssadd (ssname ss1 cnt) ss)
(setq cnt (1+ cnt))
)
)
)
(if (and ss1 (not ss2))
(setq ss ss1)
)
(if (and ss2 (not ss1))
(setq ss ss2)
)
(if (> (sslength ss) 0)
;;(eval ss)
ss
nil
)
)
(defun gxl-sel-SSgetLineatPoint (pt jd / px py px0 px1 py0 py1 ss pz)
(setq px (car pt)
px0 (- px jd)
px1 (+ px jd)
py (cadr pt)
py0 (- py jd)
py1 (+ py jd)
pz (caddr pt)
)
(setq ss
(ssget "x"
(list '(0 . "line")
'(-4 . "<or")
'(-4 . "<and")
'(-4 . ">=,>=,=")
(list 10 px0 py0 pz)
'(-4 . "<=,<=,=")
(list 10 px1 py1 pz)
'(-4 . "and>")
'(-4 . "<and")
'(-4 . ">=,>=,=")
(list 11 px0 py0 pz)
'(-4 . "<=,<=,=")
(list 11 px1 py1 pz)
'(-4 . "and>")
'(-4 . "or>")
)
)
)
(if ss
(GXL-SEL-REDRAWSEL ss 3)
)
ss
)
(defun getline (pt jd / s s1 n p1 p2)
(setq s (gxl-sel-SSgetLineatPoint pt jd))
(if s
(progn
(setq s1 (GXL-SEL-SSSUB s ssrtl)
ssrtl (GXL-SEL-SSJOIN ssrtl s1)
)
(if s1
(progn
(setq n 0)
(repeat (sslength s1)
(setq p1 (cdr (assoc 10 (entget (ssname s1 n))))
p2 (cdr (assoc 11 (entget (ssname s1 n))))
)
(getline p2 jd)
(getline p1 jd)
(setq n (1+ n))
)
)
)
)
)
)
(defun jion (/ ss s)
(setq ss (ssget '((-4 . "<OR")
(0 . "LINE")
(0 . "ARC")
(-4 . "<AND")
(0 . "LWPOLYLINE")
(70 . 0)
(-4 . "AND>")
(-4 . "OR>")
)
)
)
(while ss
(setq s (ssname ss 0))
(if (or (= "LINE" (cdr (assoc 0 (entget s))))
(= "ARC" (cdr (assoc 0 (entget s))))
)
(command "pedit" s "y" "j" "p" "" "x")
(command "pedit" s "j" "p" "" "x")
)
(setq ss (ssget "p"))
)
(princ)
)
;;;程序开始
(princ "\n选择直线")
(setq enline (car (entsel)))
(initget 5 " ")
;;; (setq jd (getreal "精确度<0.001>"))
;;; (if (= jd "")
(setq jd 0.001)
;;; )
(setq pt1 (cdr (assoc 10 (entget enline))))
(setq pt2 (cdr (assoc 11 (entget enline))))
(setq ssrtl (ssadd enline))
(getline pt1 jd)
(getline pt2 jd)
(sssetfirst nil ssrtl)
(jion)
;;; ssrtl
)

(defun c:tt (/         gxl-Sel-ReDrawSel 
       gxl-Sel-SSsub     gxl-Sel-SSJoin 
       gxl-sel-SSgetLineatPoint 
       getline 
      ) 
  (defun gxl-Sel-ReDrawSel (Sel mode / m n) 
    (setq m (sslength Sel) 
    n 0 
    ) 
    (repeat m 
      (redraw (ssname Sel n) mode) 
      (setq n (1+ n)) 
    )          ;repeat 
  ) 
  (defun gxl-Sel-SSsub (ss1 ss2 / ss n) 
    (cond 
      ((and ss1 ss2) 
       (setq n 0) 
       (repeat (sslength ss2) 
   (ssdel (ssname ss2 n) ss1) 
   (setq n (1+ n)) 
       ) 
      ) 
      ((and ss1 (not ss2)) 
       ss1 
      ) 
      (T 
       (setq ss1 nil) 
      ) 
    ) 
    ss1 
  ) 
  (defun gxl-Sel-SSJoin  (ss1 ss2 / ename ss cnt) 
    (if  ss1 
      (progn 
  (if (= (type ss1) 'ENAME) 
    (progn 
      (setq 
        ename ss1 
        ss1   (ssadd) 
      ) 
      (ssadd ename ss1) 
    ) 
  ) 
      ) 
    ) 
    (if  ss2 
      (progn 
  (if (= (type ss2) 'ENAME) 
    (progn 
      (setq 
        ename ss2 
        ss2   (ssadd) 
      ) 
      (ssadd ename ss2) 
    ) 
  ) 
      ) 
    ) 
    (setq ss (ssadd)) 
    (if  (and ss1 ss2) 
      (progn 
  ;(setq ss ss2 cnt 0) 
  (setq cnt 0) 
  (repeat  (sslength ss2) 
    (ssadd (ssname ss2 cnt) ss) 
    (setq cnt (1+ cnt)) 
  ) 
  (setq cnt 0) 
  (repeat  (sslength ss1) 
    (ssadd (ssname ss1 cnt) ss) 
    (setq cnt (1+ cnt)) 
  ) 
      ) 
    ) 
    (if  (and ss1 (not ss2)) 
      (setq ss ss1) 
    ) 
    (if  (and ss2 (not ss1)) 
      (setq ss ss2) 
    ) 
    (if  (> (sslength ss) 0) 
      ;;(eval ss) 
      ss 
      nil 
    ) 
  ) 
  (defun gxl-sel-SSgetLineatPoint (pt jd / px py px0 px1 py0 py1 ss pz) 
    (setq px  (car pt) 
    px0 (- px jd) 
    px1 (+ px jd) 
    py  (cadr pt) 
    py0 (- py jd) 
    py1 (+ py jd) 
    pz  (caddr pt) 
    ) 
    (setq ss 
     (ssget "x" 
      (list  '(0 . "line") 
      '(-4 . "<or") 
 
      '(-4 . "<and") 
      '(-4 . ">=,>=,=") 
      (list 10 px0 py0 pz) 
      '(-4 . "<=,<=,=") 
      (list 10 px1 py1 pz) 
      '(-4 . "and>") 
 
      '(-4 . "<and") 
      '(-4 . ">=,>=,=") 
      (list 11 px0 py0 pz) 
      '(-4 . "<=,<=,=") 
      (list 11 px1 py1 pz) 
      '(-4 . "and>") 
 
      '(-4 . "or>") 
      ) 
     ) 
    ) 
    (if  ss 
      (GXL-SEL-REDRAWSEL ss 3) 
 
    ) 
    ss 
  ) 
  (defun getline (pt jd / s s1 n p1 p2) 
 
    (setq s (gxl-sel-SSgetLineatPoint pt jd)) 
    (if  s 
      (progn 
  (setq s1    (GXL-SEL-SSSUB s ssrtl) 
        ssrtl (GXL-SEL-SSJOIN ssrtl s1) 
  ) 
 
  (if s1 
    (progn 
      (setq n 0) 
      (repeat (sslength s1) 
        (setq p1 (cdr (assoc 10 (entget (ssname s1 n)))) 
        p2 (cdr (assoc 11 (entget (ssname s1 n)))) 
        ) 
        (getline p2 jd) 
        (getline p1 jd) 
        (setq n (1+ n)) 
      ) 
    ) 
  ) 
      ) 
    ) 
 
  ) 
 
 
  (defun jion (/ ss s) 
    (setq ss (ssget '((-4 . "<OR") 
          (0 . "LINE") 
          (0 . "ARC") 
          (-4 . "<AND") 
          (0 . "LWPOLYLINE") 
          (70 . 0) 
          (-4 . "AND>") 
          (-4 . "OR>") 
         ) 
       ) 
    ) 
    (while ss 
      (setq s (ssname ss 0)) 
      (if (or (= "LINE" (cdr (assoc 0 (entget s)))) 
        (= "ARC" (cdr (assoc 0 (entget s)))) 
    ) 
  (command "pedit" s "y" "j" "p" "" "x") 
  (command "pedit" s "j" "p" "" "x") 
      ) 
      (setq ss (ssget "p")) 
    ) 
    (princ) 
  ) 
 
;;;程序开始 
  (princ "\n选择直线") 
  (setq enline (car (entsel))) 
  (initget 5 "  ") 
;;;  (setq jd (getreal "精确度<0.001>")) 
;;;  (if (= jd "") 
  (setq jd 0.001) 
;;;  ) 
  (setq pt1 (cdr (assoc 10 (entget enline)))) 
  (setq pt2 (cdr (assoc 11 (entget enline)))) 
  (setq ssrtl (ssadd enline)) 
  (getline pt1 jd) 
  (getline pt2 jd) 
  (sssetfirst nil ssrtl) 
  (jion) 
 
 
 
 
;;;  ssrtl 
)

上面是GL_xl版主写的，选择一条直线，相邻的线段都选择

怎样修改，将选择后的线段结合成pl线呢？不知道在哪里修改.

还有

我公司用vba编写了程序

命令行过程是这样的 vbastmt

(setvar “filetrad” 200)

Ckcase 用户选择线段

我编写是 (command “vbastmt”)

(setvar “filetrad” 200)

(command “ckcase” pasue)

这样行吗？

我也不知道改到那里

请大侠们帮帮忙

ljttjl · 发表于 2011-10-17 23:33:20

pedit命令就可以实现。

qcw911 · 发表于 2011-10-18 08:17:37

本帖最后由 qcw911 于 2011-10-18 08:17 编辑

ljttjl 发表于 2011-10-17 23:33
pedit命令就可以实现。

我是新手
这个我知道
如何修改呢
帮帮忙

ljttjl · 发表于 2011-10-18 22:23:50

查看autocad命令帮助文件

qcw911 · 发表于 2011-10-19 08:59:16

本帖最后由 qcw911 于 2011-10-19 09:00 编辑

ljttjl 发表于 2011-10-18 22:23
查看autocad命令帮助文件

这个是我找到的程序
但是结合VBA就不行了

命令行过程是这样的 vbastmt

(setvar “filetrad” 200)

Ckcase 用户选择线段

我编写是 (command “vbastmt”)

(setvar “filetrad” 200)

(command “ckcase” pasue)

这样行吗？

插写在那里

(vl-load-com)
(defun gotonexten (en pt / box en2 en2lst ep i sp ss)
(setq box (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
(getvar "viewsize")
)
)
(setq ss (ssget "c"
(mapcar '- pt (list box box))
(mapcar '+ pt (list box box))
)
)
(if ss
(progn
(ssdel en ss)
(setq i 0)
(while (setq en2 (ssname ss i))
(setq i (1+ i))
(setq
sp (vl-catch-all-apply 'vlax-curve-getStartPoint (list en2))
)
(if (listp sp)
(progn (setq ep (vlax-curve-getEndPoint en2))
(cond ((equal sp pt 1e-8)
(setq en2lst (cons (list en2 ep) en2lst))
)
((equal ep pt 1e-8)
(setq en2lst (cons (list en2 sp) en2lst))
)
)
)
)
)
)
)
en2lst
)
;楢銛楢慄c:ss-----fsxm 2007/01/29
(defun c:ss (/ en enp ept spt ss addnext)
(if (and (setq enp (entsel))
(ssget (cadr enp) '((0 . "*line,arc,circle,ellipse")))
)
(progn
(setq en (car enp))
(setq spt (vlax-curve-getStartPoint en))
(setq ept (vlax-curve-getendPoint en))
(setq ss (ssadd))
(ssadd en ss)
(defun addnext (en pt / next)
(if (setq next (gotonexten en pt))
(foreach a next
(if (not (ssmemb (car a) ss))
(progn (ssadd (car a) ss)
(apply 'addnext a)
)
)
)
)
)
(addnext en spt)
(addnext en ept)
(if (= 0 (getvar "cmdactive"))
(sssetfirst nil ss)
)
ss
(jion)
)
(progn
(princ "\n枹?庢?徾埥?庢椆旕curve?宆?徾!")
(princ)
)
)
)
(defun jion (/ ss s)
(setq ss (ssget '((-4 . "<OR")
(0 . "LINE")
(0 . "ARC")
(-4 . "<AND")
(0 . "LWPOLYLINE")
(70 . 0)
(-4 . "AND>")
(-4 . "OR>")
)
)
)
(while ss
(setq s (ssname ss 0))
(if (or (= "LINE" (cdr (assoc 0 (entget s))))
(= "ARC" (cdr (assoc 0 (entget s))))
)
(command "pedit" s "y" "j" "p" "" "x")
(command "pedit" s "j" "p" "" "x")
)
(setq ss (ssget "p"))
)
(princ)
)

(vl-load-com) 
(defun gotonexten (en pt / box en2 en2lst ep i sp ss) 
  (setq        box (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) 
               (getvar "viewsize") 
            ) 
  ) 
  (setq        ss (ssget "c" 
                  (mapcar '- pt (list box box)) 
                  (mapcar '+ pt (list box box)) 
           ) 
  ) 
  (if ss 
    (progn 
      (ssdel en ss) 
      (setq i 0) 
      (while (setq en2 (ssname ss i)) 
        (setq i (1+ i)) 
        (setq 
          sp (vl-catch-all-apply 'vlax-curve-getStartPoint (list en2)) 
        ) 
        (if (listp sp) 
          (progn (setq ep (vlax-curve-getEndPoint en2)) 
                 (cond ((equal sp pt 1e-8) 
                        (setq en2lst (cons (list en2 ep) en2lst)) 
                       ) 
                       ((equal ep pt 1e-8) 
                        (setq en2lst (cons (list en2 sp) en2lst)) 
                       ) 
                 ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  en2lst 
) 
;楢銛楢慄c:ss-----fsxm  2007/01/29 
 
 
(defun c:ss (/ en enp ept spt ss addnext) 
  (if (and (setq enp (entsel)) 
           (ssget (cadr enp) '((0 . "*line,arc,circle,ellipse"))) 
      ) 
    (progn 
      (setq en (car enp)) 
      (setq spt (vlax-curve-getStartPoint en)) 
      (setq ept (vlax-curve-getendPoint en)) 
      (setq ss (ssadd)) 
      (ssadd en ss) 
      (defun addnext (en pt / next) 
        (if (setq next (gotonexten en pt)) 
          (foreach a next 
            (if        (not (ssmemb (car a) ss)) 
              (progn (ssadd (car a) ss) 
                     (apply 'addnext a) 
              ) 
            ) 
          ) 
        ) 
      ) 
      (addnext en spt) 
      (addnext en ept) 
      (if (= 0 (getvar "cmdactive")) 
        (sssetfirst nil ss) 
      ) 
      ss 
      (jion) 
    ) 
    (progn 
      (princ "\n枹?庢?徾埥?庢椆旕curve?宆?徾!") 
      (princ) 
    ) 
  ) 
) 
 
(defun jion (/ ss s) 
  (setq        ss (ssget '((-4 . "<OR") 
                    (0 . "LINE") 
                    (0 . "ARC") 
                    (-4 . "<AND") 
                    (0 . "LWPOLYLINE") 
                    (70 . 0) 
                    (-4 . "AND>") 
                    (-4 . "OR>") 
                   ) 
           ) 
  ) 
  (while ss 
    (setq s (ssname ss 0)) 
    (if        (or (= "LINE" (cdr (assoc 0 (entget s)))) 
            (= "ARC" (cdr (assoc 0 (entget s)))) 
        ) 
      (command "pedit" s "y" "j" "p" "" "x") 
      (command "pedit" s "j" "p" "" "x") 
    ) 
    (setq ss (ssget "p")) 
  ) 
  (princ) 
)

qcw911 · 发表于 2011-10-20 08:36:06

跪求，那位高手能来相助啊

qcw911 · 发表于 2011-10-20 19:47:45

帖子快沉了，是不是我没说明白啊？

账号		自动登录	找回密码
密码			注册