【转帖】老顾请帮忙完善此程序
 

老顾请帮忙完善此程序
www.dimcax.com
老顾请帮忙完善此程序
(defun c:nc ()
(setvar "cmdecho" 0)
(if (setq ss (ssget '((0 . "circle")))) (progn
(command ".undo" "be")
(setq i -1 cirlst (list))
(repeat (sslength ss)
(setq r (cdr (assoc 40 (entget (setq en (ssname ss (setq i (1+ i))))))))
(if (assoc r cirlst)
(setq cirlst (subst (cons r (1+ (cdr (assoc r cirlst)))) (assoc r cirlst) cirlst))
(setq cirlst (cons (cons r 1) cirlst))
)
)
(setq i -1 cirlst (reverse cirlst) cclist (list))
(setq cirlst (vl-sort cirlst (function (lambda (e1 e2) (> (car e1) (car e2))))))
(repeat (length cirlst)
(setq r (car (nth (setq i (1+ i)) cirlst)))
(command "select" ss "")
(setq ss1 (ssget "p" (list (cons 0 "circle") (cons 40 r))))
(setq r1 (getdist (strcat "\n请输入补偿后的钻咀直径<" (rtos (+ r r) 2 2) "> :")))
(setq r (if r1 (* r1 0.5) r))
(setq j 0 clist (list r))
(repeat (sslength ss1)
(setq ent (entget(ssname ss1 j)))
(setq j (1+ j))
(setq pc (cdr(assoc 10 ent)))
(setq clist (append clist (list (list (car pc) (cadr pc)))))
)
(setq cclist (cons clist cclist))
)
(setq nm (if nm nm ""))
(if (setq nm (getfiled "选择文件" nm "drl" 1)) (progn
(setq i 0)
(setq fp (open nm "w"))
(princ "m48\nmetric\nver,1\nfmat,2\n" fp)
(repeat (length cclist)
(setq r (car(nth i cclist)))
(setq i (1+ i))
(princ (strcat "t" (if (< i 10) "0" "") (itoa i) "c" (rtos (+ r r) 2 3) "f423b423s6h2000\n") fp)
)
(princ "detect,on\natc,on\n%\n" fp)
(setq i 0)
(repeat (length cclist)
(setq clist (nth i cclist) i (1+ i))
(princ (strcat "t" (if (< i 10) "0" "") (itoa i) "\n") fp)
(setq j 0 clist (cdr clist))
(repeat (length clist)
(setq pc (nth j clist) j (1+ j))
(princ (strcat "x" (rtos (car pc) 2 3) "y" (rtos (cadr pc) 2 3) "\n") fp)
)
)
(princ "m30\n" fp)
(close fp)
))
(command ".undo" "e")
))
(setvar "cmdecho" 1)
(progn (alert "祝贺你,数控钻孔文件成功输出,请使用!"))
(princ)
)
这是上面程序生成的文件, 已合刀的,出现以下几个问题,请帮忙解决
m48
metric
ver,1
fmat,2
t01c1.000f423b423s6h2000
t02c2.150f423b423s6h2000
t03c4.000f423b423s6h2000 ;to3和t04已经合刀了,但还是出现换刀码,
t04c4.000f423b423s6h2000
detect,on
atc,on
%
t01
x57.700y5.501
x111.397y90.011
x4.000y-2.000
x86.923y82.510
x86.923y5.501
x28.475y5.501
x28.475y82.510
t02
x110.396y1.999
x5.001y86.009
x110.396y86.009
t03 ;;这里也是
x12.000y67.000
x45.000y20.000
x102.000y22.000
x72.000y65.000
x122.000y40.000
x-7.000y40.000
t04 ；to4应该和t03是同一把刀的,谢谢，
x40.000y62.000
x105.000y67.000
x72.500y25.000
x12.000y23.000
m30

别让它沉了,请帮忙,谢谢,呵^&*&

你把你的图发到网上,要由程序要产生的正确数据文件同时发上来,我来给你改.
gbg

错误------------
m48
metric
ver,1
fmat,2
t01c1.000f423b423s6h2000
t02c1.550f423b423s6h2000
t03c4.000f423b423s6h2000
t04c4.000f423b423s6h2000
t05c4.000f423b423s6h2000
detect,on
atc,on
%
t01
x24.000y80.000
x61.000y80.000
x98.000y80.000
x135.000y80.000
x24.000y43.000
x61.000y43.000
x98.000y43.000
x135.000y43.000
x135.000y6.000
x98.000y6.000
x61.000y6.000
x24.000y6.000
x24.000y84.000
x61.000y84.000
x98.000y84.000
x135.000y84.000
x24.000y47.000
x61.000y47.000
x98.000y47.000
x135.000y47.000
x135.000y10.000
x98.000y10.000
x61.000y10.000
x24.000y10.000
t02
x149.000y117.000
x149.000y5.000
x10.000y5.000
t03
x127.000y16.000
x143.000y32.000
x90.000y16.000
x106.000y32.000
x53.000y16.000
x69.000y32.000
x16.000y16.000
x32.000y32.000
x16.000y53.000
x32.000y69.000
x53.000y53.000
x69.000y69.000
x90.000y53.000
x106.000y69.000
x127.000y53.000
x143.000y69.000
x127.000y90.000
x143.000y106.000
x90.000y90.000
x106.000y106.000
x53.000y90.000
x69.000y106.000
x32.000y106.000
x16.000y90.000
x166.000y50.000
x-7.000y50.000
t04
x135.000y24.000
x98.000y24.000
x61.000y24.000
x24.000y24.000
x24.000y61.000
x61.000y61.000
x98.000y61.000
x135.000y61.000
x135.000y98.000
x98.000y98.000
x61.000y98.000
x24.000y98.000
t05
x135.000y24.000
x98.000y24.000
x61.000y24.000
x24.000y24.000
x24.000y61.000
x61.000y61.000
x98.000y61.000
x135.000y61.000
x135.000y98.000
x98.000y98.000
x61.000y98.000
x24.000y98.000
m30
正确:------------
m48
metric
ver,1
fmat,2
t01c1.000f423b423s6h2000
t02c1.550f423b423s6h2000
t03c4.000f423b423s6h2000
detect,on
atc,on
%
t01
x24.000y80.000
x61.000y80.000
x98.000y80.000
x135.000y80.000
x24.000y43.000
x61.000y43.000
x98.000y43.000
x135.000y43.000
x135.000y6.000
x98.000y6.000
x61.000y6.000
x24.000y6.000
x24.000y84.000
x61.000y84.000
x98.000y84.000
x135.000y84.000
x24.000y47.000
x61.000y47.000
x98.000y47.000
x135.000y47.000
x135.000y10.000
x98.000y10.000
x61.000y10.000
x24.000y10.000
t02
x149.000y117.000
x149.000y5.000
x10.000y5.000
t03
x127.000y16.000
x143.000y32.000
x90.000y16.000
x106.000y32.000
x53.000y16.000
x69.000y32.000
x16.000y16.000
x32.000y32.000
x16.000y53.000
x32.000y69.000
x53.000y53.000
x69.000y69.000
x90.000y53.000
x106.000y69.000
x127.000y53.000
x143.000y69.000
x127.000y90.000
x143.000y106.000
x90.000y90.000
x106.000y106.000
x53.000y90.000
x69.000y106.000
x32.000y106.000
x16.000y90.000
x166.000y50.000
x-7.000y50.000
x135.000y24.000
x98.000y24.000
x61.000y24.000
x24.000y24.000
x24.000y61.000
x61.000y61.000
x98.000y61.000
x135.000y61.000
x135.000y98.000
x98.000y98.000
x61.000y98.000
x24.000y98.000
x135.000y24.000
x98.000y24.000
x61.000y24.000
x24.000y24.000
x24.000y61.000
x61.000y61.000
x98.000y61.000
x135.000y61.000
x135.000y98.000
x98.000y98.000
x61.000y98.000
x24.000y98.000
m30
1

附件www.dimcax.com下载次数已上传，谢谢帮忙

程序已给你调出来.能写出文件.
(defun c:nc (/ fp ss ii i r cirlst ss1 r1 r2 r3 j g bb biao biao1 ent)
(setvar "cmdecho" 0)
(setq nm (getstring "文件名:") fp (open (strcat nm ".drl") "w"))
(princ "m48\nmetric\nver,1\nfmat,2\n" fp)
(setq ss (ssget "all" '((0 . "circle"))))
(command ".undo" "be")
(setq r2 0 i -1 biao (list) biao1 (list))
(repeat (sslength ss)
(setq r (cdr (assoc 40 (entget (setq en (ssname ss (setq i (1+ i))))))))
(if (assoc r cirlst)
(setq cirlst (subst (cons r (1+ (cdr (assoc r cirlst)))) (assoc r cirlst) cirlst))
(setq cirlst (cons (cons r 1) cirlst))
)
)
(setq ii 1 i -1 cirlst (reverse cirlst) )
(setq cirlst (vl-sort cirlst (function (lambda (e1 e2) (> (car e1) (car e2))))) cirlst (reverse cirlst))
(repeat (length cirlst)
(setq r (car (nth (setq i (1+ i)) cirlst)))
(command "select" ss "")
(setq ss1 (ssget "p" (list (cons 0 "circle") (cons 40 r))))
(setq r1 (getdist (strcat "\n请输入补偿后的钻咀直径<" (rtos (+ r r) 2 2) "> :")))
(setq r (if r1 (* r1 0.5) r))
(if (= r2 0)(setq biao (list))
(if (= r2 r1) (setq biao biao1)
(if (/= r2 r1)
(progn
(setq d (read (strcat "aa" (itoa ii))) )
(setq c2 'd c2 biao1)
(set d biao1)
(setq biao (list))
(setq bb (strcat "t" (if (< ii 10) "0" "") (itoa ii) "c" (rtos r3 2 3) "f423b423s6h2000\n"))
(princ bb fp)
(setq ii (+ ii 1))
)
)))
(setq g (sslength ss1) j 0 )
(repeat g
(setq ent (entget(ssname ss1 j)))
(setq j (1+ j))
(setq pc (cdr(assoc 10 ent)))
(setq biao (append biao (list (list (car pc) (cadr pc)))))
)
(setq biao1 biao r2 r1 r3 r1)
)
(setq d (read (strcat "aa" (itoa ii))) )
(setq c2 'd c2 biao1)
(set d biao1)
(setq bb (strcat "t" (if (< ii 10) "0" "") (itoa ii) "c" (rtos (+ r r) 2 3) "f423b423s6h2000\n"))
(princ bb fp)
(setq aa "detect,on\natc,on\n%\n")
(princ aa fp)
(setq i 0 )
(repeat ii
(setq i (1+ i))
(princ (strcat "t" (if (< i 10) "0" "") (itoa i) "\n") fp)
(setq j 0 biaoo (eval (read (strcat "aa" (itoa i)))))
(repeat (length biaoo)
(setq pc (nth j biaoo) j (1+ j))
(princ (strcat "x" (rtos (car pc) 2 3) "y" (rtos (cadr pc) 2 3) "\n") fp)
)
)
(princ "m30\n" fp)
(close fp)
(command ".undo" "e")
(setvar "cmdecho" 1)
(progn (alert "祝贺你,数控钻孔文件成功输出,请使用!"))
(princ)
)
gbg

谢谢老顾的热心帮助