[求助][LISP]Solid Hatch to Gradient?

alin

To create nice slides, I want to convert all the hatches with "Solid" style in current drawing into "Gradient" hatch without changing their colors. Anybody got an idea? Thanks in advance.

龙龙仔

;;不清楚你遇到甚么困难??
(defun C:TT1 (/ SS ENT)
  (setq SS (ssget "X" '((0 . "HATCH") (2 . "SOLID")))
 N  0
  )
  (repeat (sslength SS)
    (setq ENT (entget (ssname SS N)))
    (entmod (subst (cons 2 "ANSI31") (assoc 2 ENT) ENT))
    (setq N (1+ N))
  )
  (princ)
)

alin

我想换成渐变色(Gradient)，用ANSI31代替有时hatch很小时还要考虑比例问题，否则做出来的Slide效果还不行。

龙龙仔

3. ;;BY LUCAS
4. (defun C:TT1 (/ OBJ SS ENT COLOR)
5.     (defun ColorIndex-to-TrueColor (ci / colorObj)
6.     (vl-load-com)
7.     (and (setq colorObj (vla-getinterfaceobject
8.      (vlax-get-acad-object)
9.      "AutoCAD.AcCmColor.16"
10.    )
11.   )
12.   (>= ci 1)
13.   (<= ci 255)
14.   (not
15.     (vl-catch-all-error-p
16.       (vl-catch-all-apply 'vla-put-ColorIndex (list colorObj ci))
17.     )
18.   )
19.   (vla-setrgb
20.     colorobj
21.     (vla-get-red colorObj)
22.     (vla-get-green colorObj)
23.     (vla-get-blue colorObj)
24.   )
25.     )
26.     colorobj
27.   )
28.   (setq SS (ssget "X" '((0 . "HATCH")))
29. N  0
30.   )
31.   (repeat (sslength SS)
32.     (setq ENT (ssname SS N))
33.     ;;---------------------------------------
34.     ;;只对有62 dxf测试,相信你可以完成(增加其他情况--bylayer/truecolor)
35.     (setq color (cdr (assoc 62 (entget ent))))
36.     ;;---------------------------------------
37.     (vla-put-HatchObjectType
38.       (setq obj (vlax-ename->vla-object ent))
39.       1
40.     )
41.     (vla-put-GradientColor1
42.       obj
43.       (ColorIndex-to-TrueColor color)
44.     )
45.     (setq N (1+ N))
46.   )
47.   (princ)
48. )

;;BY LUCAS (defun C:TT1 (/ OBJ SS ENT COLOR)     (defun ColorIndex-to-TrueColor (ci / colorObj)     (vl-load-com)     (and (setq colorObj (vla-getinterfaceobject      (vlax-get-acad-object)      "AutoCAD.AcCmColor.16"    )   )   (>= ci 1)   (<= ci 255)   (not     (vl-catch-all-error-p       (vl-catch-all-apply 'vla-put-ColorIndex (list colorObj ci))     )   )   (vla-setrgb     colorobj     (vla-get-red colorObj)     (vla-get-green colorObj)     (vla-get-blue colorObj)   )     )     colorobj   )   (setq SS (ssget "X" '((0 . "HATCH"))) N  0   )   (repeat (sslength SS)     (setq ENT (ssname SS N))     ;;---------------------------------------     ;;只对有62 dxf测试,相信你可以完成(增加其他情况--bylayer/truecolor)     (setq color (cdr (assoc 62 (entget ent))))     ;;---------------------------------------     (vla-put-HatchObjectType       (setq obj (vlax-ename->vla-object ent))       1     )     (vla-put-GradientColor1       obj       (ColorIndex-to-TrueColor color)     )     (setq N (1+ N))   )   (princ) )

alin

谢谢龙龙仔，但我一直没有成功。可能是因为我要跨文档操作，我改成VBA也不行，每次到改变HatchObjectType时AutoCAD就死掉。

龙龙仔

3. ;;(arxload "acetutil.arx" NIL)
4. ;;不清楚你如何跨文档操作
5. ;;批量修改Hatchobj为渐变色(非OBJECTDBX)
6. ;;BY LUCAS(龙龙仔)
7. (vl-load-com)
8. (defun C:TTT (/ HOLDECHO APP DWGNAME PREFIX_DWG NN QQ WW ENT N COLOR)
9.   (defun COLORINDEX-TO-TRUECOLOR (CI / COLOROBJ)
10.     (vl-load-com)
11.     (and (setq COLOROBJ (vla-getinterfaceobject
12.      (vlax-get-acad-object)
13.      "AutoCAD.AcCmColor.16"
14.    )
15.   )
16.   (>= CI 1)
17.   (<= CI 255)
18.   (not
19.     (vl-catch-all-error-p
20.       (vl-catch-all-apply 'vla-put-colorindex (list COLOROBJ CI))
21.     )
22.   )
23.   (vla-setrgb
24.     COLOROBJ
25.     (vla-get-red COLOROBJ)
26.     (vla-get-green COLOROBJ)
27.     (vla-get-blue COLOROBJ)
28.   )
29.     )
30.     COLOROBJ
31.   )
32.   (setq HOLDECHO (getvar "cmdecho"))
33.   (setvar "cmdecho" 0)
34.   (setq PREFIX_DWG
35.   (strcat
36.     (vl-string-right-trim
37.       "\"
38.       (strcase (acet-ui-pickdir
39.    "选择目录"
40.    (vl-string-right-trim "\" (getvar "dwgprefix"))
41.    "批量修改Hatchobj为渐变色"
42.         )
43.       )
44.     )
45.     "\"
46.   )
47.   )
48.   (setq QQ (vl-directory-files PREFIX_DWG "*.DWG"))
49.   (setq NN 0)
50.   (if (/= QQ NIL)
51.     (progn
52.       (setq APP (vlax-get-acad-object))
53.       (repeat (length QQ)
54. (setq DWGNAME (strcase (strcat PREFIX_DWG (nth NN QQ))))
55. (setq WW (vla-open (vla-get-documents APP) DWGNAME))
56. (vlax-for N (vla-get-blocks WW)
57.    (vlax-for ENT N
58.      (if (vlax-property-available-p ENT 'HATCHOBJECTTYPE)
59.        (progn
60.   ;;只对有62 dxf测试,相信你可以完成(增加其他情况--bylayer/truecolor)
61.   (if (setq COLOR
62.       (cdr
63.         (assoc 62
64.         (entget (vlax-vla-object->ename ENT))
65.         )
66.       )
67.       )
68.     (progn
69.       (vla-put-hatchobjecttype
70.         ENT
71.         1
72.       )
73.       (vla-put-gradientcolor1
74.         ENT
75.         (COLORINDEX-TO-TRUECOLOR COLOR)
76.       )
77.     )
78.   )
79.        )
80.      )
81.    )
82. )
83. (vla-save WW)
84. (prompt (strcat "\n" DWGNAME " <修改Hatchobj完成>!!!"))
85. (vla-close WW :vlax-false)
86. (setq NN (1+ NN))
87.       )
88.       (vlax-release-object WW)
89.       (vlax-release-object APP)
90.     )
91.     (prompt "\n所选目录中未有任何图档!!!")
92.   )
93.   (setvar "cmdecho" HOLDECHO)
94.   (princ)
95. )
96. (princ)

;;(arxload "acetutil.arx" NIL) ;;不清楚你如何跨文档操作 ;;批量修改Hatchobj为渐变色(非OBJECTDBX) ;;BY LUCAS(龙龙仔) (vl-load-com) (defun C:TTT (/ HOLDECHO APP DWGNAME PREFIX_DWG NN QQ WW ENT N COLOR)   (defun COLORINDEX-TO-TRUECOLOR (CI / COLOROBJ)     (vl-load-com)     (and (setq COLOROBJ (vla-getinterfaceobject      (vlax-get-acad-object)      "AutoCAD.AcCmColor.16"    )   )   (>= CI 1)   (<= CI 255)   (not     (vl-catch-all-error-p       (vl-catch-all-apply 'vla-put-colorindex (list COLOROBJ CI))     )   )   (vla-setrgb     COLOROBJ     (vla-get-red COLOROBJ)     (vla-get-green COLOROBJ)     (vla-get-blue COLOROBJ)   )     )     COLOROBJ   )   (setq HOLDECHO (getvar "cmdecho"))   (setvar "cmdecho" 0)   (setq PREFIX_DWG   (strcat     (vl-string-right-trim       "\"       (strcase (acet-ui-pickdir    "选择目录"    (vl-string-right-trim "\" (getvar "dwgprefix"))    "批量修改Hatchobj为渐变色"         )       )     )     "\"   )   )   (setq QQ (vl-directory-files PREFIX_DWG "*.DWG"))   (setq NN 0)   (if (/= QQ NIL)     (progn       (setq APP (vlax-get-acad-object))       (repeat (length QQ) (setq DWGNAME (strcase (strcat PREFIX_DWG (nth NN QQ)))) (setq WW (vla-open (vla-get-documents APP) DWGNAME)) (vlax-for N (vla-get-blocks WW)    (vlax-for ENT N      (if (vlax-property-available-p ENT 'HATCHOBJECTTYPE)        (progn   ;;只对有62 dxf测试,相信你可以完成(增加其他情况--bylayer/truecolor)   (if (setq COLOR       (cdr         (assoc 62         (entget (vlax-vla-object->ename ENT))         )       )       )     (progn       (vla-put-hatchobjecttype         ENT         1       )       (vla-put-gradientcolor1         ENT         (COLORINDEX-TO-TRUECOLOR COLOR)       )     )   )        )      )    ) ) (vla-save WW) (prompt (strcat "\n" DWGNAME " <修改Hatchobj完成>!!!")) (vla-close WW :vlax-false) (setq NN (1+ NN))       )       (vlax-release-object WW)       (vlax-release-object APP)     )     (prompt "\n所选目录中未有任何图档!!!")   )   (setvar "cmdecho" HOLDECHO)   (princ) ) (princ)

alin

Thanks again. I have just tried your routine in 2004 but it didn’t work. The Solid hatch in drawings didn’t change to Gradient hatch type. And it exited with error before finishing the whole folder.

 

What I want to do is: Open an existing DWG file è Zoom extent è Substitute all Solid hatch with gradient Hatch type è Make a slide è Quit without save

龙龙仔

VLISP跨文档无法做Zoom extent,看来只能用INSERT图档

附我的测试图(R2005通过)

alin

Yes, it works fine on your test drawing. Now I know the reason why I failed to do that. Because we were told to save our drawings in 2000 format by default and there is no gradient in 2000 and I believe some drawing information has lost.

teykmcqh

好贴很多，可我水平很有限，只能取所需学习一下啦