【分享明经——发程序、拜新年专贴】

caoyin · 发表于 2008-12-6 13:16

本帖最后由作者于 2009-3-3 13:57:49 编辑

【分享明经——发程序、拜新年专贴】
元旦将至，在此向各位新老朋友拜早年了，祝大家在新的一年里
事业发达，身体健康，阖家平安！
祝福明经祝福网友

[说明及参与办法]
发帖以分享自己的程序为祝福新年方式。
要求：
1. LISP 函数模块或实用程序；
2. 所发程序可为源代码或编译的 VLX、FAS 程序；
3. 所发程序应为本站未发过的程序(本站首发最好)；
4. 源代码需注明作者或版权信息。
非原创程序需征得作者同意，且注明出处或网址链接。
5. VLX、FAS 编译后的程序须为原创程序。
6. 所发程序应包含中文的用法和说明。
为了支持明经，希望大家踊跃发帖。
希望各位朋友大力支持，发帖多者、发帖精者望 mccad 予以特别加分。
希望本次活动能够掀起年底的一次发帖小高潮！！
特邀：
管理员、版主、贵宾、资深会员、超人气会员、活跃会员(排名不分先后)：
mccad 龙龙仔无痕 ZZXXQQ alin 王咣生 highflybir BDYCAD
lyy Andyhon fsxm phoenixdjq sailorcwx lidejun_55 英雄无敌
byghbcx nonsmall 露水2 carrot1983 jxlsp 等
诚邀：
所有热爱 LISP，乐于奉献的会员。
参与或支持本活动。
复制代码

注：本帖中所发程序版权为程序作者及明经通道所有，未经许可谢绝转载。
网友可使用本帖中的任何函数，但请保留作者名称及版权信息，用于商业行为需征得原创作者同意。

carrot1983 · 发表于 2008-12-6 22:52

本帖最后由作者于 2008-12-6 22:56:26 编辑

caoyin都这么说了，不发点东西，真不好意思。

来个经典的。今天重写。

;;;writenn by carrot1983 2008-12-06
(defun c:cd (/ e elist i newstring pt1 pt2)
(command "._undo" "_begin")
(princ "\n功能: 纯数字递增复制")
(if (and (setq e (car (entsel "\n选择纯数字 <退出>: ")))
    (if (setq i (getint "\n输入增值 <1>: ")) t (setq i 1))
    (setq pt1 (getpoint "\n指定第一点 <退出>: "))
      )
    (while (setq pt2 (getpoint pt1 "\n下一点 <退出>: "))
      (setq elist (entget e))
      (setq newstring (itoa (+ (read (cdr (assoc 1 elist))) i))) ;_递增
      (entmake (subst (cons 1 newstring)
        (assoc 1 elist)
        elist
        )
      )
      (setq e (entlast))
      (command "._move" e "" "none" pt1 "none" pt2)
      (setq pt1 pt2)
    )
)
(command "._undo" "_end")
(princ)
)

nonsmall · 发表于 2008-12-6 13:40

本帖最后由作者于 2008-12-7 18:11:30 编辑

;;3D->2D

;; by nonsmall @ mjtd

;;相当于ET工具的Flatten

;;常用的图元就当参考吧

(defun c:3d2d( / i name obname ss typ)
(vl-load-com)
(setq i 0)
(command "ucs" "w")
(setq ss (ssget))
(repeat (sslength ss)
  (setq name (ssname ss i))
  (setq obname (vlax-ename->vla-object name))
  (setq typ (vla-get-objectname obname))
  (cond
   ((= "AcDbLine" typ)
    (vla-put-startpoint obname (pt32 (vla-get-startpoint obname)))
    (vla-put-endpoint obname (pt32 (vla-get-endpoint obname)))
   )
   ((= "AcDbArc" typ)
    (vla-put-center obname (pt32 (vla-get-center obname)))
   )
   ((= "AcDbCircle" typ)
    (vla-put-center obname (pt32 (vla-get-center obname)))
   )
   ((= "AcDbText" typ)
    (vla-put-InsertionPoint obname (pt32 (vla-get-InsertionPoint obname)))
   )
   ((= "AcDbMText" typ)
    (vla-put-InsertionPoint obname (pt32 (vla-get-InsertionPoint obname)))
   )
   ((= "AcDbBlockReference" typ)
    (vla-put-InsertionPoint obname (pt32 (vla-get-InsertionPoint obname)))
   )
   ((= "AcDbEllipse" typ)
    (vla-put-center obname (pt32 (vla-get-center obname)))
   )
   ((= "AcDbPolyline" typ)
    (vla-put-Elevation obname 0)
   )
   ((= "AcDbHatch" typ)
    (vla-put-Elevation obname 0)
   )
   (T
    (command "Flatten" obname "")
   )
  )
  (print(setq i (1+ i)))
)
(command "ucs" "p")
)
(defun pt32 (pt / ptnew)
(setq ptnew (trans (vlax-safearray->list (vlax-variant-value pt)) 0 1))
(setq ptnew (list (car ptnew) (cadr ptnew) 0))
(setq pt (vlax-3d-point ptnew))
)

