动态填充(强烈推荐)
本帖最后由 xiaxiang 于 2011-1-9 17:11 编辑Author: TheSwamp@Andrea
this allow user to select a closed polyline and scale in real time the hatch !
you can switch to the next Hatch patern by pressing the TAB key.
(progn
(setq mess1 "\nPlease pick Boundary or point inside hatch region")
(setq mess2 "\n- Hatch Pattern Switched to : ")
(setq mess3 "\nPress SPACE bar to Make a choice and than ENTER to edit:")
(setq mess4 "\nPlease select Hatch to edit : ")
(setq mess5 "\n(D)ynamic or (V)alue <D>: ")
(setq mess6 "\nDynamic Scale...")
(setq mess7 "\nEnter the Hatch Scale Value <")
(setq mess8 ";Scale: ")
(setq mess9 ";Angle: ")
(setq mess10";Pattern: ")
(setq mess11";Origin: ")
(setq mess12";PAT File: ")
(setq cmess0"\nPress SPACE bar for select/ENTRER to activate/V to enter a Value:")
(setq cmess1"\nNew Scale Value :")
(setq cmess2"\nNew Angle Value :")
(setq cmess3"\nNew Pattern Name :")
(setq cmess4"\nNew Origin Coordinates (list) :")
(setq cmess5"\nNew Color Value :")
(setq var256"BYLAYER")
(setq var0 "BYBLOCK")
)
能不要明经币么... xyp1964 发表于 2011-1-9 14:44
(defun c:test933 ()
(if (setq s1 (car (entsel "\n选择: ")))
(xyp-Grread-Change s1 "比例" 41...
错误: no function definition: XYP-GRREAD-CHANGE请版主查看，谢谢（2006版本） teykmcqh 发表于 2011-4-19 01:46
请楼主尽快提供使用方法说明，否则请斑竹给予删除！
我也是不会用呃，我在用的2016版，请赐教 程序不错，好用，比较有创意 CAD2011就有这个功能 楼主明经币大大的多 老外的有:
前一半;| ;;
H O S COMMAND -> Changed for DHATCH (Dynamic HATCH) ;;
(Hatch Object Scaling v. 2) ;;
By: Andrea Andreetti dec. 2009 ;;
;;
Update 1 - By: Ronjonp (theswamp) ;;
Rotation angle revised ;;
;;
Update 2 - By Andrea Andreetti ;;
ORTHOMODE added with F8 ;;
Color Switch from 1 to 9 ;;
Switch Hatch Pattern during Rotation ;;
;;
Update 2.1 -By Andrea Andreetti ;;
Fix1 :ColorToggle variable added to fix ;;
Color Swaping without rescaling the Hatch ;;
Fix2 : PatternToggle Variable added for same reason ;;
when swapping the Hatch Pattern ;;
Fix3 : English and French message detection ;;
HOS became DHATCH (dynamic Hatch) ;;
;;
Update 2.2 -By Andrea Andreetti ;;
- New Feature allowing to move the HatchOrigin ;;
;;
Upgrade Dhatch v.3 -bY Andrea Andreetti 2008/12/23 ;;
-Solid Hatch accepted ;;
-Work for Ellipse ;;
-You can select object or click INSIDE a closed object ;;
-New Options: (S)cale/(H)atch/(O)rigin/(C)olor ;;
-You can change Origin in real time and continu the function.
-Osnap follow the SNAPANG variable. ;;
-Diffrent ggrdraw vector color when using the Origin option.
-Color option show the 256 autoCAD color dialog Box during the hatch.
-Auto-Language version detection. (French / English) ;;
;;
Update Dhatch v.3.1.0 -by Andrea Andreetti 2008/12/23 ;;
-Undo Redo management ;;
Update dHATCH V.3.1.1 -by Andrea Andreetti 2008/12/23 ;;
-Case Sensitive when choosing options FIXED ;;
;;
Upgrade Dhatch 4.0 by Andrea Andreetti 2008/12/25 ;;
-New function DHEDIT (editor) ;;
Update Dhatch 4.1 By A.A. 2008-12-28 ;;
DHSL DHatch String Language detection function ;;
Update Dhatch 4.2 By A.A. 2008-12-29 ;;
Scale option allow to put Number Value ;;
|;
;; ;;
;; FRENCH/ENGLISH DETEXTION ;;
;; ;;
;;
(defun DHSL ()
(vl-load-com)
(if (vl-string-search "(FR)" (strcase (ver)))
(progn
(setq mess1 "\nSelectionnez votre entit??Hachurer...")
(setq mess2 "\n- Type de Hachure chang??: ")
(setq mess3 "\n(E)chelle/(H)achurage/(O)rigine/(C)couleur:")
(setq mess4 "\nS閘ectionnez l'hachure ?閐iter : ")
(setq mess5 "\n(D)ynamique ou (V)aleur <D>: ")
(setq mess6 "\n蒫helle Dynamique...")
(setq mess7 "\n蒫helle de votre hachurage <")
(setq var256"DUCALQUE")
(setq var0 "DUBLOCK")
)
(progn
(setq mess1 "\nSelect Entity to Hatch...")
(setq mess2 "\n- Hatch Pattern Switched to : ")
(setq mess3 "\n(S)cale/(H)atch pattern/(O)rigin/(C)olor:")
(setq mess4 "\nPlease select Hatch to edit : ")
(setq mess5 "\n(D)ynamic or (V)alue <D>: ")
(setq mess6 "\nDynamic Scale...")
(setq mess7 "\nEnter the Hatch Scale Value <")
(setq var256"BYLAYER")
(setq var0 "BYBLOCK")
)
)
)
;;
;; ;;
;; FRENCH/ENGLISH DETEXTION ;;
;; ;;
;; ;;
;; DHATCH COMMAND ;;
;; ;;
;;
(defun c:Dhatch (/ #DCswitch dr_sel1 entVLA OTD)
(DHSL)
(setq HatchEdition nil)
(if (not #DCswitch)(setq #DCswitch 0))
(setq dr_sel1 nil)
(while (or
(= dr_sel1 nil)
(and
(/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "LWPOLYLINE")
(/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "CIRCLE")
(/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) "ELLIPSE")
)
)
(setq dr_sel1 (entsel mess1))
(if (not dr_sel1)
(progn
(setq FicPoint (cadr (grread t 4 4)))
(vl-cmdf "._boundary" FicPoint "")
(if (> (getvar "cmdactive") 0)
(progn
(command)
(setq OTD nil)
)
(progn
(setq dr_sel1 (list (setq TD (entlast)) FicPoint))
(setq OTD T)
)
)
)
)
)
(setq entVLA (vlax-ename->vla-object (car dr_sel1)))
(if (or
(eq (vla-get-ObjectName entVLA) "AcDbEllipse")
(eq (vla-get-ObjectName entVLA) "AcDbCircle")
(and
(eq (vla-get-ObjectName entVLA) "AcDbPolyline")
(eq (vla-get-Closed entVLA) :vlax-true)
)
)
(progn
(vla-GetBoundingBox entVLA 'x 'y)
(setq LLpoint(vlax-safearray->list x))
(setq URpoint(vlax-safearray->list y))
(setq centerpoint (polar LLpoint (angle LLpoint URpoint) (/ (distance LLpoint URpoint) 2)))
)
)
(redraw)
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
(oHexecute)
(setq hatchent nil)
(if OTD (entdel TD))
(redraw)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
)
;;
;; ;;
;; DHATCH COMMAND ;;
;; ;;
;; ;;
;; DHATCHEDIT ;;
;; ;;
;;
(defun c:Dhatchedit (/)
(DHSL)
(setq hatchdata nil)
(setq HatchEdition T)
(setq OTD nil)
(setq dr_sel1 nil)
(while (or
(= dr_sel1 nil)
(and
(/= (cdr (assoc 0 (setq hatchdata (entget (car dr_sel1))))) "HATCH")
)
)
(setq dr_sel1 (entsel mess4))
)
(setq entVLA (vlax-ename->vla-object (car dr_sel1)))
(vla-GetBoundingBox entVLA 'x 'y)
(setq LLpoint(vlax-safearray->list x))
(setq URpoint(vlax-safearray->list y))
(setq centerpoint (polar LLpoint (angle LLpoint URpoint) (/ (distance LLpoint URpoint) 2)))
(entdel (car dr_sel1))
(redraw)
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
(oHexecute)
(setq hatchent nil)
(redraw)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
)
;;
;; ;;
;; DHATCHEDIT ;;
;; ;;
;; ;;
;; DHATCH ORTHOMODE ;;
;; ;;
;;
(defun HOSortho ()
(defun dtr (a)
(* pi (/ a 180.0))
)
(defun rtd (a)
(/ (* a 180) pi)
)
(setq distP (distance centerpoint cursorpoint))
(setq NorthP (polar centerpoint (+ snapA (dtr 90)) distP))
(setq WestP(polar centerpoint (+ snapA (dtr 180)) distP))
(setq EastP(polar centerpoint snapA distP))
(setq SouthP (polar centerpoint (- snapA (dtr 90)) distP))
(if (and
(< (distance cursorpoint NorthP) (distance cursorpoint WestP))
(< (distance cursorpoint NorthP) (distance cursorpoint EastP))
(< (distance cursorpoint NorthP) (distance cursorpoint SouthP))
)
(setq cursorpoint NorthP)
)
(if (and
(< (distance cursorpoint WestP) (distance cursorpoint NorthP))
(< (distance cursorpoint WestP) (distance cursorpoint EastP))
(< (distance cursorpoint WestP) (distance cursorpoint SouthP))
)
(setq cursorpoint WestP)
)
(if (and
(< (distance cursorpoint EastP) (distance cursorpoint WestP))
(< (distance cursorpoint EastP) (distance cursorpoint NorthP))
(< (distance cursorpoint EastP) (distance cursorpoint SouthP))
)
(setq cursorpoint EastP)
)
(if (and
(< (distance cursorpoint SouthP) (distance cursorpoint WestP))
(< (distance cursorpoint SouthP) (distance cursorpoint EastP))
(< (distance cursorpoint SouthP) (distance cursorpoint NorthP))
)
(setq cursorpoint SouthP)
)
) 后一半 ;;
;; ;;
;; DHATCH ORTHOMODE ;;
;; ;;
;; ;;
;; DHATCH function ;;
;; ;;
;;
(defun oHexecute (/ fi si LP A_hps)
(setvar "CMDECHO" 0)
(setq orthm (getvar "ORTHOMODE"))
(setq snapa (getvar "SNAPANG"))
(setq #dcswitch 0)
(setq Operation nil)
(setq hatchlist (gethatchlin (findfile "acad.PAT")))
(setq hatch# (1- (vl-list-length hatchlist)))
(if (not HatchEdition)
(progn
(vl-cmdf "_-hatch" "_S" (car dr_sel1) "" "")
(setq hatchdata (entget (entlast)))
(if (eq (cdr (assoc 0 hatchdata)) "HATCH")
(entdel (entlast))
)
(setq A_cecolor (getvar "CECOLOR")
A_hpang (getvar "HPANG")
A_hpscale (getvar "HPSCALE")
A_hpname (getvar "HPNAME")
A_hporigin centerpoint)
)
(progn
(if (assoc 62 hatchdata)
(setq A_cecolor (itoa (cdr (assoc 62 hatchdata))))
(setq A_cecolor var256)
)
(setq A_hpscale (cdr (assoc 41 hatchdata)))
(setq A_hpang (getvar "HPANG"))
(setq A_hpname (cdr (assoc 2 hatchdata)))
(setq A_hporigin centerpoint)
)
)
(princ mess3)
(while (and (setq input (grread t 4 4))
(or (= (car input) 5) ; *cursor
(and (= (car input) 2) (= (cadr input) 15)) ; F8 Orthomode
(and (= (car input) 2) (= (cadr input) 104)); h = Hatch
(and (= (car input) 2) (= (cadr input) 72)) ; H
;(and (= (car input) 2) (= (cadr input) 14)) ; R = Rotation
(and (= (car input) 2) (= (cadr input) 115)); s = Scale
(and (= (car input) 2) (= (cadr input) 83)) ; S
(and (= (car input) 2) (= (cadr input) 101)); e = Echelle
(and (= (car input) 2) (= (cadr input) 69)) ; E
(and (= (car input) 2) (= (cadr input) 111)); o = Origin
(and (= (car input) 2) (= (cadr input) 79)) ; O
(and (= (car input) 2) (= (cadr input) 99)) ; c = Color
(and (= (car input) 2) (= (cadr input) 67)) ; C
)
)
(if (= (car input) 5) (setq cursorpoint (cadr input)))
(if (or
(and (= (car input) 2) (= (cadr input) 104))
(and (= (car input) 2) (= (cadr input) 72))
)
(setq Operation "HATCH" Thatch T)
)
(if (and (= (car input) 2) (= (cadr input) 15)) (setq Operation "ORTHO"))
(if (or
(and (= (car input) 2) (= (cadr input) 115));S
(and (= (car input) 2) (= (cadr input) 83))
(and (= (car input) 2) (= (cadr input) 101));E
(and (= (car input) 2) (= (cadr input) 69))
)
(setq Operation "SCALE")
)
(if (or
(and (= (car input) 2) (= (cadr input) 111))
(and (= (car input) 2) (= (cadr input) 79))
)
(setq Operation "ORIGIN")
)
(if (or
(and (= (car input) 2) (= (cadr input) 99))
(and (= (car input) 2) (= (cadr input) 67))
)
(setq Operation "COLOR")
)
(if (eq Operation "COLOR")
(progn
(setq ccol (read A_cecolor))
(if (eq (strcase A_cecolor) "BYBLOCK") (setq ccol 0))
(if (eq (strcase A_cecolor) "BYLAYER") (setq ccol 256))
(setq Ncol (acad_colordlg ccol 8))
(if Ncol
(progn
(setq A_cecolor (itoa Ncol))
(if (eq A_cecolor 256)(setq A_cecolor var256))
(if (eq A_cecolor 0)(setq A_cecolor var0))
)
)
(setq Operation nil)
)
)
;;SWITCH HATCH MODE ;;
;;
(if (eq Operation "HATCH")
(progn
(setq Operation nil)
(setq input (grread t 4 4))
(if (>= #dcswitch hatch#)
(setq #dcswitch 0)
(setq #dcswitch (1+ #dcswitch))
)
(setvar "HPNAME" A_hpname)
(princ (strcat mess2
(setq A_hpname (nth #dcswitch hatchlist))
)
)
(princ mess3)
)
)
;;
;;SWITCH HATCH MODE ;;
;;SWITCH ORTHOMODE ;;
;;
(if (eq Operation "ORTHO")
(progn
(if (eq orthm 1)
(progn (setvar "ORTHOMODE" 0) (setq orthm 0))
(progn (setvar "ORTHOMODE" 1) (setq orthm 1))
)
(setq Operation nil)
)
)
(if (eq orthM 1)
(HOSortho)
)
;;
;;SWITCH ORTHOMODE ;;
;;SWITCH SCALE ;;
;;
(if (eq Operation "SCALE")
(progn
(initget "D V")
(setq gkw (getKword mess5))
(if (eq gkw "D")
(progn
(princ mess6)
(while (and (setq inputX (grread t 5 0))
(= (car inputX) 5)
)
(setq cursorpoint (cadr inputX))
(setq A_hpscale (distance cursorpoint centerpoint))
(MODIFHATCH A_hpname A_cecolor A_hpang A_hpscale A_hporigin)
(setq Operation nil)
)
(princ mess3)
)
(progn
(setq A_hps (getreal (strcat mess7
(rtos A_hpscale)
">: "
)
)
)
(if A_hps
(setq A_hpscale A_hps)
)
(setq Operation nil)
(princ mess3)
)
)
)
)
;;
;;SWITCH SCALE ;;
;;SWITCH ORIGIN ;;
;;
(if (eq Operation "ORIGIN")
(progn
(while (and (setq input (grread t 4 4))
(or (= (car input) 5)
))
(redraw)
(setq cursorpoint (cadr input))
(setq cursorX (car cursorpoint))
(setq cursorY (cadr cursorpoint))
(grdraw cursorpoint centerpoint 12 1)
(if hatchent
(progn
(setq A_hpang A_LastAng)
(setq hatchentData (entget hatchent))
(setq hatchdatax (subst (cons 43 cursorX)(assoc 43 hatchentData) hatchentData))
(setq hatchdatax (subst (cons 44 cursorY)(assoc 44 hatchdatax) hatchdatax))
(entmod hatchdatax)
(setq hatchent (cdr (car hatchdatax)))
)
)
)
(setq centerpoint (cadr input))
)
)
;;
;;SWITCH ORIGIN ;;
;;UPDATE HATCH
(MODIFHATCH A_hpname A_cecolor A_hpang A_hpscale A_hporigin)
;;UPDATE ANGLE
(if (not (eq Operation "ORIGIN"))
(progn
(setq rangle (+ (angle cursorpoint centerpoint) (angtof "135")))
(grdraw cursorpoint centerpoint 4 1)
(setq entVLA (vlax-ename->vla-object hatchent))
(vla-put-PatternAngle entVLA rangle)
)
(setq Operation nil)
)
(princ)
)
)
;;
;; ;;
;; H O S function ;;
;; ;;
;; ;;
;; HATCH UPDATE ;;
;; ;;
;;
(defun MODIFHATCH (hatch col Rot sca orig)
(redraw)
(if hatchdata
(progn
(grdraw cursorpoint centerpoint 4 1)
;;origin
(setq orig A_hporigin)
(setq cursorX (car orig))
(setq cursorY (cadr orig))
(setq hatchdatax (subst (cons 43 cursorX)(assoc 43 hatchentData) hatchdata))
(setq hatchdatax (subst (cons 44 cursorY)(assoc 44 hatchdatax) hatchdatax))
;;scale
(setq hatchdatax (subst (cons 41 sca) (assoc 41 hatchdatax) hatchdatax))
;;HatchPattern
(setq hatchdatax (subst (cons 2 hatch) (assoc 2 hatchdatax) hatchdatax))
;;Color
(if (eq (strcase col) var256);BYLAYER
(setq hatchdatax(vl-remove (assoc 62 hatchdatax) hatchdatax))
)
(if (eq (strcase col) var0);BYBLOCK
(setq col 0)
)
(if (numberp (read col))
(progn
(if (not (assoc 62 hatchdatax))
(setq hatchdatax (append hatchdatax (list (cons 62 (read col)))))
(setq hatchdatax (subst (cons 62 (read col)) (assoc 62 hatchdatax) hatchdatax))
)
)
)
(if hatchent
(progn (command "._erase" hatchent "") (setq hatchent nil))
)
(setq hatchent (entmakex hatchdatax))
(setq hatchdata hatchdatax)
)
)
)
;;
;; ;;
;; HATCH UPDATE ;;
;; ;;
;| ;;
PAT or LIN file reader ;;
|;
;;
(defun getHatchLIN (acadftype / lino acadftype l1 commaPos ALLLIST)
(setq HATCHLIST nil
LINESLIST nil)
(if (findfile acadftype)
(progn
(setq lino (open acadftype "r"))
(while (setq l1 (read-line lino))
(if (and
(eq (substr l1 1 1) "*")
(setq commaPos (vl-string-search "," l1))
)
(setq ALLLIST (append ALLLIST (list (substr l1 2 (1- commaPos)))))
)
)
)
)
(close lino)
(if (eq (strcase (vl-filename-extension acadftype)) ".PAT")
(setq HATCHLIST (mapcar 'strcase ALLLIST))
(setq LINESLIST (mapcar 'strcase ALLLIST))
)
)
;;
;| |;
很好的程序，谢谢，可惜在2010上用不了 (defun c:test933 ()
(if (setq s1 (car (entsel "\n选择: ")))
(xyp-Grread-Change s1 "比例" 41 0)
)
(princ)
) 回复 xyp1964 的帖子
回版主,试了下,选择填充时,CAD提示"选择: ; 错误: no function definition: XYP-GRREAD-CHANGE",烦请版主看下,谢谢!