动态填充(强烈推荐)

xiaxiang · 发表于 2011-1-7 11:10

本帖最后由 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")
)

(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") 
  )

display18 · 发表于 2011-1-7 12:49

能不要明经币么...

小明同学 · 发表于 2017-9-3 20:41

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版本）

305341043 · 发表于 2017-9-8 17:30

teykmcqh 发表于 2011-4-19 01:46
请楼主尽快提供使用方法说明，否则请斑竹给予删除！

我也是不会用呃，我在用的2016版，请赐教

langjs · 发表于 2011-1-7 12:21

程序不错，好用，比较有创意

小神仙 · 发表于 2011-1-7 14:13

CAD2011就有这个功能

cnks · 发表于 2011-1-8 01:52

楼主明经币大大的多

logitechlike · 发表于 2011-1-8 10:23

老外的有:
前一半

;| ;;
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)
)
)

;|                                                                        ;; 
        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) 
)   
)

logitechlike · 发表于 2011-1-8 10:23

后一半

;;
;; ;;
;; 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))
)
)
;;
;| |;

;; 
;;                                ;; 
;;        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))   
) 
) 
                                                ;; 
;|                                                |;

cj52000 · 发表于 2011-1-8 21:49

很好的程序，谢谢，可惜在2010上用不了

xyp1964 · 发表于 2011-1-9 14:44

(defun c:test933 ()
  (if (setq s1 (car (entsel "\n选择: ")))
(xyp-Grread-Change s1 "比例" 41 0)
  )
  (princ)
)

cj52000 · 发表于 2011-1-9 15:19

回复 xyp1964 的帖子

回版主,试了下,选择填充时,CAD提示 "选择: ; 错误: no function definition: XYP-GRREAD-CHANGE",烦请版主看下,谢谢!

账号		自动登录	找回密码
密码			注册

[资源] 动态填充(强烈推荐)

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

本帖子中包含更多资源