| 作者: summerfly2008 发布日期:
2006-4-26 |
一、cmdla－序列
位于程序的开始和结束，用于存储和恢复用户的系统变量……
代码:
;;;通用子程序
;;;------------------------ CMDLA0 -------------------------
;;;------------------------ CMDLASC0 -----------------------
;;; 保存用户系统变量
;;;方式 : (CMDLA0)
(defun CMDLASC0 ()
(CMDLA0)
(if (null sc)
(SETBL)
)
)
(defun CMDLA0 ()
(defun *error* (msg)
(princ "错误 : ")
(princ msg)
(CMDLA1)
)
(SetQ **SysVarNL**
'("AUNITS" "AUPREC" "ATTDIA"
"BLIPMODE" "CECOLOR" "CELTYPE"
"CLAYER" "CMDECHO" "DIMZIN"
"EXPERT" "HIGHLIGHT" "LUNITS"
"LUPREC" "OSMODE" "ORTHOMODE"
"TEXTSTYLE" "PLINEWID" "dimdec"
"dimadec" "regenmode" "pickbox"
)
#time1 (rtos (getvar "cdate") 2 16)
start-time (substr (rtos (getvar "cdate") 2 16) 7)
)
(SetIErr)
(command "ucs" "")
(command ".undo" "BE")
(princ)
)
(Defun SetIErr (/ sv)
(If (= 'LIST (Type *error*))
(Alert "错误：最后一个(SetIErr)函数没有配对的(ReErr)!")
(Progn
(SetQ **svarl** '())
(ForEach sv **SysVarNL**
(SetQ **svarl** (Cons (GetVar sv) **svarl**))
)
(ForEach sv '("ATTDIA" "BLIPMODE" "CMDECHO"
"ORTHOMODE" "DIMZIN" "plinewid"
"regenmode"
)
(SetVar sv 0)
)
(setvar "ATTREQ" 1)
(SetVar "EXPERT" 5)
(setvar "pickbox" 5)
(setvar "pickadd" 1)
(setvar "aperture" 5)
(Defun-Q *error* (st) (ReErr))
)
)
)
(Defun ReErr ()
(If (= 'LIST (Type *error*))
(Progn
(MapCar 'SetVar **SysVarNL** (Reverse **svarl**))
(SetQ *error* nil)
(SetVar "modemacro" ".")
)
)
)
;;;------------------------ CMDLA1 -------------------------
;;; 恢复用户系统变量
;;;方式 : (CMDLA1)
(defun CMDLA1 ()
(command ".undo" "E")
(command "ucs" "")
(ReErr)
(princ)
)
;;; ---------------------- setbl ---------------------------
;;; 设置出图比例
;;;方式 : (setbl)
(defun setbl ()
(if (= (getvar "UserI1") 0)
(setvar "UserI1" 1)
)
(if (= (getvar "UserR1") 0)
(setvar "UserR1" 1.0)
)
(setq bl (ureal 1 "" "\n输入出图比例1 " bl)
SC (/ bl 100.0)
)
(setvar "UserR1" (/ 1.0 sc))
(command "modemacro"
(strcat " 当前出图比例 1:"
(rtos bl 2 1)
)
)
[ 本帖最后由 summerfly2008 于 2006-4-27 10:16 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
一般程序的标准格式（参考）
PHP代码:
(defun c:test ()
(cmdla0);前置函数
;;核心程序
;;……
;;……
;;……
(cmdla1);后置函数
) |
| 作者: summerfly2008 发布日期:
2006-4-26 |
二、sub_upd函数
代码:
;|
功能 : 更改图元DXF组码以修改实体属性
方式 : (SUB_UPD 实体名 DXF码 新值)
实例1 : 改圆半径为500
(sub_upd (car(entsel"\n选择圆 : ")) 40 500)
实例2 : 改文本为"晓东空间"
(sub_upd (car(entsel"\n选择文本 : ")) 1 "晓东空间")
实例3 : 改块的插入点为(0 0 0)
(sub_upd (car(entsel"\n选择块 : ")) 10 '(0 0 0))
--------------------------------------------------------
|;
(defun sub_upd (ename code newvalue)
(entmod (subst (cons code newvalue)
(assoc code (entget ename))
(entget ename)
)
)
(entupd ename)
[ 本帖最后由 summerfly2008 于 2006-4-27 10:17 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
三、文本排序函数 xyp-Sort-Text
代码:
;;文本排序函数 xyp-Sort-Text
;;(xyp-Sort-Text 文本选择集 模式)
;;mode : 0,按选择顺序排序；1，按Y轴由上到下排序；2，按Y轴由下到上排序；
;;可以扩充
(defun xyp-Sort-Text (sssel mode / lst)
(setq i -1
lst '()
)
(while (setq s1 (ssname sssel (setq i (1+ i))))
(setq pt (dxf 10 (entget s1)) ;左下角点
ename (dxf -1 (entget s1)) ;实体名
pt-tx (cons pt ename)
lst (cons pt-tx lst)
)
)
(cond ((= mode 1)
(setq
lst (vl-sort lst
(function (lambda (e1 e2)
(> (cadr (car e1)) (cadr (car e2)))
)
)
)
)
)
((= mode 2)
(setq
lst (vl-sort lst
(function (lambda (e1 e2)
(< (cadr (car e1)) (cadr (car e2)))
)
)
)
)
)
((= mode 0) (princ))
(t (princ))
)
lst
)
实例：行距调整
代码:
(DEFUN c:tzhj (/ ss pt1)
(cmdla0)
(princ "\n选择文本: ")
(if (null no4)
(setq no4 1000)
)
(while (not (SETQ SS (ssget '((0 . "TEXT"))))))
(WHILE (NOT (SETQ pt1 (getpoint "\n基点 : "))))
(setq no4 (ureal 7 "" "\n行距" no4)
tlst (xyp-Sort-Text ss 1)
n -1
y (cadr pt1)
)
(princ "\n")
(foreach tx tlst
(progn
(setq s1 (cdr tx)
pt10 (car tx)
pt1 (list (car pt10) (- y (* (setq n (1+ n)) no4)))
)
(command "move" s1 "" pt10 pt1)
(princ ".")
)
)
(princ (length tlst))
(princ " 个文本行距调整完成!")
(cmdla1)
)
[ 本帖最后由 summerfly2008 于 2006-4-27 10:17 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
四、选择集排序 xyp-Sort
xyp-Sort 是文本排序函数 xyp-Sort-Text 的扩展函数
格式：(xyp-Sort 选择集 dxf组码 mode)
返回表格式 '((组码值 实体名)(组码值 实体名)(组码值 实体名))
代码:
;;;针对选择集sssel内包含dxf组码的实体排序
;;;返回表，格式 '((组码值 实体名)(组码值 实体名)(组码值 实体名))
;;;mode : "none",按选择顺序排序；
;;;点表 'LIST
;;;"Y-max"，按Y轴由上到下排序；"Y-min"，按Y轴由下到上排序；
;;;"X-max"，按x轴由右到左排序；"X-min"，按x轴由左到右排序；
;;;值 'REAL
;;;"X-max"、"Y-max"，按从大到小排序；
;;;"X-min"、"Y-min"，按从小到大排序；
(defun xyp-Sort (sssel dxfmode mode / s1 pt ename pt-tx lst)
(setq i -1
lst '()
mode (strcase mode) ;转大写
)
(while (setq s1 (ssname sssel (setq i (1+ i))))
(if (setq pt (xyp-get-DXF dxfmode s1)) ;dxf组码值：10左下角点
(progn
(setq ename (xyp-get-DXF -1 s1) ;实体名
pt-tx (cons pt ename)
lst (cons pt-tx lst)
)
)
)
)
(if (= (type (car (car lst))) 'LIST) ;10 11组码 点表
(progn
(cond
((= mode "X-MAX")
(setq
lst (vl-sort lst
(function (lambda (e1 e2)
(> (car (car e1)) (car (car e2)))
)
)
)
)
)
((= mode "X-MIN")
(setq
lst (vl-sort lst
(function (lambda (e1 e2)
(< (car (car e1)) (car (car e2)))
)
)
)
)
)
((= mode "Y-MAX")
(setq
lst
(vl-sort lst
(function (lambda (e1 e2)
(> (cadr (car e1)) (cadr (car e2)))
)
)
)
)
)
((= mode "Y-MIN")
(setq
lst
(vl-sort lst
(function (lambda (e1 e2)
(< (cadr (car e1)) (cadr (car e2)))
)
)
)
)
)
((= mode "NONE") (princ))
(t (princ))
)
)
)
(if (= (type (car (car lst))) 'REAL) ;40 实数
(progn
(cond
((or (= mode "X-MAX") (= mode "Y-MAX"))
(setq lst (vl-sort lst
(function (lambda (e1 e2)
(> (car e1) (car e2))
)
)
)
)
)
((or (= mode "X-MIN") (= mode "Y-MIN"))
(setq lst (vl-sort lst
(function (lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
)
)
((= mode "NONO") (princ))
(t (princ))
)
)
)
lst
)
文本调整行距程序：tzhj
代码:
;;;文本调整行距
(DEFUN c:tzhj (/ ss pt1)
(cmdla0)
(princ "\n选择文本: ")
(if (null no4)
(setq no4 1000)
)
(while (not (setq SS (ssget '((0 . "TEXT"))))))
(while (not (setq pt1 (getpoint "\n基点 : "))))
(setq no4 (ureal 7 "" "\n行距" no4)
tlst (xyp-Sort ss 10 "Y-max")
n -1
y (cadr pt1)
)
(princ "\n")
(foreach tx tlst
(progn
(setq s1 (cdr tx)
pt10 (car tx)
pt1 (list (car pt10) (- y (* (setq n (1+ n)) no4)))
)
(command "move" s1 "" pt10 pt1)
(princ ".")
)
)
(princ (length tlst))
(princ " 个文本行距调整完成!")
(cmdla1)
)
[ 本帖最后由 summerfly2008 于 2006-4-27 10:17 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
五、Dxf组码函数 xyp-get-Dxf
代码:
(defun xyp-get-DXF (code ename) (cdr (assoc
[ 本帖最后由 summerfly2008 于 2006-4-27 10:18 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
六、比例设置函数 SETBL
代码:
(defun setbl ()
(if (null (vlax-ldata-get "dict" "bl"))
(setq bl 100)
(setq bl (vlax-ldata-get "dict" "bl"))
)
(setq bl (ureal
[ 本帖最后由 summerfly2008 于 2006-4-27 10:18 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
七、获得特定符号表的列表 xyp-get-tblnext
代码:
;;;获得特定符号表的列表
;;;有效符号表名称为Layer、Ltype、Viewx、Style、Block、Appid、Ucs、Dimstyle和 Vport
(defun xyp-get-tblnext (table-name / lst d)
(while (setq d (tblnext table-name (null d)))
(setq lst (cons (dxf 2 d) lst))
)
(reverse lst)
lst
)
测试：
命令: (xyp-get-tblnext "layer")
("阿基米德螺旋线" "建筑-厨卫" "0")
[ 本帖最后由 summerfly2008 于 2006-4-27 10:19 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
8、xyp-DelSame 删除表中的重复元素
代码:
(defun xyp-DelSame (ptlst / nl lst)
(mapcar '(lambda (x)
(if (not (member x nl))
(setq nl (cons x nl))
)
)
ptlst
)
(setq nl (reverse nl))
nl
)
或
代码:
(defun xyp-DelSame (ptlst / nl lst)
(foreach x ptlst
(if (not (member x nl))
(setq nl (cons x nl))
)
)
(setq nl (reverse nl))
nl
)
测试：
Command: (xyp-delsame '(a a b c d a 12 3 45 12 a))
(A B C D 12 3 45)
[ 本帖最后由 summerfly2008 于 2006-4-27 10:19 编辑 ] |
| 作者: summerfly2008 发布日期:
2006-4-26 |
9、xyp-Text 定点写字
代码:
;;;---------------- xyp-Text -----------------
;;;定点写字
;;;(xyp-Text 点表 mode 文本)
;;;mode模式＝1～9，下中上9位码；其他均为MC点位
;;; 7 8 9
;;; ------------------
;;; | |
;;; | |
;;; | |
;;; 4| 5 |6
;;; | |
;;; | |
;;; | |
;;; ------------------
;;; 1 2 3
(defun xyp-Text (point mode textobj)
(if (null sc)(setbl))
(jzhz)
(cond ((= mode 1)(command "text" "j" "BL" point (* sc 300) "0" textobj))
((= mode 2)(command "text" "j" "BC" point (* sc 300) "0" textobj))
((= mode 3)(command "text" "j" "BR" point (* sc 300) "0" textobj))
((= mode 4)(command "text" "j" "ML" point (* sc 300) "0" textobj))
((= mode 5)(command "text" "j" "MC" point (* sc 300) "0" textobj))
((= mode 6)(command "text" "j" "MR" point (* sc 300) "0" textobj))
((= mode 7)(command "text" "j" "TL" point (* sc 300) "0" textobj))
((= mode 8)(command "text" "j" "TC" point (* sc 300) "0" textobj))
((= mode 9)(command "text" "j" "TR" point (* sc 300) "0" textobj))
(t (command "text" "j" "MC" point (* sc 300) "0" textobj))
)
)
修改版：
代码:
(defun xyp-Text (point mode textobj / tmode)
(if (null sc)(setbl))
(jzhz)
(cond ((= mode 1)(setq tmode "BL"))
((= mode 2)(setq tmode "BC"))
((= mode 3)(setq tmode "BR"))
((= mode 4)(setq tmode "ML"))
((= mode 5)(setq tmode "MC"))
((= mode 6)(setq tmode "MR"))
((= mode 7)(setq tmode "TL"))
((= mode 8)(setq tmode "TC"))
((= mode 9)(setq tmode "TR"))
(t (setq tmode "MC"))
)
(command "text" "j" tmode point (* sc 300) "0" textobj)
)
再修改：
代码:
(defun xyp-Text (mode point textobj / tmode)
(if (null sc)
(setbl)
)
(jzhz)
(cond ((= mode 1) (setq tmode "BL"))
((= mode 2) (setq tmode "BC"))
((= mode 3) (setq tmode "BR"))
((= mode 4) (setq tmode "ML"))
((= mode 5) (setq tmode "MC"))
((= mode 6) (setq tmode "MR"))
((= mode 7) (setq tmode "TL"))
((= mode 8) (setq tmode "TC"))
((= mode 9) (setq tmode "TR"))
((or (null mode) t) (setq tmode "MC"))
)
(command "text" "j" tmode point (* sc 300) "0" textobj)
)
[ 本帖最后由 summerfly2008 于 2006-4-27 10:20 编辑 ] |
