自动图案填充
大家好，已经开始使用lisps，可以看到很多可能性。
我们执行的一个重复命令是使用剖面线图案ASNI37在风管HA层上填充矩形（或闭合多段线），比例为32，角度为0。
这在我们的施工图上表示绝缘管道系统。
我想创建一个lisp，我可以简单地键入HH并选择对象，（围绕风管区域绘制）创建图案填充，然后删除对象。
我读过几篇关于创建图案填充的帖子，但我的autolisp知识非常基础，我需要一些帮助。
谢谢
戴夫
嗨Dave，
我在最近的一个线程上使用了这个程序，并对其进行了修改以满足您的需要。如果还需要修剪，请告诉我。
这段代码有一定的效果。
这是线程的链接。
http://www.cadtutor.net/forum/showthread.php?52876-创建-Ansi-31-Hatch-Linetype
以下是您的代码：
红色的默认值可以更改为适合。很抱歉粘贴后的格式很糟糕。
ANSI37.lsp
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Start-Up.
;
(defun C:ANSI37 (/ CL01 CL02 RAD# DEG# PT01 PT02 PT03 PT04 DLEN E01 CPS SUS HPRP HSCL HWID HANG LNAM LCLR LTYP)
(ANSI37_SUS)
(princ))
(princ "\nANSI37.lsp loaded... Type ANSI37 to start.")
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Save User Settings.
;
(defun ANSI37_SUS ()
(setq SUS_LST (list "cmdecho" "orthomode" "osmode" "blipmode" "angbase" "angdir" "aunits" "clayer")
SUS (mapcar 'getvar SUS_LST)
TERR *error*
*error* ANSI37_ET)
(ANSI37_MF)
(princ))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Main Function.
;
(defun ANSI37_MF ()
(or H:WID (setq H:WID 12)) ;Defualt Hatch Width = 12
(setq HPRP "ANSI37" ;Default Hatch Pattern = ANSI37
HSCL 32 ;Default Hatch Scale = 32
HANG 180 ;Default Hatch Angle = 0°
LNAM "DUCT-HA" ;Default Layer Name = DUCT-HA
LCLR 1 ;Default Layer Color = 1 or RED
LTYP "Continuous") ;Default Layer Linetype= Continuous
(setq H:WID ;Set the hatch width
(cond ;Condition
((getint (strcat "\nSpecify hatch width. <"(itoa H:WID)">: ")))(T H:WID))) ;Get the hatch width
(setq HWID H:WID) ;Set the Hatch Width
(setvar "osmode" (nth 2 SUS)) ;Turn on Saved User Snaps
(setq CL01 (getpoint "\nSpecify first point along duct: ")) ;Get the first point
(while ;While loop
(if (/= (setq CL02 (getpoint CL01 "\nSpecify next point along duct: ")) nil) ;Get the next point, if the next point is nil, Go to the Loop Function
(progn ;Then do the following
(ANSI37_CPS) ;Go to Change Program Settings Function
(setq RAD# (angle CL01 CL02) ;Get the angle in radians
DEG# (ANSI37_RTD RAD#) ;Convert the radians to degrees
DLEN (distance CL01 CL02) ;Get the distance from first point to the next point
CL01 (trans CL01 1 0) ;Translate coordinate system
CL02 (trans CL02 1 0) ;Translate coordinate system
PT01 CL01 ;Calculate Point 01
PT02 (polar PT01 (ANSI37_DTR (+ DEG#0))DLEN) ;Calculate Point 02
PT03 (polar PT01 (ANSI37_DTR (+ DEG# 270)) HWID) ;Calculate Point 03
PT04 (polar PT02 (ANSI37_DTR (+ DEG# 270)) HWID)) ;Calculate Point 04
(ANSI37_ML LNAM LCLR LTYP) ;Set layer name, color, linetype
(setvar "clayer" LNAM) ;Set layer current
(setvar "osmode" 0) ;Turn off snaps
(command "._pline" PT01 PT02 PT04 PT03 "C") ;Start Polyline command for hatch perimeter
(setq E01 (entlast)) ;Set polyline as last entity to E01
(command "._-bhatch" "_a" "_a" "_y" "" "_p" HPRP HSCL HANG "_s" "_l" "" "") ;Start Hatch command and fill the polyline
(command "._erase" E01 "") ;Erase entity E01 or the polyline perimeter
(setvar "osmode" (nth 2 SUS)) ;Turn on Saved User Snaps
(setq CL01 CL02)))) ;Set the next point to the first point
(ANSI37_LF) ;Go to the Loop Function
(princ)) ;Exit quietly
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Loop Function.
;
(defun ANSI37_LF ()
(setq LOOP "Y") ;Default Loop Y or Yes
(initget "Y N") ;Set the keywords
(setq LOOP ;Set variable LOOP
(cond ;Condition
((getkword (strcat "\nContinue? <"LOOP">: ")))(T LOOP))) ;Do you wish to continue? Y or N
(cond ;Condition
((= LOOP "N")(ANSI37_RUS)) ;If N or No was selected go to ANSI37_RUS, Restore User Settings function
((= LOOP "Y")(ANSI37_MF))) ;If Y or Yes was selected go to HLIN_MF, Main Function
(princ)) ;Exit quietly
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Degrees To Radians.
;
(defun ANSI37_DTR (DEG#)(* pi (/ DEG# 180.0))) ;Convert degrees to radians
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Radians To Degrees.
;
(defun ANSI37_RTD (RAD#)(* 180.0 (/ RAD# pi))) ;Convert radiand to degrees
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Make Layer.
;
(defun ANSI37_ML (L:NAM L:CLR L:TYP)
(if (null (tblsearch "layer" L:NAM))
(entmake
(list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 2L:NAM)
(cons700)
(cons62L:CLR)
(cons 6L:TYP)
(cons 2901))))
(princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Change Program Settings.
;
(defun ANSI37_CPS ()
(setq CPS (list 0 1 0 0 0 0))
(mapcar (function setvar)(list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits") CPS)
(princ))
(princ)
;
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Restore User Settings.
;
(defun ANSI37_RUS ()
(setq *error* TERR)
(if SUS (mapcar 'setvar SUS_LST SUS))
(princ "\nANSI37.lsp has completed successfully and will now restore your settings.")
(princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Error Trap.
;
(defun ANSI37_ET (ERRORMSG)
(command nil nil nil)
(if (not (member ERRORMSG '("console break" "Function cancelled")))
(princ (strcat "\nError:" ERRORMSG)))
(if SUS (mapcar 'setvar SUS_LST SUS))
(princ "\nANSI37.lsp has encountered a user error!")
(princ "\nProgram will now restore your settings and exit.")
(terpri)
(setq *error* TERR)
(princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
也许是这样？
(defun c:HH ( / *error* _StartUndo _EndUndo doc spc ent hobj hl )
(vl-load-com)
;; © Lee Mac 2010
(setq hl "Duct-HA") ;; Hatch Layer
(defun *error* ( msg )
(and doc (_EndUndo doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(LM:ActiveSpace 'doc 'spc)
(or (tblsearch "LAYER" hl)
(vla-add (vla-get-layers doc) hl)
)
(if (setq ent (LM:Selectif (lambda ( x ) (vlax-curve-isClosed x)) entsel "\nSelect Object to Hatch: "))
(progn
(_StartUndo doc)
(if
(not
(vl-catch-all-error-p
(setq hobj
(vl-catch-all-apply 'vla-AddHatch
(list spc acHatchPatternTypePredefined "ANSI37" :vlax-false 0)
)
)
)
)
(progn
(vlax-invoke hobj 'AppendOuterLoop (list (vlax-ename->vla-object ent)))
(mapcar
'(lambda ( p v ) (vlax-put-property hobj p v))
'(Layer AssociativeHatch PatternAngle PatternScale) (list hl :vlax-false 0.0 32.0)
)
(vla-Evaluate hobj)
(entdel ent)
)
(princ (strcat "\n** Error: " (vl-catch-all-error-message hobj) " **"))
)
(_EndUndo doc)
)
)
(princ)
)
;;---------------------=={ Select if }==----------------------;;
;; ;;
;;Continuous selection prompts until the predicate function ;;
;;foo is validated ;;
;;------------------------------------------------------------;;
;;Author: Lee McDonnell, 2010 ;;
;; ;;
;;Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;;Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;foo - optional predicate function taking ename argument ;;
;;fun - selection function to invoke ;;
;;str - prompt string ;;
;;------------------------------------------------------------;;
;;Returns:selected entity ename if successful, else nil ;;
;;------------------------------------------------------------;;
(defun LM:Selectif ( foo fun str / e )
;; © Lee Mac 2010
(while
(progn (setq e (car (fun str)))
(cond
( (eq 'ENAME (type e))
(if (and foo (not (foo e)))
(princ "\n** Invalid Object Selected **")
)
)
)
)
)
e
)
;;--------------------=={ ActiveSpace }==---------------------;;
;; ;;
;;Retrieves pointers to the Active Document and Space ;;
;;------------------------------------------------------------;;
;;Author: Lee McDonnell, 2010 ;;
;; ;;
;;Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;;Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;*doc - quoted symbol other than *doc ;;
;;*spc - quoted symbol other than *spc ;;
;;------------------------------------------------------------;;
(defun LM:ActiveSpace ( *doc *spc )
;; © Lee Mac 2010
(set *spc
(if
(or
(eq AcModelSpace
(vla-get-ActiveSpace
(set *doc
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
)
)
(eq :vlax-true (vla-get-MSpace (eval *doc)))
)
(vla-get-ModelSpace (eval *doc))
(vla-get-PaperSpace (eval *doc))
)
)
) 这无疑是更好和更简单的使用。
感谢Buzzard，这是我第一次使用VL创建图案填充，在这样做时需要注意一些事情（详细信息见VLIDE帮助文件），所以我想试试。 我几乎可以发誓你已经做了类似的事情。我就是记不起那根线了。无论如何，它仍然需要一个层函数，但我想我们不能放弃存储。
哦，是的-忘了图层。。。 谢谢大家的反馈。将公布最终结果。
戴夫
谢谢Buzzard。
这个lisp可以实现我想要的，除了我希望它完全填充矩形，而不是在其周围放一条边。
基本上，启动命令，选择现有的矩形或闭合多段线（一些风管是weired形状）并用图案填充。
戴夫
我的编辑速度有点快，所以我希望有一些怪癖。我建议你试试李的节目。我相信他把你想要的东西都放进去了。顺便说一句，我的程序正在请求风管宽度，以将图案填充设置为，并且不留下矩形。所以我不确定你到底是什么意思，但李的节目是你最好的选择。
页:
[1]
2