查斜线程序的缺陷改进

s678z

画图时稍不当心会把正交线画得稍微斜一点点，肉眼看不清楚，标注尺寸时会发觉出现小数点，下面的程序可以查斜线，但有部分正交线也被当成斜线打成红色，请高手帮忙再改进，附件是测试用图纸。
(defun c:bias()
   (setq ss_first (ssget "X" '((0 . "line"))))
   
   (setq n 0)
   (setq ss_kill (ssadd))
   (while (< n (sslength ss_first))
      (setq en (ssname ss_first n))
      (setq en_data (entget en))
      (setq pt_st (cdr (assoc 10 en_data)))
      (setq pt_en (cdr (assoc 11 en_data)))
      (setq ang (/ (* 180 (angle pt_st pt_en)) pi))
    (if (and (/= ang 0) (equal ang 0 0.3))
       (ssadd en ss_kill)
        )
    (if (and (/= ang 90) (equal ang 90 0.3))
       (ssadd en ss_kill)
        )
     (if (and (/= ang 180) (equal ang 180 0.3))
       (ssadd en ss_kill)
        )
    (if (and (/= ang 270) (equal ang 270 0.3))
       (ssadd en ss_kill)
        )
     (if (and (/= ang 360) (equal ang 360 0.3))
       (ssadd en ss_kill)
        )
      (setq n (1+ n))
   
   )
   (if ss_kill
    (progn
      (command "_.chprop" ss_kill "" "c" 1 "")
      (princ (strcat "\n------------- 有\t" (itoa (sslength ss_kill)) "  条斜线。"))
     )
     (princ "\n没有斜线!")
    )
)

菜卷鱼

1. (defun c:bias()  
   
2.    (setq ss_first (ssget "X" '((0 . "line"))))
   
3.    (setq n 0)
   
4.    (setq ss_kill (ssadd))
   
5. (while (< n (sslength ss_first))
   
6.       (setq en (ssname ss_first n))
   
7.       (setq en_data (entget en))
   
8.       (setq pt_st (cdr (assoc 10 en_data)))
   
9.       (setq x1 (car pt_st) y1 (cadr pt_st))
   
10.       (setq pt_en (cdr (assoc 11 en_data)))
    
11.       (setq x2 (car pt_en) y2 (cadr pt_en))
    
12. (if
    
13. (or (= "0" (rtos (- y2 y1)) ) (= "0" (rtos (- x2 x1)) ) )
    
14. (setq n (1+ n))
    
15. (progn (ssadd en ss_kill)(setq n (1+ n))
    
16. ))
    
17. )
    
18.    (if (/= 0 (sslength ss_kill))
    
19.     (progn
    
20.       (setvar "cmdecho" 0)
    
21.       (command "_.chprop" ss_kill "" "c" 1 "")
    
22.       (setvar "cmdecho" 1)
    
23.       (mapcar  'princ (list "\n------------- 有\t" (sslength ss_kill) "  条斜线。"))
    
24.      )
    
25.      (alert "\n没有斜线!")
    
26.     )
    
27. (prin1)
    
28. )
    

(defun c:bias()  <br />    (setq ss_first (ssget "X" '((0 . "line"))))<br />    (setq n 0)<br />    (setq ss_kill (ssadd))<br /> (while (< n (sslength ss_first))<br />       (setq en (ssname ss_first n))<br />       (setq en_data (entget en))<br />       (setq pt_st (cdr (assoc 10 en_data)))<br />       (setq x1 (car pt_st) y1 (cadr pt_st))<br />       (setq pt_en (cdr (assoc 11 en_data)))<br />       (setq x2 (car pt_en) y2 (cadr pt_en))<br /> (if <br /> (or (= "0" (rtos (- y2 y1)) ) (= "0" (rtos (- x2 x1)) ) ) <br /> (setq n (1+ n))<br /> (progn (ssadd en ss_kill)(setq n (1+ n))<br /> ))<br /> )<br />    (if (/= 0 (sslength ss_kill))<br />     (progn<br />       (setvar "cmdecho" 0)<br />       (command "_.chprop" ss_kill "" "c" 1 "")<br />       (setvar "cmdecho" 1)<br />       (mapcar  'princ (list "\n------------- 有\t" (sslength ss_kill) "  条斜线。"))<br />      )<br />      (alert "\n没有斜线!")<br />     )<br /> (prin1)<br /> )<br />

菜卷鱼

这下应该解决了吧

s678z

菜卷鱼 发表于 2013-12-11 10:57
这下应该解决了吧

改进后查斜线程序检查的dwg图纸见附件，图中部分斜线没显示，但直线已经没有被误为斜线，这已经改进了，另外，查出的斜线能否另外建个图层，以便和正常的线条颜色区别开来，感谢网友的帮忙。

菜卷鱼

单独设置图层的话就把 (command "_.chprop" ss_kill "" "c" 3 "")  改成  (command "_.chprop" ss_kill "" "c" 3 "LA" "斜线的图层" "")，
部分斜线没显示出来就是斜线的角度超过了0.3，你就把(/ pi 600)中的 600改小一点，(/ pi 600)就是0.3°，就是把0.3改大一点

chenming10

菜卷鱼 发表于 2013-12-16 08:44
单独设置图层的话就把 (command "_.chprop" ss_kill "" "c" 3 "")  改成  (command "_.chprop" ss_kill ""  ...

能不能支持多义线呀。。那要怎样修改呢？

菜卷鱼

chenming10 发表于 2013-12-16 09:33
能不能支持多义线呀。。那要怎样修改呢？

我也是菜鸟，多义线的话要找高手，是我自己的话我会把多义线炸开

s678z

菜卷鱼 发表于 2013-12-16 08:44
单独设置图层的话就把 (command "_.chprop" ss_kill "" "c" 3 "")  改成  (command "_.chprop" ss_kill ""  ...

查斜线程序已好用，这个问题你看看有无办法http://bbs.mjtd.com/thread-108134-1-1.html