【Gu_xl】自动提取AutoCAD 图形中填充图案的定义文件
本帖最后由 Gu_xl 于 2013-6-11 10:41 编辑在有些时候，从别人处得到dwg图形，里面有非常漂亮的非标准填充图案方案，要想借用其图案是很困难的！
里面的非标准的填充图案，我们cad标准填充图案文件acad.pat或acadiso.pat文件有若没有该图案定义，这时想要对图案进行编辑和使用，也非常麻烦和不方便！一个好的办法是将图案定义提取出来，添加到acad.pat或acadiso.pat文件中！这一切烦恼的问题都不存在了！
在程序的编制过程中，得到了highflybird和caoyin两位版主的鼎力技术支持，在此表示感谢！
;;;c:getpat 提取填充图案 2011年12月24日 By 明经通道 Gu_xl
;;;若选取的图案文件已存在，自动追加或替换已有文件中图案
(defun c:getpat (/ ROTZ RTOD DXF GETPATHmeasurement
PATNAMEENT FILENAME F1 FLAG
ZC PATDATAALLPATDATA NAME
HATCH SCALE ROT ENL NEWPATDATA
ANG X Y DX DY
DATA N L K STRDATA
TMP F
)
;;;坐标绕Z轴顺时针旋转角度
(defun RotZ (ang x y / an)
(setq an (- ang))
(mapcar '(lambda (r) (apply '+ (mapcar '* r (list x y))))
(list (list (cos an) (- (sin an)))
(list (sin an) (cos an))
)
)
)
;;;字串分割
(defun gxl-StrParse (str del / pos lst)
(while (setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 1 (strlen del)))
)
)
(if (= " " Del)
(vl-remove "" (reverse (cons str lst)))
(reverse (cons str lst))
)
)
;;;弧度转度
(defun RtoD (dat /)
(* 180.0 (/ dat pi))
)
;;;取组码值
(defun dxf (ent i)
(cond ((= (type ent) 'ename)
(cdr (assoc i (entget ent '("*"))))
)
((= (type ent) 'list)
(cdr (assoc i ent))
)
) ;_ if
)
;;;计算路径
(defun getpath (/ tmp)
(strcat (VL-FILENAME-DIRECTORY (findfile "acad.pat")) "\\")
)
(princ "\n***提取填充图案 By 明经通道 Gu_xl***")
(setq measurement(getvar 'measurement)) ;_ 0 英制 1 公制
(cond
((= 0 measurement) ;_ 英制
(setq patname (getenv "ANSIHatch"))
)
((= 1 measurement) ;_ 公制
(setq patname (getenv "ISOHatch"))
)
)
(while (and (setq ent (car (entsel "\n选择填充图案: "))) (= "HATCH" (dxf ent 0)))
(setq filename (getfiled "选取图案文件" (strcat (getpath) patname)"pat" 1))
(if filename
(progn
(if (findfile filename)
;_ 若图案文件已存在，则生成的图案文件添加或替换到该图案文件
(progn
(setq f1 (open filename "r"))
(setq flag nil)
(while (setq zc (read-line f1))
(cond
(flag
(setq Patdata (append Patdata (list zc)))
(while (and
(setq zc (read-line f1))
(/= "*" (substr (VL-STRING-RIGHT-TRIM " " zc) 1 1))
(/= ";" (substr (VL-STRING-RIGHT-TRIM " " zc ) 1 1))
)
(setq Patdata (append Patdata (list zc)))
)
(setq AllPatdata (cons Patdata AllPatdata))
(if (and zc (= "*" (substr (VL-STRING-RIGHT-TRIM " " zc ) 1 1)))
(progn
(setq Patdata (list (strcase (car (GXL-STRPARSE zc ","))) zc) Flag t)
)
(progn
(setq flag nil)
(if zc (setq AllPatdata (cons (list "注释" zc) AllPatdata)))
)
)
)
((= ";" (substr (VL-STRING-RIGHT-TRIM " " zc ) 1 1))
(setq AllPatdata (cons (list "注释" zc) AllPatdata))
)
((= "*" (substr (VL-STRING-RIGHT-TRIM " " zc ) 1 1))
(setq Patdata (list (strcase (car (GXL-STRPARSE zc ","))) zc))
(while (and
(setq zc (read-line f1))
(/= "*" (substr (VL-STRING-RIGHT-TRIM " " zc) 1 1))
(/= ";" (substr (VL-STRING-RIGHT-TRIM " " zc ) 1 1))
)
(setq Patdata (append Patdata (list zc)))
)
(setq AllPatdata (cons Patdata AllPatdata))
(if (and zc (= "*" (substr (VL-STRING-RIGHT-TRIM " " zc ) 1 1)))
(progn
(setq Patdata (list (strcase (car (GXL-STRPARSE zc ","))) zc) Flag t)
)
(progn
(setq flag nil)
(if zc (setq AllPatdata (cons (list "注释" zc) AllPatdata)))
)
)
)
)
)
(close f1)
;;;图案文件数据 '((图案名称 图案数据)
(setq AllPatdata (reverse AllPatdata))
(setq name (dxf ent 2)) ;_ 图案名称
)
(progn
(setq AllPatdata nil) ;_ 图案文件数据置空
(setq name (VL-FILENAME-BASE filename)) ;_图案名称同文件名
)
)
(setq hatch (vlax-ename->vla-object ent))
(setq scale (vla-get-PatternScale hatch);_ 填充比例
Rot (vla-get-PatternAngle hatch) ;_ 填充角度
)
(setq enl (entget (vlax-vla-object->ename hatch))
enl (member (assoc 53 enl) enl)
)
(setq NewPatData (list (strcat "*" (strcase name)) (strcat "*" name "," name))) ;_ 储存填充数据表
(while (= 53 (caar enl))
(setq ang (cdar enl) ;_ 53 图案直线角度
enl (cdr enl)
)
(setq x(dxf enl 43) ;_ 图案直线基点，X 分量
y(dxf enl 44) ;_ 图案直线基点，Y 分量
dx (dxf enl 45) ;_ 图案直线偏移，X 分量
dy (dxf enl 46) ;_ 图案直线偏移，Y 分量
)
(mapcar 'set (list 'dx 'dy) (RotZ ang dx dy))
(mapcar 'set (list 'x 'y) (RotZ Rot x y))
(setq data (list x y dx dy))
(setq enl (member (assoc 79 enl) enl))
(setq n (cdar enl) ;_ 虚线长度项目数
enl (cdr enl)
)
(repeat n
(setq l (car enl) ;_ 虚线长度
enl (cdr enl)
)
(setq data (append data (list (cdr l))))
)
(setq k 12) ;_ 数字取位精度
;;;图案定义最长不超过80个字符
(while (> (strlen (setq strdata
(apply
'strcat
(cons
(rtos (RtoD (- ang Rot)) 2 k)
(mapcar
'(lambda (a) (strcat "," (rtos (/ a scale) 2 k)))
data
)
)
)
)
)
80
)
(setq k (1- k))
)
(setq NewPatData (append NewPatData (list strdata)))
)
(if (setq tmp (assoc (strcat "*" (strcase name)) AllPatdata))
(setq AllPatdata (subst NewPatData tmp AllPatdata))
(setq AllPatdata (append AllPatdata (list NewPatData)))
)
(setq f (open filename "w"))
(if f
(progn
(foreach a AllPatdata
(if (= (car a) (strcat "*" (strcase name)))
(progn
(write-line ";;" f)
(write-line ";; 以下图案由Gu_xl图案提取程序自动提取生成" f)
(write-line ";;" f)
)
)
(foreach b (cdr a)
(write-line b f)
)
)
(close f)
;(startapp "notepad.exe" filename)
)
(progn
(alert (strcat filename "文件不能保存！线型文件为你保存在临时文件中！"))
(setq filename (VL-FILENAME-MKTEMP "pat" "" ".pat"))
(setq f (open flename "w"))
(foreach a AllPatdata
(foreach b (cdr a)
(write-line b f)
)
)
(close f)
;(startapp "notepad.exe" filename)
)
)
)
)
)
(princ)
)
测试样图：
http://bbs.mjtd.com/xwb/images/bgimg/icon_logo.png 该贴已经同步到 Gu_xl的微博
2011年12月25日更新
更新内容：可以批量提取图案，并增加是否更新已有图案选项！
2012.12.26日更新：根据caoyin版主的意见，增加考虑将填充图案基点修正到‘(0 0)为基点
atone 发表于 2023-4-17 10:48
我这样设置了快捷键，也保存了ini文件，快捷键不起作用或者叫CAD不识别
我想知道我是逻辑理解错了，还是有什么东西没有添加？ 花了两天的时间逛明经，终于把发帖数攒到20了！！！下载来使用了一下，不要太好用！！！
那些求发邮箱的。朋友，这个插件还是源码，值得你为了它好好逛逛论坛。 swb4420 发表于 2021-2-28 15:11
两个测试CAD提示图形文件无效。
fixmj.exe本版块搜索这个文件修复下即可 本帖最后由 highflybir 于 2011-12-24 22:15 编辑
占沙发。
不知道关于镜像后的填充图案是不是真的无解？
本帖最后由 gbhsu 于 2011-12-24 22:01 编辑
坐板凳！！！！
鼓掌！！！！！！ GXL-STRPARSE 没有定义 精品作品！支持！ highflybir 发表于 2011-12-24 23:39 static/image/common/back.gif
GXL-STRPARSE 没有定义
函数补上：
;;;字串分割
(defun gxl-StrParse (str del / pos lst)
(while (setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 1 (strlen del)))
)
)
(if (= " " Del)
(vl-remove "" (reverse (cons str lst)))
(reverse (cons str lst))
)
)
还有几点建议：
1、建议用measurement 系统变量
;;measurement
(setq MEASUREMENT (getvar 'MEASUREMENT)) ;_ 0 Ó¢ÖÆ 1 ¹«ÖÆ
(cond
((= 0 MEASUREMENT) ;
(setq patname (getenv "ANSIHatch"))
)
((= 1 MEASUREMENT)
(setq patname (getenv "ISOHatch"))
)
)
(setq filename (findfile patname))
(setq filepath (strcat (VL-FILENAME-DIRECTORY filename) "\\"))
2、好像应该按照i文件支持路径顺序找acad.pat或者acadiso.pat
譬如天正，斯维尔之类的，它们的标准pat文件并不在你的那个目录下，(getpath)
3、如果是根据图案名字来定义文件名，可以不考虑添加,因为一个文件名只有一种图案有效。
4、如果是批量或者连续选择，建议前面让用户选择，是否添加到标准图案库中，如果是，则判断标准图案中是否有
有则不计算，无则计算。
如果不是添加到标准图案中，则寻找支持目录下是否有同名的图案名，有的话不计算，否则计算。
这样可以防止覆盖原来的pat
精彩，无私奉献 我搞机械的，虽然用不上，但是很支持！