[LISP程序]：请高手帮忙诊断一下这个程序,老出问题.

shona521 · 发表于 2007-10-2 22:19:29

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

请高手帮忙诊断一下这个程序,老出问题.本人学lsp不深,请大虾们多多指点.(注明:此程序借鉴了网上资料,出处不详了,如原作者见到,还望指点).

[FONT=courier new]
;;主要思路：将pl图层上的多条pline线每条最长的一段两端加钩,其余的删除。
(defun c:BZG ()
(SSBDJ)
(BZGz)
(prin1)
)
(defun xdd1(/ eobj i leng pt0 pt1)
((setq eobj (vlax-ename->vla-object ssn))
i -1
Leng-max 0
)
(while (setq pt0 (vlax-curve-getPointAtParam eobj (setq i (1+ i))))
(if (setq pt1 (vlax-curve-getPointAtParam eobj (setq k (1+ i))))
(progn
(setq Leng (distance pt0 pt1))
(if (> leng leng-max)
(setq ptmax0 pt0
ptmax1 pt1
leng-max leng
)
)
)
)
)
)
(defun SSBDJ(/ old_wid wid width ssbdj)
(setvar "cmdecho" 0)
(setq old_wid (getvar "PLINEWID")) ;线宽度(默认为图中默认PLINEWID值)
(setq wid (strcat "\n 请输入线宽度<" (rtos old_wid 2) ">: "))
(setq width (getdist wid))
(if (null width) (setq width old_wid))
(prompt "\n\t选择加钩的pline线<退出> : ")
(setq ssgj (ssget '((8 . "pl" )) )) ;图层为pl的线才加
)
(defun BZGz ()
(setq n 0)
(while (< n (sslength ssgj))
(setq ssn (ssname ssgj n))
(setq ssdata (entget ssn))
(setq sstyp (cdr (assoc 0 ssdata)))
(if (= sstyp "LWPOLYLINE")
(progn
(xdd1)
(setq ang (angle ptmax0 ptmax1))
(setq pp1 (polar ptmax0 ( + (* pi 0.25) ang) 150))
(setq pp2 (polar ptmax1 ( + (* pi 0.75) ang) 150))
(command "pline" pp1 "w" width width ptmax0 ptmax1 pp2"")
(command "erase" (car ssn) "" ) ;将选中的pline删除
)
)
(setq n (1+ n))
);end while
(prin1)
)
[/FONT]

[FONT=courier new] 
;;主要思路：将pl图层上的多条pline线每条最长的一段两端加钩,其余的删除。 
(defun c:BZG () 
   (SSBDJ) 
   (BZGz) 
  (prin1) 
) 
                
(defun xdd1(/ eobj i leng pt0 pt1) 
  ((setq eobj (vlax-ename->vla-object ssn)) 
        i    -1 
    Leng-max 0 
  )   
  (while (setq pt0 (vlax-curve-getPointAtParam eobj (setq i (1+ i)))) 
    (if    (setq pt1 (vlax-curve-getPointAtParam eobj (setq k (1+ i)))) 
      (progn 
    (setq Leng (distance pt0 pt1)) 
    (if (> leng leng-max) 
       (setq    ptmax0 pt0 
        ptmax1 pt1 
        leng-max leng 
      )    
    ) 
      ) 
    ) 
  ) 
) 
 
 
(defun SSBDJ(/ old_wid wid width ssbdj)   
  (setvar "cmdecho" 0) 
  (setq old_wid (getvar "PLINEWID")) ;线宽度(默认为图中默认PLINEWID值) 
  (setq wid (strcat "\n 请输入线宽度<" (rtos old_wid 2) ">: ")) 
  (setq width (getdist wid)) 
  (if (null width) (setq width old_wid)) 
  (prompt "\n\t选择加钩的pline线<退出> : ") 
  (setq ssgj (ssget '((8 . "pl" )) )) ;图层为pl的线才加 
) 
 
(defun BZGz () 
  (setq n 0) 
  (while (< n (sslength ssgj)) 
       
      (setq ssn (ssname ssgj  n)) 
      (setq ssdata (entget ssn))       
      (setq sstyp (cdr (assoc 0 ssdata))) 
      (if (= sstyp "LWPOLYLINE") 
        (progn 
          (xdd1) 
      (setq ang (angle ptmax0 ptmax1)) 
      (setq pp1 (polar ptmax0 ( + (* pi 0.25) ang) 150)) 
      (setq pp2 (polar ptmax1 ( + (* pi 0.75) ang) 150)) 
         
      (command "pline" pp1 "w" width width ptmax0 ptmax1 pp2"") 
      (command "erase" (car ssn) "" )   ;将选中的pline删除 
        ) 
      ) 
  (setq n (1+ n)) 
  );end while 
  (prin1) 
   
)   
  [/FONT]

Free-Lancer · 发表于 2007-10-3 00:06:55

应该这样写

(defun c:tt (/ old_wid width ss ssl i e el pts pdl ptl p1 p2 p3 p4 an
lay)
(setq old_wid (getvar "PLINEWID")
width (getdist (strcat "\n 请输入线宽度<" (rtos old_wid 2) ">: "))
)
(if (null width)
(setq width old_wid)
)
(prompt "\n\t选择加钩的pline线<退出> : ")
(if (setq ss (ssget '((0 . "LWPOLYLINE"))))
(progn
(setq ssl (sslength ss)
i -1
)
(repeat ssl
(setq e (ssname ss (setq i (1+ i)))
el (entget e)
pts (mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) el)
)
ptl (mapcar
'(lambda (x) (list (car x) (cadr x)))
(cdar (vl-sort
(mapcar '(lambda (a b) (list (distance a b) a b))
pts
(cdr pts)
)
'(lambda (e1 e2) (> (car e1) (car e2)))
)
)
)
p2 (car ptl)
p3 (cadr ptl)
an (angle p2 p3)
p1 (polar p2 (+ (* pi 0.25) an) 150)
p4 (polar p3 (+ (* pi 0.75) an) 150)
lay (assoc 8 el)
)
(entmake (append '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(90 . 4)
(70 . 0)
)
(list (cons 43 width) lay)
(list (cons 10 p1)
(cons 10 p2)
(cons 10 p3)
(cons 10 p4)
)
)
)
(entdel e)
)
)
)
(princ)
)

(defun c:tt (/ old_wid width ss        ssl i e        el pts pdl ptl p1 p2 p3        p4 an 
             lay) 
  (setq        old_wid        (getvar "PLINEWID") 
        width        (getdist (strcat "\n 请输入线宽度<" (rtos old_wid 2) ">: ")) 
  ) 
  (if (null width) 
    (setq width old_wid) 
  ) 
  (prompt "\n\t选择加钩的pline线<退出> : ") 
  (if (setq ss (ssget '((0 . "LWPOLYLINE")))) 
    (progn 
      (setq ssl        (sslength ss) 
            i        -1 
      ) 
      (repeat ssl 
        (setq e          (ssname ss (setq i (1+ i))) 
              el  (entget e) 
              pts (mapcar 'cdr 
                          (vl-remove-if-not '(lambda (x) (= (car x) 10)) el) 
                  ) 
              ptl (mapcar 
                    '(lambda (x) (list (car x) (cadr x))) 
                    (cdar (vl-sort 
                            (mapcar '(lambda (a b) (list (distance a b) a b)) 
                                    pts 
                                    (cdr pts) 
                            ) 
                            '(lambda (e1 e2) (> (car e1) (car e2))) 
                          ) 
                    ) 
                  ) 
              p2  (car ptl) 
              p3  (cadr ptl) 
              an  (angle p2 p3) 
              p1  (polar p2 (+ (* pi 0.25) an) 150) 
              p4  (polar p3 (+ (* pi 0.75) an) 150) 
              lay (assoc 8 el) 
        ) 
        (entmake (append '((0 . "LWPOLYLINE") 
                           (100 . "AcDbEntity") 
                           (100 . "AcDbPolyline") 
                           (90 . 4) 
                           (70 . 0) 
                          ) 
                         (list (cons 43 width) lay) 
                         (list (cons 10 p1) 
                               (cons 10 p2) 
                               (cons 10 p3) 
                               (cons 10 p4) 
                         ) 
                 ) 
        ) 
        (entdel e) 
      ) 
    ) 
  ) 
  (princ) 
)

shona521 · 发表于 2007-10-3 09:34:37

多谢Free-Lancer 指点,你的代码是通过修改pline线的顶点实现的,如果要在两端加弧形的pline,不知道要怎么样实现?

Free-Lancer · 发表于 2007-10-3 11:10:21

当然可以, 增加一个凸度而已

shona521 · 发表于 2007-10-3 11:29:01

谢谢Free-Lancer热心解答.已经解决.

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

[LISP程序]：请高手帮忙诊断一下这个程序,老出问题.

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子