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

1993063 · 发表于 2012-12-31 23:34:55

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

辉/:) · 发表于 2013-1-1 09:22:25

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

726613 · 发表于 2013-1-2 09:59:01

感谢分享精华

ylzhaosjz · 发表于 2013-1-3 09:06:42

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

wjl1014 · 发表于 2013-1-24 10:09:57

谢谢汇总分享。

2007russell · 发表于 2013-2-4 13:36:50

谢谢分享

461045462 · 发表于 2013-2-4 16:09:29

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

清风明月名字 · 发表于 2013-6-29 13:57:06

谢谢楼主代码分享！

陈亚娣 · 发表于 2013-7-6 11:47:58

谢谢楼主分享！

pengfei2010 · 发表于 2013-7-16 09:58:54

谢谢楼主的分享

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

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

点评