qinleilei · 发表于 2018-2-10 20:39

马上又是春节了，提前预祝大家新年快乐！

caoyin · 发表于 2008-12-6 13:20

本帖最后由作者于 2008-12-6 14:12:22 编辑

重在参与，先自己顶一下
;;AX选择集--Alisp选择集相互转换函数
;;by caoyin @ mjtd.com

;;____________________________________________________________________________________________________
;; ▓ (ltax:ss->axss ss)
;; [功能] 将 ALISP 选择集转换为 VLA 选择集
;; [参数] ss---选择集
(defun ltax:ss->axss (ss / ssp axss)
(setq ssp (ssget "_p"))
(sssetfirst nil ss)
(ssget "_I")
(setq axss (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
(if (cadr (sssetfirst nil ssp)) (ssget "_I"))
(sssetfirst)
axss
)
;;____________________________________________________________________________________________________
;; ▓ (ltax:axss->ss axss)
;; [功能] 将 VLA 选择集转换为 ALISP 选择集
;; [参数] ss---选择集
(defun ltax:axss->ss (axss / ss)
(setq ss (ssadd))
(vlax-for x axss (ssadd (vlax-vla-object->ename x) ss))
ss
)

caoyin · 发表于 2008-12-6 13:23

本帖最后由作者于 2008-12-6 13:45:49 编辑

;;选择对象 entsel ssget等函数扩展
;; by caoyin @mjtd.com
;;____________________________________________________________________________________________________
;; ▓ (lt:entsel msg fil lst)
;; [功能] 扩展 entsel，支持过滤选择，关键字
;; [参数] msg---(STR)提示信息。如果nil时则显示缺省为"\n选择对象: "
;;       fil---(LIST)过滤条件列表，格式与 ssget 函数相同
;;       lst---(LIST)包含两个元素：(errmsg key)
;;             errmsg---出错信息(STR)。如果nil时则显示缺省为"无效的对象。"
;;             keywd----关键字，格式与 initget 函数相同
;; [返回] 本函数受变量 $LT-ENTSEL$ 影响，若 $LT-ENTSEL$ 为 nil，返回值与函数 entsel 相同，反之
;;       则与函数 nentsel 相同。
;| [测试]
(LT:ENTSEL "\n选择对象或 [类型(T)/点(O)]: "
         '((0 . "line") (8 . "0"))
         (list "对象必须是图层为 0 的直线。" "Type pOint")
)
|;

(defun LT:ENTSEL (MSG FIL LST / NOM PIF ERRMSG KEYWD FUN E EN SS)
(setq NOM (getvar "nomutt")
PIF (getvar "pickfirst")
ERRMSG (car lst)
KEYWD (cadr lst)
)
(if $LT-ENTSEL$
(setq FUN 'nentsel)
(setq FUN 'entsel)
)
(or MSG (setq MSG ""))
(or ERRMSG (setq ERRMSG "无效对象。"))
(setq KEYWD (cond (KEYWD (strcat KEYWD " ")) (T " ")))
(setvar "pickfirst" 1)
(while (not E)
(initget KEYWD)
(setq E (apply fun (list MSG)))
(cond
((= E "") (setq E T))
((not E) (princ "未找到对象。"))
((and (vl-consp E) (not $LT-ENTSEL$))
(setq SS (ssadd) EN (car E))
(ssadd EN SS)
(sssetfirst nil SS)
(setvar "nomutt" 1)
(ssget)
(setq SS (ssget "_p" FIL))
(setvar "nomutt" NOM)
(if (not (and SS (ssmemb EN SS)))
(progn (princ ERRMSG) (setq E nil))
)
)
)
)
(setvar "pickfirst" PIF)
(if (/= E T) E)
)

;;____________________________________________________________________________________________________
;; ▓ (lt:ssget-for msg flt fun)
;; [功能] 获取选择集并实时进行指定函数的操作
;; [参数] msg---提示信息(STR)，如果nil时则显示缺省为"\n选择对象: "
;;       flt---等同于 ssget 函数图元过滤表
;;       fun---要对所选对象执行的函数
;; [返回] 成功->选择集，反之->nil
;| [测试]
(lt:ssget-for "\n删除对象:" nil 'entdel)
(defun c:tt ()
  (lt:ssget-for "选择要改变颜色的直线:"
            '((0 . "line"))
            '(lambda (x)
               (if (or (>= col 256) (not col)) (setq col 0))
                  (vla-put-color (vlax-ename->vla-object x) (setq col (1+ col)))
            )
  )
)
|;

(defun lt:ssget-for (msg flt fun / cme nom sp ss ss2 e)
(setq cme (getvar "cmdecho")
nom (getvar "nomutt")
)
(if msg
(setq msg (strcat "\r" msg))
(setq msg "\r选择对象: ")
)
(setvar "nomutt" 1)
(setvar "cmdecho" 0)
(while
(progn
(setq sp (ssget "_P"))
(princ msg)
(command "_.select" "_si")
(command pause)
(setq ss (ssget "_p"))
(if (and sp (equal (ssnamex sp) (ssnamex ss)))
(setq ss nil)
)
ss
)
(if (and ss (setq ss (ssget "_p" flt)))
(progn
(if (not ss2) (setq ss2 (ssadd)))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(if fun (apply fun (list e)))
(ssadd e ss2)
)
)
)
)
(setvar "cmdecho" cme)
(setvar "nomutt" nom)
ss2
)

;;下面一个函数源自 xdcad.net 网友讨论，龙版主发过，为了方便整理，放于此处
;;____________________________________________________________________________________________________
;; ▓ (lt:ssget lst)
;; [功能] 获取选择集(类似于 ssget 函数，不同的是可以加入提示信息)
;; [参数] lst----(LIST)参数列表，包含若干元素：
;;             第一个元素----提示信息(STR)，如果nil时则显示缺省为"\n选择对象: "
;;             其他元素------包括 ssget 函数的所有参数
;; [返回] 成功->选择集，反之->nil
;; [测试] (lt:ssget '("\n选择直线或圆弧: " ((0 . "line,arc"))))
;;       (lt:ssget '(nil "_x" ((0 . "line,arc"))))

(defun lt:ssget (lst / oldnom ss)
(if (setq msg (car lst))
(progn
(setq oldnom (getvar "nomutt"))
(princ msg)
(setvar "nomutt" 1)
)
)
(setq ss (vl-catch-all-apply 'ssget (cdr lst)))
(if oldnom (setvar "nomutt" oldnom))
(if (not (vl-catch-all-error-p ss)) ss)
)

caoyin · 发表于 2008-12-6 13:31

本帖最后由作者于 2008-12-6 14:20:51 编辑

;;刷子函数，此程序写得比较粗糙 by caoyin @ mjtd.com
;;刷子功能由用户自己定义，用于任何“匹配”功能需要动态显示刷子的程序
;;发一个刷文字内容的例子(动画)

;;____________________________________________________________________________________________________
;; ▓ (lt:match )
;; [功能] 模仿 MATCHPROP 刷子功能
;; [参数] pt-------刷子动态起始点
;;       col------表 (刷子颜色选择框颜色)
;;       ssparm---表，选择参数。(命令行打印信息图元属性过滤)
;;       fun------函数名
;; [返回]
;| [测试]
(defun c:tt (/ EN PT TAG x y pt1)
  (setq EN (ENTSEL "\n选择源对象: "))
  (if EN
(progn
   (setq pt (cadr en)
         EN (car EN)
         ss (lt:match pt '(4 6)
               (list "\n选择直线: "
                     '((0 . "line")))
                     '(lambda (x) (vla-put-color (vlax-ename->vla-object x) 2)
               )
            )
   )
)
  )
  ss
)
(defun c:matxt (/ e ed ss) ;;  文字内容匹配
;(lt:error-init (list nil 0 nil nil))
  (setq e (lt:entsel "\n选择源文字对象: "
                  '((0 . "*TEXT,DIMENSION"))
                  '("\n对象必须是单行文字、多行文字或标注。" nil nil)
      )
  )
  (if (not e) (exit))
  (redraw (car e) 3)
  (setq ed (cons 1 (cdr (assoc 1 (entget (car e))))))
  (lt:match
(cadr e)
'(2 3)
(list "\n选择目标文字对象: " '((0 . "*TEXT,DIMENSION")))
'(lambda (x / ent)
   (setq ent (entget x))
   (entmod (subst ed (assoc 1 ent) ent))
   )
  )
;(lt:error-restore)
)
|;

(defun lt:match (pt col ssparm fun / d_brush pickbox p2u len x y msg pt1 ss1 pt2 co i e ss)
(defun d_brush (col x y len / a b c)
(grvecs (list col (list (- x (setq A (* len 1.5))) (- y len))
(list (- x A) (setq B (- y (* len 7.5))))
col (list (- x (setq C (* len 0.5))) y)
(list (- x C) B)
col (list (+ x C) y)
(list (+ x C) B)
col (list (+ x A) (- y len))
(list (+ x A) B)
col (list (- x (setq A (* len 4.5))) B)
(list (+ x A) B)
col (list (- x A) B)
(list (- x (setq C (* len 6.5))) (- y (* len 9)))
col (list (+ x A) B)
(list (+ x C) (setq A (- y (* len 9))))
col (list (- x C) A)
(list (- x C) (setq B (- y (* len 17))))
col (list (+ x C) A)
(list (+ x C) B)
col (list (- x C) (setq A (- y (* len 10))))
(list (+ x C) A)
col (list (- x C) (setq A (- y (* len 11))))
(list (+ x C) A)
col (list (- x C) (setq A (- y (* len 13))))
(list (+ x C) A)
col (list (- x C) (setq A (- y (* len 14))))
(list (+ x C) A)
col (list (- x C) B)
(list (+ x C) B)
col (list (- x C) B)
(list (- x (* len 11)) (setq A (- y (* len 21.5))))
col (list (- x (* len 2)) B)
(list (- x (* len 6.5)) A)
col (list (+ x (* len 2)) B)
(list (- x (* len 2.5)) A)
col (list (+ x C) B)
(list (+ x (* len 2)) A)
col (list (- x (* len 11)) A)
(list (+ x (* len 3)) A)
)
(list (list 1 0 0 (* len 14))
(list 0 1 0 (* len -4)) '(0 0 1 0) '(0 0 0 1)
)
)
)
(defun pickbox (pt / si cv)
(setq si (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) (getvar "viewsize") 0.5)
cv (list si si 0)
)
(list (mapcar '+ pt cv) (mapcar '- pt cv))
)
(defun p2u (pix) (* pix (/ (getvar "viewsize") (cadr (getvar "screensize")))))
(or (setq co (cadr col)) (setq co 7))
(or (setq col (car col)) (setq col 7))
(or (setq msg (car ssparm)) (setq msg "\n选择目标对象: "))
(setq ssparm (cadr ssparm) len (p2u 1) x (car pt) y (cadr pt))
(princ msg)
(while (/= (car pt1) 11)
(redraw)
(d_brush col x y len)
(while (not (member (car (setq pt1 (grread T 12 2))) '(3 11)))
(setq pt1 (cadr pt1))
(if (vl-consp pt1)
(progn
(if (> (distance PT1 PT) (p2u (* 0.0001 (car (getvar "screensize")))))
(progn
(redraw)
(setq len (p2u 1) x (car pt) y (cadr pt))
(d_brush col x y len)
(setq pt pt1)
)
)
)
)
)
(redraw)
(if (and (= (car pt1) 3)
(princ msg)
(not (setq ss1 (apply 'ssget (append '("_c") (pickbox (cadr pt1)) (list ssparm)))))
)
(progn
(princ "指定对角点: ")
(setq pt1 (list (caadr pt1) (cadadr pt1)))
(while (not (member (car (setq pt2 (grread T 12 1))) '(3 11)))
(setq pt2 (list (caadr pt2) (cadadr pt2)))
(if (vl-consp pt1)
(progn
(if (> (distance PT2 PT) (p2u (* 0.0001 (car (getvar "screensize")))))
(progn
(redraw)
(setq len (p2u 1) x (car pt) y (cadr pt) co (abs co))
(if (> (car pt1) (car pt2)) (setq co (- co)))
(d_brush col x y len)
(grvecs (list co pt1 (list (car pt1) (cadr pt2))
co pt2 (list (car pt1) (cadr pt2))
co pt2 (list (car pt2) (cadr pt1))
co pt1 (list (car pt2) (cadr pt1))
)
)
(setq pt pt2
ss1 (ssget (if (minusp co) "_c" "_w") pt1 pt2 ssparm)
)
)
)
)
)
)
)
)
(or ss (setq ss (ssadd)))
(if ss1
(repeat (setq i (sslength ss1))
(setq e (ssname ss1 (setq i (1- i))))
(ssadd e ss)
(redraw e 3)
(apply fun (list e))
))
(setq ss1 nil)
)
(redraw)
ss
)

(defun lt:match (pt col ssparm fun / d_brush pickbox p2u len x y msg pt1 ss1 pt2 co i e ss)
  (defun d_brush (col x y len / a b c)
    (grvecs (list col (list (- x (setq A (* len 1.5))) (- y len))
                      (list (- x A) (setq B (- y (* len 7.5))))
                  col (list (- x (setq C (* len 0.5))) y)
                      (list (- x C) B)
                  col (list (+ x C) y)
                      (list (+ x C) B)
                  col (list (+ x A) (- y len))
                      (list (+ x A) B)
                  col (list (- x (setq A (* len 4.5))) B)
                      (list (+ x A) B)
                  col (list (- x A) B)
                      (list (- x (setq C (* len 6.5))) (- y (* len 9)))
                  col (list (+ x A) B)
                      (list (+ x C) (setq A (- y (* len 9))))
                  col (list (- x C) A)
                      (list (- x C) (setq B (- y (* len 17))))
                  col (list (+ x C) A)
                      (list (+ x C) B)
                  col (list (- x C) (setq A (- y (* len 10))))
                      (list (+ x C) A)
                  col (list (- x C) (setq A (- y (* len 11))))
                      (list (+ x C) A)
                  col (list (- x C) (setq A (- y (* len 13))))
                      (list (+ x C) A)
                  col (list (- x C) (setq A (- y (* len 14))))
                      (list (+ x C) A)
                  col (list (- x C) B)
                      (list (+ x C) B)
                  col (list (- x C) B)
                      (list (- x (* len 11)) (setq A (- y (* len 21.5))))
                  col (list (- x (* len 2)) B)
                      (list (- x (* len 6.5)) A)
                  col (list (+ x (* len 2)) B)
                      (list (- x (* len 2.5)) A)
                  col (list (+ x C) B)
                      (list (+ x (* len 2)) A)
                  col (list (- x (* len 11)) A)
                      (list (+ x (* len 3)) A)
            )
            (list (list 1 0 0 (* len 14))
                  (list 0 1 0 (* len -4)) '(0 0 1 0) '(0 0 0 1)
            )
    )
  )
  (defun pickbox (pt / si cv)
    (setq si (* (/ (getvar "pickbox") (cadr (getvar "screensize"))) (getvar "viewsize") 0.5)
          cv (list si si 0)
    )
    (list (mapcar '+ pt cv) (mapcar '- pt cv))
  )
  (defun p2u (pix) (* pix (/ (getvar "viewsize") (cadr (getvar "screensize")))))
  (or (setq co (cadr col)) (setq co 7))
  (or (setq col (car col)) (setq col 7))
  (or (setq msg (car ssparm)) (setq msg "\n选择目标对象: "))
  (setq ssparm (cadr ssparm) len (p2u 1) x (car pt) y (cadr pt))
  (princ msg)
  (while (/= (car pt1) 11)
    (redraw)
    (d_brush col x y len)
    (while (not (member (car (setq pt1 (grread T 12 2))) '(3 11)))
      (setq pt1 (cadr pt1))
      (if (vl-consp pt1)
        (progn
          (if (> (distance PT1 PT) (p2u (* 0.0001 (car (getvar "screensize")))))
            (progn
              (redraw)
              (setq len (p2u 1) x (car pt) y (cadr pt))
              (d_brush col x y len)
              (setq pt pt1)
            )
          )
        )
      )
    )
    (redraw)
    (if (and (= (car pt1) 3)
             (princ msg)
             (not (setq ss1 (apply 'ssget (append '("_c") (pickbox (cadr pt1)) (list ssparm)))))
        )
      (progn
        (princ "指定对角点: ")
        (setq pt1 (list (caadr pt1) (cadadr pt1)))
        (while (not (member (car (setq pt2 (grread T 12 1))) '(3 11)))
          (setq pt2 (list (caadr pt2) (cadadr pt2)))
          (if (vl-consp pt1)
            (progn
              (if (> (distance PT2 PT) (p2u (* 0.0001 (car (getvar "screensize")))))
                (progn
                  (redraw)
                  (setq len (p2u 1) x (car pt) y (cadr pt) co (abs co))
                  (if (> (car pt1) (car pt2)) (setq co (- co)))
                  (d_brush col x y len)
                  (grvecs (list co pt1 (list (car pt1) (cadr pt2))
                                co pt2 (list (car pt1) (cadr pt2))
                                co pt2 (list (car pt2) (cadr pt1))
                                co pt1 (list (car pt2) (cadr pt1))
                          )
                  )
                  (setq pt  pt2
                        ss1 (ssget (if (minusp co) "_c" "_w") pt1 pt2 ssparm)
                  )
                )
              )
            )
          )
        )
      )
    )
    (or ss (setq ss (ssadd)))
    (if ss1
    (repeat (setq i (sslength ss1))
      (setq e (ssname ss1 (setq i (1- i))))
      (ssadd e ss)
      (redraw e 3)
      (apply fun (list e))
    ))
    (setq ss1 nil)
  )
  (redraw)
  ss
)

nonsmall · 发表于 2008-12-6 13:48

本帖最后由作者于 2008-12-7 18:06:08 编辑

;;批量清理一个文件夹下面的图纸

;;不断打开图清理

;; by nonsmall @ mjtd

(defun c:puall( / doc_now docs dwg dwg_files folder read_only)
(vl-load-com)
(setq docs (vla-get-documents (vlax-get-acad-object)))
(setq folder (acet-ui-pickdir))
(if (and folder (setq dwg_files (vl-directory-files (setq folder (strcat (vl-string-right-trim "\\" folder) "\\")) "*.dwg" 1)))
  (progn
   (setq read_only "")
   (foreach dwg dwg_files
    (setq doc_now(vla-open docs (strcat folder dwg)))
    (if (= :vlax-true (vla-get-readonly doc_now))
     (progn
      (setq read_only (strcat read_only "\n" dwg))
      (vla-close doc_now :vlax-false)
     )
     (progn
      (vla-PurgeAll doc_now)
      (vla-close doc_now :vlax-true dwg)
     )
    )
   )
   (if (/= "" read_only)
    (alert (strcat "This drawings are readonly:\n" read_only))
   )
  )
)
(princ "Complete")
(princ)
)

nonsmall · 发表于 2008-12-6 13:57

（转）读取系统进程的函数

;;Writed By Patrick_35 @ TheSwamp.org
(defun appli(/ apps item lst meth1 meth2 WMI)
(setq WMI (vlax-create-object "WbemScripting.SWbemLocator")
        meth1 (vlax-invoke WMI 'ConnectServer nil nil nil nil nil nil nil nil)
        meth2 (vlax-invoke meth1 'ExecQuery "Select * from Win32_Process"))
(vlax-for item meth2
    (setq lst (append lst (list (vlax-get item 'CommandLine))))
)
(vlax-release-object WMI)
(vlax-release-object meth1)
(vlax-release-object meth2)
(vl-remove nil lst)
)

caoyin · 发表于 2008-12-6 14:10

多谢 nonsmall 支持

liminnet · 发表于 2008-12-6 18:57

本帖最后由作者于 2008-12-6 19:29:09 编辑

本人属于发贴多者（一千多篇）、活跃会员，以前没想过会写程序，也不敢想，最记的是caoyin大哥叫我也要学着写程序，慢慢的觉的程序有好多事是可以做的，包括坏事和好事，终于，现在自己有一点成就啦，功力有一点点啦，所以说，我的学程序的心得是：

<<源起明经，蒙由caoyin，取名koyote,报回明经>>

我也来贡献啦支持caoyin版主

我在晓东上找的，但原来的没这么完善和功能这么多和以前有BUG现在我调试后一个也没有啦，按ESC键会删掉生成的对象，经过本人多次调试，现在已经是天下无敌啦，如果大家有什么好的建议，请留下，大家一起学习

;|

动态和可以吃后悔药的等距复制和平分距离复制程序

This program by koyote k.o (鬼谷子)

有问题请发至邮箱：koyote@mjtd.com

|；

(defun koyote (/ convert-pline #koerr ttt p1 p2 s e cn pt2 ttt an ee $oerr oneena ns nss firstss firstena)
;;++++++++++++++++++++++++
(defun #koerr (s)
     (setq *error* $oerr)
     (cmd0)
     (if firstss (command "erase" firstss ""))
     (if nss (command "erase" nss ""))
     (princ)
);;定义错误函数
;;++++++++++++++++++++++++
(defun convert-pline (ss / ena sss i)
(setq i -1 sss (ssadd))
(while (setq ena (ssname ss (setq i (1+ i))))
       (if (= (dxf 0 (entget ena)) "POLYLINE")
             (setq sss (ssadd (ko-convert-pline ena) sss))
              (setq sss (ssadd ena sss))
       )
)
sss
)
;;++++++++++++++++++++++++
   (defun undoaction (ss n);;修改间距程序
         (cmd0)
         (if firstss (command "erase" firstss ""))
         (if nss (command "erase" nss ""))
         (setq c2-dis (atof n))
         (setq p2 (polar p1 an c2-dis))
         (vl-cmdf "copy" ss "" "non" p1 p2)
         (setq firstena e)
         (while (setq firstena (entnext firstena))
            (setq firstss (ssadd firstena firstss));;得到最后生成对象的选择集用以按下ESC时删掉它闪
         )
   )
;;++++++++++++++++++++++++
(defun ttt (ss n / m ee eee)
    (setq ee e ns (ssadd) nss (ssadd))
    (while (setq ee (entnext ee))
      (setq ns (ssadd ee ns))
    )
    (vl-cmdf "erase" ns "")
    (vl-cmdf "copy" ss "" "m" "non" p1)
    (setq m 0)
    (repeat (atoi n)
      (setq m (1+ m))
      (cond
((= "b" (substr n (strlen n)))
         (cmd0)
(vl-cmdf
    "non"
    (mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n)))))
     p1
     p2
    )
)
)

(t
           (cmd0)
    (vl-cmdf "non"
      (mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)
    )
)
     );end_cond
   );end_repeat
   (command)
    (setq eee e)
    (while (setq eee (entnext eee))
      (setq nss (ssadd eee nss));;得到最后生成对象的选择集用以按下ESC时删掉它闪
    )

)
;__________________
(princ "\n选择要复制的物体:")
(setq $oerr *error*)
(setq *error* #koerr)
(cmd0)
(if (setq s (ssget));;空格时静静退出
(progn
(setq s (convert-pline s));;当遇到二维多段线把集中的转为多段线
(setq p1 (getpoint "\n复制的起点:"))
(setvar "lastpoint" p1)
(setq PT2 (getpoint P1 "\n请指定方向:")) (setq c2-dis (koreal "\n复制距离:" 300 5 c2-dis))
(setq e (entlast))
(setq an (angle P1 PT2))
(setq p2 (polar p1 an c2-dis))
(vl-cmdf "copy" s "" "non" p1 p2)
(setq firstena e firstss (ssadd)) (princ "距离为") (princ c2-dis)
(while (setq firstena (entnext firstena))
      (setq firstss (ssadd firstena firstss));;得到最后生成对象的选择集用以按下ESC时删掉它闪
)
(if (not (equal p1 p2))
    (while (/= 0
        (atof (setq cn (getstring (strcat "\n输入数值n并以b结束=间距内等分n次复制输入数值n并以空格结束=按间距复制n次输入数值并以e结束=修改间距" "\n请按提示输入<退出>:"))))
    )
       (cond
         ((= "e" (substr cn (strlen cn))) (undoaction s cn))
         (t (ttt s cn))
       )
    )
)
)
)
(setq *error* $oerr)
(princ)
)

最后给明经老大一个建议，本人经常用手机上网，总结出了一个这样的经验，就是如果LSP程序是做成一个文件后，再放在贴中的，用手机留缆时当不知道那个函数的功能时，是可以去查看的，如果，LSP程序是直接贴在贴中的，我们就查不到，也不能看到函数的功能啦，所有建议程序还是做成LSP文件后，再上传，这样就比较好啦，能完善的话就好啦，不行的话也没关系，，嘻嘻。。。。

liminnet · 发表于 2008-12-6 19:26

本帖最后由作者于 2008-12-7 11:41:59 编辑

再传一个，koyote版变种ssget函数，部分代码是nonsmall提供，其他都是自己找的，思路是本人想出来的

;|

增强型及变种型ko->ssget

语法：

(ko->ssget msg keyword action filter_list firstss)

功能及参数

功能：支持直接点选和多选或先选择对象再执行程序，返回选择集或字符串(包括关键字或实数或整数)或用空格结束返回nil
可控制关键字是否需要空格或回车键或右键来响应程序

参数 [类型]:

msg         = 注释 [STR] 值为空字符串""，或 "\n程序爱好者:鬼谷子或koyote或liminnet:"
keyword     = initget的keyword 关键字[STR],不考虑时参数为nil或关键字必须大写和单词间至少留一位空格 "W G"或"Undo Option eXit"
action      =控制keword是否需要空格或回车键或右键来响应,具备天正的命令的功能 T或nil(大小写不分)[SYM]
filter_list = 过滤字符表.参见ssget [LIST]，不考虑时参数为nil '((0 . "*LINE,CIRCLE,ARC"))或(list '(0 . "*LINE,CIRCLE,ARC"))
firstss     =ssgetfirst功能，参数值nil或选择集，nil的话命令没有启动时所选择的对象集无效，反之则是，如果filter_list存在，会过滤掉不符合条件的

对象
注意：firstss参数如果要启用时，语句(setq firstss (cadr (ssgetfirst)))一定要放在主程序最前面一行
范例:

1.(ko->ssget "\n选择直线或圆/Undo/Option/eXit"

"Undo Option eXit" t '((0 . "*LINE,CIRCLE,ARC")) nil)
2.firstss用法例子
测试:

(defun c:tt()
(setq firstss (cadr (ssgetfirst)));;注意：firstss参数如果要启用时，语句(setq firstss (cadr (ssgetfirst)))一定要放在主程序最前面一行
(setq xh t)
(while xh
    (setq ent (ko-ssget "\n测试ko-ssget函数(X)/(H):" "X H" T '((0 . "*LINE,CIRCLE,ARC")) firstss))
    (cond ((= ent "X") (alert "等于字符串X你要执行的程序一") ent)
          ((= ent "H") (alert "等于字符串H你要执行的程序二") ent)
          ((= (type ent) 'PICKSET) (alert "这个功能是返回选择集") (setq xh nil) ent)
          ((numberp ent) (alert (strcat "此项功能是判断输入的是否是实数或整理,
                                       用于不用进入子选项而直接设置一个值" "\n"
                                       "请选择要拉伸的对象或[当前默认值(500)或直接输入值回车改变默认值]"))
            ent
          )
          ((= ent nil) (setq xh nil))
    )
)
)

(defun c:ff()
(ko-ssget "\n[选择你要标注的对象或修改(F)/(W)]<" "Fdf dWg eXit" t (list '(0 . "*LINE,CIRCLE,ARC")) nil)
)
|;

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

【分享明经——发程序、拜新年专贴】

评分

本帖被以下淘专辑推荐:

评分

评分

评分

评分

本帖子中包含更多资源

点评

评分

评分

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分