本帖最后由 1993063 于 2012-12-31 05:35 编辑
那填充有问题,中途如果按了ESC键退了原代码有个小BUG 优化了下:也是我正在用,
(defun c:TH ( / *Error* blipm eedel i plw pp1 pp2 ppa ppb ptlist rden redent usercmd userosm)
(defun *Error* (msg)
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))
(and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm))
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)
(setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE"))
(progn
(setvar "CMDECHO" 0)
(setvar "OSMODE" 6839)
(setq blipm(getvar "blipmode"))
(setvar "blipmode" 0)
(setq pp1(getpoint "\n指定第一点:"))
(setq pp2(getcorner pp1"\r指定对角点:"))
(if (or (= pp1 nil) (= pp2 nil)) "" (progn
(setq ppa (list (car pp2)(cadr pp1)))
(setq ppb(list (car pp1) (cadr pp2)))
(setq ptlist ( list pp1 ppa pp2 ppb))
(setq plw(getvar "plinewid"))
(setvar "plinewid" 0)
(command "pline" pp1 ppa pp2ppb "c")
(setvar "plinewid" plw)
(setq eedel(entlast))
(if (tblsearch "layer" "填充") ""
(command "layer" "New" "填充" "c" "194" "填充" "")
)
(command "hatch""" "" "" "l" "")
(command "change" (entlast) "" "P" "la" "填充" "")
(entdel eedel)
(setvar "blipmode" blipm)
(setq redent(ssget "f" ptlist))
(if (= redent nil)""
(progn
(setq i 1)
(setq rden (ssname redent 0))
(while rden
(redraw rden)
(setq rden (ssname redent i))
(setq i (+ i 1))
)
)
)
))
)
(*Error* "")
(princ)
)
(defun c:HHH ( / *Error* blipm i obj pl0 pln pt0 pt1 ptlist ptn usercmd userosm)
(defun *Error* (msg)
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))
(and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm) blipm (setvar "blipmode" blipm))
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)
(setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE") blipm (getvar "blipmode"))
(setvar "CMDECHO" 0)
(progn
(setvar "OSMODE" 6839)
(setvar "blipmode" 0)
(setq pt0 (getpoint "\n指定第一点: "))
(if pt0
(progn
(setq ptlist nil)
(setq pt1 pt0)
(command ".pline" pt0 pt1 "")
(setq pl0 (entlast))
(while pt0
(setq ptlist (cons pt0 ptlist))
(setq ptn pt0)
(setq pt0 (getpoint pt0 "\r下一个点[回车] "))
(if (or
(equal pt0 pt1)
(= pt0 nil)
)
(setq pt0 nil)
""
)
(if pt0
(progn
(command ".pline" ptn pt0 "")
(setq pln (entlast))
(command "pedit" pl0 "j" pln "" "")
(setq pl0 (entlast))
(redraw pl0 3)
)
(progn
(command ".pline" ptn pt1 "")
(command "pedit" pl0 "j" (entlast) "" "")
)
) ; end if
) ; end while
(setq pl0 (entlast))
(command ".hatch" "" "" "" "l" "")
(entdel pl0)
(if (tblsearch "layer" "填充")
""
(command "layer" "New" "填充" "c" "194" "填充" "")
)
(command "change" (entlast) "" "P" "la" "填充" "")
(setq i 0)
(if (setq obj (ssget "f" ptlist))
(repeat (sslength obj)
(redraw (ssname obj i))
(setq i (+ i 1))
)
""
)
)
(prompt "取消")
)
(*Error* "")
(princ)
)
)
嘿嘿，不是我专业的，还是要支持楼主
感谢分享精华
都是原来有的，不过还是要谢谢楼主。
谢谢汇总分享。
谢谢分享
谢谢楼主的分享
先收藏看看、学习学习
谢谢
谢谢楼主代码分享！
谢谢楼主分享！
谢谢 楼主 的分享