回帖是一种美德！感谢楼主的无私分享 谢谢
乱七八糟的有60M,有需要的朋友,发邮件给我.我发邮件给大家.谢谢!
这个主要是针对冲压模具CNC加工的备料程序.
有点眼花缭乱
"借鉴高飞大侠的像素功能"制作界面的程序，可否分享一下
复杂。。。
将白色过滤掉
(defun putb(ff/ *error* dch dcl des i images
j x y R G B W
H wStr hStr rStr key ColorObj
DCLHead DCLList DCLTail ImageHead IndexColor
Version
);;读取文本文件
(defun RGB->Index (ColorObj r g b / i)
;;; (if (or (and (equal 0 r 10) (equal 0 g 10) (equal 0 b 10))
;;; (and (equal 255 r 10) (equal 255 g 10) (equal 255 b 10))
;;; )
(if (and (equal 0 r 10) (equal 0 g 10) (equal 0 b 10))
-15 ;It should be 0,but if you have set the CAD background color,then it looks strange.
(progn
(vla-setRGB ColorObj r g b)
(setq i (vla-get-ColorIndex ColorObj))
(if (= i 7) ;A little confused!
255
i
)
)
)
)
(setq images (load(strcat "c:\\ourscad\\pic\\" ff ".lsp")))
(setq ffff (open (strcat "c:\\ourscad\\pic\\" ff ".lsp") "r"))
(setq file (open (strcat "c:\\ourscad\\pic\\" ff "12.lsp") "w"))
;;;(setq file (open "c:/OURSCAD/hanzi.wmf" "w"))
;(setq str (read-line f))
(write-line (read-line ffff) file)
(and (null Images) (exit))
;;获取CAD颜色对象，为颜色转化做准备
(setq Version (substr (getvar 'acadver) 1 2))
(setq Version (strcat "AutoCAD.AcCmColor." version))
(setq ColorObj (vlax-create-object version))
(setq i 0)
(foreach image Images
(foreach pt (cdr Image)
(setq x (car pt))
(setq y (cadr pt))
(setq r (nth 2 pt))
(setq g (nth 3 pt))
(setq b (nth 4 pt))
(setq IndexColor (RGB->Index ColorObj r g b))
(write-line (vl-prin1-to-string (list x y IndexColor)) file)
)
(end_image)
(setq i (1+ i))
)
(write-line "))" file)
(Close file)(close ffff)
(and ColorObj (vlax-release-object ColorObj))
(setq ffff (open (strcat "c:\\ourscad\\pic\\" ff ".lsp") "r"))
(setq file (open (strcat "c:\\ourscad\\pic\\" ff "bak.lsp") "w"))
(setq str (read-line ffff))
(write-line str file)
(while (setq str (read-line ffff))
(write-line str file)
)
(close ffff)(Close file)
(setq ffff (open (strcat "c:\\ourscad\\pic\\" ff ".lsp") "w"))
(setq file (open (strcat "c:\\ourscad\\pic\\" ff "12.lsp") "r"))
(setq str (read-line file))
(write-line str ffff)
(while (setq str (read-line file))
(setq lll (strlen str))
(cond
((< lll 4) (write-line str ffff))
((and (>= lll 4)(/= "255)" (substr str (- lll 3))))
; ((and (>= lll 4)(/= "5)" (substr str (- lll 1))))
(write-line str ffff))
)
; (write-line str ffff)
)
(close ffff)(Close file)
(princ)
)
FF为文件名.xs为倍数
(defun put(ff xs / *error* dch dcl des i images
j x y R G B W
H wStr hStr rStr key ColorObj
DCLHead DCLList DCLTail ImageHead IndexColor
IC
);;读取文本文件,xs为正整数
(setq images (load(strcat "c:\\ourscad\\pic\\" ff ".lsp")))
(and (null Images) (exit))
;;填充图像控件
(setq i 0)
(foreach image Images
(foreach pt (cdr Image)
(setq x (car pt))
(setq y (cadr pt))
(setq ic (nth 2 pt))
; (fill_image x y 1 1 ic)
;;; (if (/= 255 ic)
(fill_image (* xs x)(* xs y) xs xs ic)
;;; (fill_image (* xs x)(* xs y) xs xs ic)
;;; )
)
(end_image)
(setq i (1+ i))
)
;;开始对话框演示
;;;(and (< 0 dch) (unload_dialog dch))
(and ColorObj (vlax-release-object ColorObj))
(princ)
)
给楼主发送邮件失败了，楼主可不可以给我发一份源码，邮箱470247532@qq.com，万分感谢！
本帖最后由 xiaolong1487 于 2017-10-19 12:21 编辑
可以给份我吗？我有个朋友是做CNC的！ xiaolong100.168@163.com
实用型工具，给楼主点赞
可以给份我吗？我也是做CNC方面的 498091367@qq.com