发一些自己编写的常用程序源码，还有整理的几个

1993063

那填充有问题,中途如果按了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   pp2  ppb "c")
    (setvar "plinewid" plw)
    (setq eedel(entlast))
    (if (tblsearch "layer" "填充") ""
      (command "layer" "New" "填充" "c" "194" "填充" "")
    )
    (command "hatch"  "" "" "" "l" "")
    (command "change" (entlast) "" "" "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) "" "" "la" "填充" "")
          (setq i 0)
          (if (setq obj (ssget "f" ptlist))
            (repeat (sslength obj)
              (redraw (ssname obj i))
              (setq i (+ i 1))
            )
            ""
          )
        )
        (prompt "取消")
      )
      (*Error* "")
    (princ)
  )
)

辉/:)

嘿嘿，不是我专业的，还是要支持楼主

726613

感谢分享精华

ylzhaosjz

都是原来有的，不过还是要谢谢楼主。

wjl1014

谢谢汇总分享。

2007russell

谢谢分享

461045462

谢谢楼主的分享
先收藏看看、学习学习
谢谢

清风明月名字

谢谢楼主代码分享！

陈亚娣

谢谢楼主分享！

pengfei2010

谢谢 楼主 的分享