通用函数揭密与改进

summerfly2008 · 发表于 2006-4-27 10:05

通用函数是以往程序的提炼和总结，使新编程序简洁可读。
以下函数仅供参考，请大家批评指正，能否更高效简洁？任何高见均会被采纳！
PHP代码:

目录：
1、cmdla--  序列位于程序的开始和结束，用于存储和恢复用户的系统变量
2、sub_upd  更改图元DXF组码以修改实体属性
3、xyp-Sort-Text  文本排序
4、xyp-Sort  选择集排序
5、xyp-get-DXF  Dxf组码
6、SETBL  比例设置
7、xyp-get-tblnext  获得特定符号表的列表
8、xyp-DelSame  删除表中的重复元素
9、xyp-Text  定点写字
10、U系列函数
11、xyp-get-MinMaxPoint  指定对象最小外接矩形的九点坐标
12、xyp-get-RightPoint  两点中点之正方向点
13、xyp-ZB  坐标标注函数
14、XYP-GET-COLOR  取得物体的颜色（含随层）

[ 本帖最后由 summerfly2008 于 2006-4-27 10:15 编辑 ]

summerfly2008 · 发表于 2006-4-27 10:06

一、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-27 10:07

一般程序的标准格式（参考）

PHP代码:　　　　　　　　　　　　　　　　　　　　　　　　　　　
(defun c:test ()
  (cmdla0);前置函数
  ;;核心程序
  ;;……
  ;;……
  ;;……
  (cmdla1);后置函数
)

summerfly2008 · 发表于 2006-4-27 10:08

二、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-27 10:08

三、文本排序函数 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-27 10:09

四、选择集排序 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-27 10:09

五、Dxf组码函数 xyp-get-Dxf
代码:
(defun xyp-get-DXF (code ename) (cdr (assoc

[ 本帖最后由 summerfly2008 于 2006-4-27 10:18 编辑 ]

summerfly2008 · 发表于 2006-4-27 10:09

六、比例设置函数 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-27 10:09

七、获得特定符号表的列表 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-27 10:12

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-27 10:12

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 编辑 ]

summerfly2008 · 发表于 2006-4-27 10:13

10、xyp-get-MinMaxPoint 函数
功能：指定对象最小外接矩形的九点坐标

代码:
;;;------------- xyp-get-MinMaxPoint -------------
;;;指定对象最小外接矩形的九点坐标
;;;(xyp-get-MinMaxPoint 实体名参数)
;;;参数＝1～9，上中下9位码；其他均为左下角点
;;; 7       8       9 maxpoint '(x2 y2)
;;;  ------------------
;;;  |             |
;;;  |             |
;;;  |             |
;;; 4|    5       |6
;;;  |             |
;;;  |             |
;;;  |             |
;;;  ------------------
;;; 1       2       3
;;;minpoint '(x1 y1 )
(defun xyp-get-MinMaxPoint (ename mode / pointmax pointmin x1 x2 y1 y2 dx dy point)
  (vla-getboundingbox
(vlax-ename->vla-object ename)
'minpoint
'maxpoint
  )
  (setq pointmax (vlax-safearray->list maxpoint)
pointmin (vlax-safearray->list minpoint)
x1    (car pointmin)
x2    (car pointmax)
y1    (cadr pointmin)
y2    (cadr pointmax)
dx    (/ (- x2 x1) 2.0)
dy    (/ (- y2 y1) 2.0)
  )
  (cond ((= mode 1) (setq point pointmin))
((= mode 2) (setq point (list (+ x1 dx) y1)))
((= mode 3) (setq point (list x2 y1)))
((= mode 4) (setq point (list x1 (+ y1 dy))))
((= mode 5) (setq point (list (+ x1 dx) (+ y1 dy))))
((= mode 6) (setq point (list x2 (+ y1 dy))))
((= mode 7) (setq point (list x1 y2)))
((= mode 8) (setq point (list (+ x1 dx) y2)))
((= mode 9) (setq point pointmax))
(t (setq point pointmin))
  )
  point
)

或

代码:
(defun xyp-get-MinMaxPoint (ename  mode    /    pointmax    pointmin
      dx    dy    pt1    pt2 pt3 pt4 pt5
      pt6    pt7    pt8    pt9 point
   )
  (vla-getboundingbox
(vlax-ename->vla-object ename)
'minpoint
'maxpoint
  )
  (setq pointmax (vlax-safearray->list maxpoint)
pointmin (vlax-safearray->list minpoint)
dx    (/ (- (car pointmax) (car pointmin)) 2.0)
dy    (/ (- (cadr pointmax) (cadr pointmin)) 2.0)
pt1    pointmin
pt2    (polar pt1 0 dx)
pt3    (polar pt2 0 dx)
pt4    (polar pt1 (* pi 0.5) dy)
pt5    (polar pt4 0 dx)
pt6    (polar pt5 0 dx)
pt7    (polar pt4 (* pi 0.5) dy)
pt8    (polar pt7 0 dx)
pt9    pointmax
  )
  (cond ((= mode 1) (setq point pt1))
((= mode 2) (setq point pt2))
((= mode 3) (setq point pt3))
((= mode 4) (setq point pt4))
((= mode 5) (setq point pt5))
((= mode 6) (setq point pt6))
((= mode 7) (setq point pt7))
((= mode 8) (setq point pt8))
((= mode 9) (setq point pt9))
(t (setq point pt1))
  )
  point
)

[ 本帖最后由 summerfly2008 于 2006-4-27 10:20 编辑 ]

summerfly2008 · 发表于 2006-4-27 10:13

11、xyp-get-RightPoint 函数
功能：两点中点之正方向点

代码:
;;;两点中点之正方向点
;;;(xyp-get-RightPoint 起点终点离开两点连线的距离)
;;;---------- xyp-get-RightPoint ---------
(defun xyp-get-RightPoint (point1 point2 dist / pttxt ang)
  (if (null sc)
(setbl)
  )
  (setq ang (rad2ang (angle point1 point2)))
  (if (or (< ang 90) (> ang 270))
(setq ang (+ ang 90))
(setq ang (- ang 90))
  )
  (setq pttxt (polar (xyp-get-MidPoint point1 point2)
      (ang2rad ang)
      (* sc dist)
      )
  )
  pttxt
)

[ 本帖最后由 summerfly2008 于 2006-4-27 10:21 编辑 ]

cad · 发表于 2006-4-27 21:31

好啊

浮出心海 · 发表于 2006-5-7 13:10

看不懂,水平不行,谢谢了

		自动登录	找回密码
密码			立即注册

[开发] 通用函数揭密与改进