画正牙孔程序.lsp

726613

                            图一



                              图二

(defun c:Ar (/)
  (setvar "cmdecho" 0)
  (setq M (getDIST "\n-->请输入正牙孔M?<8>:"))
  (if (= M nil) (setq M 8))
  (cond ((= M 16) (progn (SETQ c 16.0) (setq d 14.5)))
        ((= M 14) (progn (SETQ c 14.0) (setq d 12.5)))
        ((= M 12) (progn (SETQ c 12.0) (setq d 10.5)))
        ((= M 10) (progn (SETQ c 10.0) (setq d 8.5)))
        ((= M 8)  (progn (SETQ c 8.0)  (setq d 6.9)))
        ((= m 6) (progn (SETQ c 6.0)  (setq d 5.1)))
        ((= m 5) (progn (SETQ c 5.0)  (setq d 4.3)))
        ((= M 4) (progn (SETQ c 4.0)  (setq d 3.4)))
        ((= M 3) (progn (SETQ c 3.0)  (setq d 2.5))))  
    (SETQ PT (GETPOINT "\n-->请选取插入点:"))
      (while pt
          (command "circle" pt (/ d 2) "")
          (command "circle" pt (/ c 2) "")
             (command "break"(entlast) "none" "@0.5,-2" "none" "@3,3")   
             (command "line" "none" "@-8.5,-1" "none" "@10,0" "")
             (command "change"(entlast) "" "p" "lt" "center" "lts"1 "" "")
             (command "line" "none" "@-5,-5" "none" "@0,10" "")
             (command "change"(entlast) "" "p" "lt" "center" "lts"1 "" "")
     (setq pt (getpoint "\n-->请选取插入点:")))
(princ)
)

此程序还须进一步完善一下，如何修改才能达到图二，请高手指点迷津，谢谢。

726613

补充附件

726613

有人会修改程序吗？

lincctw_ccl

(command "line" "none" "@-8.5,-1" "none" "@10,0" "")
(command "line" "none" "@-5,-5" "none" "@0,10" "")
改上面这两段
自己试试便知该如何改了
很有 显的这两段是 划 中心线的!!!

726613

lincctw_ccl 发表于 2013-4-15 01:04
(command "line" "none" "@-8.5,-1" "none" "@10,0" "")
(command "line" "none" "@-5,-5" "none" "@0,10" ...

谢谢你指点

726613

此程序的缺点是
     A、画M3、M4、M5、M6的十字中心线过长；
     B、画M10、M12、M14、M16的十字中心线太短。

              请高手指点迷津

ZZXXQQ

1. (defun c:SAr (/)
   
2. (setvar "CMDECHO" 0)
   
3. (setq M (getDIST "\n-->请输入正牙孔M?<8>:"))
   
4. (if (= M nil) (setq M 8))
   
5. (cond
   
6.   ((<= 2 M 3) (SETQ c 3.0 d 2.5))
   
7.   ((<= 3.1 M 4) (SETQ c 4.0 d 3.4))
   
8.   ((<= 4.1 m 5) (SETQ c 5.0 d 4.3))
   
9.   ((<= 5.1 m 6) (SETQ c 6.0 d 5.1))
   
10.   ((<= 6.1 M 8) (SETQ c 8.0 d 6.9))
    
11.   ((<= 8.1 M 10) (SETQ c 10.0 d 8.5))
    
12.   ((<= 10.1 M 12) (SETQ c 12.0 d 10.5))
    
13.   ((<= 12.1 M 14) (SETQ c 14.0 d 12.5))
    
14.   ((<= 14.1 M 16) (SETQ c 16.0 d 14.5))
    
15. )
    
16. (while (SETQ PT (GETPOINT "\n-->请选取插入点:"))
    
17.   (setq p1 (polar pt (/ pi -6) (/ c 2))
    
18.         p2 (polar pt (/ pi 3) (/ c 2))
    
19.         p3 (polar pt 0 (+ (/ c 2) 3));比直径长6
    
20.         p4 (polar pt pi (+ (/ c 2) 3))
    
21.         p5 (polar pt (/ pi 2) (+ (/ c 2) 3))
    
22.         p6 (polar pt (/ pi -2) (+ (/ c 2) 3)))
    
23.   (command "_.CIRCLE" "none" pt (/ d 2) "_.ARC" "none" p2 "C" "none" pt "none" p1)
    
24.   (command "_.LINE" "none" p3 "none" p4 "" "_.CHPROP" "L" "" "lt" "center" "lts" 1 "")
    
25.   (command  "_.LINE" "none" p5 "none" p6 "" "_.CHPROP" "L" "" "lt" "center" "lts" 1 "")
    
26. )
    
27. (setvar "CMDECHO" 1)
    
28. (princ)
    
29. )
    

(defun c:SAr (/)<br /> (setvar "CMDECHO" 0)<br /> (setq M (getDIST "\n-->请输入正牙孔M?<8>:")) <br /> (if (= M nil) (setq M 8))<br /> (cond<br />   ((<= 2 M 3) (SETQ c 3.0 d 2.5))<br />   ((<= 3.1 M 4) (SETQ c 4.0 d 3.4))<br />   ((<= 4.1 m 5) (SETQ c 5.0 d 4.3))<br />   ((<= 5.1 m 6) (SETQ c 6.0 d 5.1))<br />   ((<= 6.1 M 8) (SETQ c 8.0 d 6.9))<br />   ((<= 8.1 M 10) (SETQ c 10.0 d 8.5))<br />   ((<= 10.1 M 12) (SETQ c 12.0 d 10.5))<br />   ((<= 12.1 M 14) (SETQ c 14.0 d 12.5))<br />   ((<= 14.1 M 16) (SETQ c 16.0 d 14.5))<br /> )<br /> (while (SETQ PT (GETPOINT "\n-->请选取插入点:"))<br />   (setq p1 (polar pt (/ pi -6) (/ c 2))<br />         p2 (polar pt (/ pi 3) (/ c 2))<br />         p3 (polar pt 0 (+ (/ c 2) 3));比直径长6<br />         p4 (polar pt pi (+ (/ c 2) 3))<br />         p5 (polar pt (/ pi 2) (+ (/ c 2) 3))<br />         p6 (polar pt (/ pi -2) (+ (/ c 2) 3)))<br />   (command "_.CIRCLE" "none" pt (/ d 2) "_.ARC" "none" p2 "C" "none" pt "none" p1)<br />   (command "_.LINE" "none" p3 "none" p4 "" "_.CHPROP" "L" "" "lt" "center" "lts" 1 "")<br />   (command  "_.LINE" "none" p5 "none" p6 "" "_.CHPROP" "L" "" "lt" "center" "lts" 1 "")<br /> )<br /> (setvar "CMDECHO" 1)<br /> (princ)<br /> )<br />

726613

ZZXXQQ 发表于 2013-4-16 08:24

谢谢版主的修改