<p>收藏无版的程序</p><p>无版的马甲好多哦，呵呵！</p>
<p>再次祝明经的新老朋友：</p><p><font color="#ff0000"><strong><u>圣诞快乐，新年发财！牛年牛气！</u></strong></font></p>
caoyin老大，我的程序收视率好高呀，是不是有奖呀
本帖最后由 作者 于 2008-12-13 19:29:09 编辑
恭喜你啊，点击率高有奖啊，哈哈，你要什么奖啊，请明总给你颁发发帖量最高奖
谢谢caoyin老大帮我加份啦，我的宝贝还是有点，迟点再公布一个好多人都想看的宝贝，哈哈。。。。
晕了!
本帖最后由 作者 于 2008-12-18 9:50:23 编辑
好久没有认认真真来看论坛的每一讨论的话题了,主要是手上的开发工作太多工作压力大。今天看了这个贴上面好多朋友发表了他们精心设计的程序代码很，我觉的我们明经上面拥有很多很多不同功能的程序源代码。对初学者或有资深经验的开发者来讲明经是一个给他们的前进加油的主站。精明一点的朋友稍稍努力地整理一下我们明经论坛上面的每一个朋友发表的程序组合起来，可以很高效、很稳健的开发出一个很棒的行业软件的。
今天，我到我开发了几年的LISP包里面抽一个简单的LISP代码发在这里，希望对初学者有一定的帮助：）
;功能: 键盘控制对象进行移动
;编程: 包达勇
;时间: 2005-07-19
(DEFUN C:MMad (/ BASEPOINT0 BASEPOINT1 BASEPOINT2 CENTPOINT D KEYLIST LOOP N OS SSET STEP)
(SETVAR "CMDECHO" 0)
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(SETQ loop 1)
(WHILE loop
(PROMPT "\nSelect object of auto move : ")
(SETQ SSet (SSGET))
(COND
((NULL SSet)(ALERT "还没有选择对象,重新选择!"))
(T (SETQ loop nil))
)
)
(setq step nil)
(SETQ step (getreal "\n输入移动的步长<1>:"))
(if (= step nil) (SETQ step 1.0))
;;;(PRINC "\n Press key:")
;;;(PRINC "\n\t E --- UP")
;;;(PRINC "\n\t D --- DOWN")
;;;(PRINC "\n\t S --- LEFT")
;;;(PRINC "\n\t F --- RIGHT")
(PRINC "\n请按方向键:")
(TERPRI)
;;;(ascii "e")=101
;;;(ascii "d")=100
;;;(ascii "s")=115
;;;(ascii "f")=102
;;;(ascii "q")=113
;;;(ascii "+")=43
;;;(ascii "-")=45
;;;(ascii "E")=69
;;;(ascii "D")=68
;;;(ascii "S")=83
;;;(ascii "F")=70
(SETQ KeyList '(101 100 115 102 32 43 45 69 68 83 70 50 52 54 56 3))
(SETQ n (CADR (GRREAD D)))
(WHILE (/= n 32);;; 32代表空格键完成退出这个程序
(WHILE (NOT (MEMBER n KeyList))
(SETQ n (CADR (GRREAD)))
)
(SETQ BasePoint0'(0 0 0));(LIST 0 0)
(SETQ BasePoint1 (LIST (CAR BasePoint0) (+(CADR BasePoint0)step)));(LIST 0 step)
(SETQ BasePoint2 (LIST (+(CAR BasePoint0) step) (CADR BasePoint0)));(LIST step 0)
(COND
((EQUAL n 101)(COMMAND "MOVE" SSet "" BasePoint0 BasePoint1)(PRINC "\r向上移动")(princ step)(princ "mm:"));键盘T
((EQUAL n 69)(COMMAND "MOVE" SSet "" BasePoint0 BasePoint1)(PRINC "\r向上移动")(princ step) (princ "mm:"));键盘T
((EQUAL n 56)(COMMAND "MOVE" SSet "" BasePoint0 BasePoint1)(PRINC "\r向上移动")(princ step) (princ "mm:"));键盘T
((EQUAL n 100)(COMMAND "MOVE" SSet "" BasePoint1 BasePoint0)(PRINC "\r向下移动")(princ step) (princ "mm:"));键盘D
((EQUAL n 50)(COMMAND "MOVE" SSet "" BasePoint1 BasePoint0)(PRINC "\r向下移动")(princ step) (princ "mm:"));键盘D
((EQUAL n 68)(COMMAND "MOVE" SSet "" BasePoint1 BasePoint0)(PRINC "\r向下移动")(princ step)(princ "mm:"));键盘D
((EQUAL n 115) (COMMAND "MOVE" SSet "" BasePoint2 BasePoint0)(PRINC "\r向左移动")(princ step)(princ "mm:"));键盘S
((EQUAL n 52) (COMMAND "MOVE" SSet "" BasePoint2 BasePoint0)(PRINC "\r向左移动")(princ step)(princ "mm:"));键盘S
((EQUAL n 83) (COMMAND "MOVE" SSet "" BasePoint2 BasePoint0)(PRINC "\r向左移动")(princ step )(princ "mm:"));键盘S
((EQUAL n 102)(COMMAND "MOVE" SSet "" BasePoint0 BasePoint2)(PRINC "\r向右移动")(princ step)(princ "mm:"));键盘F
((EQUAL n 70)(COMMAND "MOVE" SSet "" BasePoint0 BasePoint2)(PRINC "\r向右移动")(princ step)(princ "mm:"));键盘F
((EQUAL n 54)(COMMAND "MOVE" SSet "" BasePoint0 BasePoint2)(PRINC "\r向右移动")(princ step)(princ "mm:"));键盘F
((EQUAL n 3)(COMMAND "MOVE" SSet "" BasePoint0 BasePoint2)(PRINC "\r向右移动")(princ step)(princ "mm:"));鼠标键
;;; ((EQUAL n 43)(setq step (1+ step)));;;移动加速
;;; ((EQUAL n 45)(setq step (- step 1.0)));;;移动减速
((= n 43)(setq step (1+ step)) (princ "\r移动步长=")(princ step))
((= n 45)(setq step (- step 1)) (princ "\r移动步长=")(princ step))
)
(SETQ n (CADR (GRREAD)))
);WHILE
(setvar "osmoDe" os )
(SETVAR "CMDECHO" 1)
(PRINC)
)
本帖最后由 作者 于 2009-2-8 10:00:30 编辑
如果有问题，56楼有一个临时修正版;;; NCOPY.lsp
;;; By MJTD.com @ Caoyin 2007-6-20
;;; 仿照 ET 的 NCOPY，并扩展增强其功能
;;; 从块(或属性)、多段线、多线或标注中复制套嵌对象(子图元)
;;; 替代 ExpressTools 的 NCOPY 命令，ExpressTools 仅支持块对象
;;; 支持 NUS 块
;;; 暂不支持填充图案
(defun C:NCOPY (/ OS SS NEN $LT-ENTSEL$ EN ES EP P1 ELST TYP EN1 PP P2 SC DOC BLKS BLK)
(setq OS (getvar "osmode"))
(sssetfirst nil nil)
(lt:error-init '(("cmdecho" 0 "osmode" 0 "qaflags" 1 "explmode" 1) 1 nil))
(setq SS (ssadd))
(princ "\n复制块、多段线、多线或标注中的套嵌对象...")
(setq $LT-ENTSEL$ T)
(while (setq NEN (lt:entsel nil nil nil))
(if (= (length NEN) 2)
(setq EN (car NEN))
(setq EN (car (last NEN)))
)
(cond ((if (ssmemb EN SS)
(princ "重复选择，忽略。")
(progn
(setq ELST (entget EN)
TYP(cdr (assoc 0 ELST))
)
nil
)
)
)
((= TYP "MLINE")
(entmake ELST)
(setq EN1 (entlast))
(command "_.explode" EN1 "")
(setq ES(lt:ss->list (ssget "_P"))
P1(cadr NEN)
EN1 (nth (car (vl-sort-i
(mapcar '(lambda (X)
(distance (vlax-curve-getClosestPointTo X P1) P1)
)
ES
)
'<
)
)
ES
)
)
(foreach X ES
(if (not (eq X EN1)) (entdel X))
)
)
((= TYP "LWPOLYLINE")
(setq PP (fix (vlax-curve-getParamAtPoint
EN
(apply 'vlax-curve-getClosestPointTo NEN)
)
)
ELST1 (lt:list-sub ELST 0 (vl-position (assoc 10 ELST) ELST))
ELST1 (subst '(70 . 0) (assoc 70 ELST1) ELST1)
ELST2 (member (assoc 10 ELST) ELST)
ELST3 (member (assoc 210 ELST2) ELST2)
)
(if (and (vlax-curve-isClosed EN)
(/= (setq EP (vlax-curve-getEndParam EN)) 1)
(= EP (1+ PP))
)
(setq ELST2 (append (lt:list-sub ELST2 (* PP 4) 4)
(lt:list-sub ELST2 0 4)
)
)
(setq ELST2 (lt:list-sub ELST2 (* PP 4) 8))
)
(entmake (append ELST1 ELST2 ELST3))
(setq EN1 (entlast))
)
((= TYP "INSERT")
(setq SC (mapcar '(lambda (X) (assoc X ELST)) '(10 41 42 43 50))
P1 (cdar SC)
SC (cdr SC)
)
(entmake (entget (car NEN)))
(setq EN1 (entlast)
DOC (vla-get-activedocument (vlax-get-acad-object))
BLKS (vla-get-Blocks DOC)
)
(vlax-invoke DOC
'CopyObjects
(list (en2obj EN1))
(setq BLK (vla-add BLKS (vlax-3d-point '(0 0 0)) "*U"))
)
(setq BLK (vla-get-name BLK))
(entdel EN1)
(entmake (vl-list* '(0 . "INSERT") (cons 2 BLK) (cons 10 P1) SC))
(setq EN1 (entlast))
(vl-catch-all-apply 'vla-delete (list (vla-item BLKS BLK)))
)
((= TYP "ATTRIB")
(princ "\n所选对象为属性，自动转换为单行文字...")
(setq ELST (vl-remove-if '(lambda (X)
(member (car X) '(-1 0 330 5 100 2 70 71 72 74))
)
ELST
)
)
(entmake (cons '(0 . "TEXT") ELST))
(setq EN1 (entlast))
)
((= TYP "DIMENSION")
(entmake (entget (car NEN)))
(setq EN1 (entlast))
)
(T (command "_.copy" EN "" "0,0" "@")
(setq EN1 (entlast))
)
)
(if EN1 (progn (ssadd EN1 SS) (redraw EN1 3)))
)
(if (and SS (/= (sslength SS) 0))
(progn
(setvar "osmode" OS)
(if (setq P1 (getpoint "\n指定基点 <原位置>: "))
(progn
(command "_.move" SS "" "_non" P1)
(princ "指定第二点: ")
(command "\\")
)
)
(if (equal (getvar "lastpoint") P1 1e-7)
(command "_.erase" SS "")
)
(command "_.select" SS "")
(if (setq SS1 (ssget "_P" '((0 . "INSERT"))))
(command "_.explode" SS1 "");;;
)
(command "_.select" SS "")
)
)
(lt:error-restore)
)
;;-----------------------------------------------------
;;本程序支持函数
(defun lt:list-sub (lst sta len / item n)
(setq item (nth sta lst) n (- (length lst) sta))
(while (/= (length (setq lst (member item lst))) n) (setq lst (cdr lst)))
(setq item (nth (1- len) lst) lst (reverse lst))
(while (/= (length (setq lst (member item lst))) len) (setq lst (cdr lst)))
(reverse lst)
)
(defun lt:ss->list (ss / lst)
(foreach x (ssnamex ss)
(if (= (car x) 3) (setq lst (append lst (list (cadr x)))))
)
lst
)
;; lt:entsel --> 见本帖3楼
;; lt:error-init lt:error-restore
;; --> http://bbs.mjtd.com/forum.php?mod=viewthread&tid=59013&replyID=&skin=1
本帖最后由 作者 于 2008-12-18 14:19:59 编辑
;;;修改任意对象的颜色(MLINE除外)---caoyin
;;;龙龙仔版主有这样一个程序，我学着写了一个
;;;--------------------------------------------------------------
(defun c:ChColor (/ SS BLKS I BNLst)
(if (and (setq SS (lt:ssget '("\n选择要修改颜色的对象: ")))
(or $ChColor$ (setq $ChColor$ 7))
(setq $ChColor$ (acad_colordlg $ChColor$))
)
(progn
(setq BLKS(vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
(defun ChColor (OBJ / oName BlkName)
(setq oName (vla-get-ObjectName OBJ))
(cond
((wcmatch oName "*Dimension,AcDbLeader,AcDbFcf")
(vla-put-DimensionLineColor OBJ $ChColor$)
(if (wcmatch oName "*Dimension")
(progn
(vla-put-ExtensionLineColor OBJ $ChColor$)
(if (setq BlkName (assoc 2 (entget (vlax-vla-object->ename OBJ))))
(vlax-for OBJ (vla-item Blks (cdr BlkName))
(vla-put-color OBJ $ChColor$)
)
)
)
)
(if (wcmatch oName "*Dimension,AcDbFcf")
(vla-put-TextColor OBJ $ChColor$)
)
)
((= oName "AcDbBlockReference")
(setq BlkName (vla-get-name OBJ))
(if (not (member BlkName BNLst))
(progn
(setq BNLst (cons BlkName BNLst))
(vlax-for X (vla-item Blks BlkName)
(ChColor X)
)
)
)
(if (= (vla-get-HasAttributes OBJ) :vlax-true)
(foreach X (vlax-invoke OBJ 'getattributes)
(vla-put-color X $ChColor$)
)
)
)
)
(vla-put-color obj $ChColor$)
)
(repeat (setq I (sslength SS))
(setq OBJ (vlax-ename->vla-object (ssname SS (setq I (1- I)))))
(ChColor OBJ)
)
)
)
(princ)
)
;;;-----------------支持函数
;; lt:ssget --> 见本帖3楼
本帖最后由 作者 于 2008-12-18 14:19:01 编辑
;; 删除块中属性--- by caoyin
(defun C:BLKRMATT (/ DELATT SS I EN EL LST)
(LT:ERROR-INIT '(nil 1 nil "删除块中属性: BLKRMATT "))
(defun DELATT (ENAME / OBJ BN BNLST)
(setq OBJ (vlax-ename->vla-object ENAME)
BN(vla-get-Name OBJ)
)
(if (= (vla-get-HasAttributes OBj) :vlax-true)
(progn
(foreach x (vlax-invoke OBJ 'getattributes)
(vla-delete X)
)
(if (not (member BN BNLST))
(progn
(setq BNLST (cons BN BNLST))
(vlax-for X
(vla-item (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
BN
)
(if (= (vla-get-ObjectName X) "AcDbAttributeDefinition")
(vla-delete X)
)
)
)
)
)
)
)
(if (setq SS (LT:SSGET '("\n选择要删除属性的块: " ((0 . "INSERT") (66 . 1)))))
(progn
(princ "已更新 ")
(repeat (princ (setq I (sslength SS)))
(setq EN (ssname SS (setq I (1- I)))
EL (entget EN)
)
(DELATT EN)
(entmake (vl-remove (assoc 66 EL) EL))
(setq LST (cons (entlast) LST))
(entdel EN)
)
(foreach X LST (ssadd X SS)) ;;确保程序执行完毕可执行 (ssget "_P")
(LT:SS-ACTIVE SS)
(princ " 个对象。")
)
)
(LT:ERROR-RESTORE)
)
;;;-----------------支持函数
(defun lt:ss-active (ss)
(sssetfirst nil ss)
(ssget "_I")
(sssetfirst)
)
;; lt:ssget --> 见本帖3楼
;; lt:error-init lt:error-restore
;; --> http://bbs.mjtd.com/forum.php?mod=viewthread&tid=59013&replyID=&skin=1
;;