[LISP函数]：移动CASS中高程块的属性（高程注记）

caddog · 发表于 2007-8-26 15:09:03

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

[FONT=courier new]
;;;--------------------------------------------------------
;;;函数：mm
;;;--------------------------------------------------------
;;;来源：　作者：CADDOG
;;;编制时间：2007.8.24
;;;功能 :模拟CAD的MOVE命令实现对cass中高程块属性（高程值）
;;; 的动态移动。因为CASS中高程注记不能用M来移动，只能
;;; 选择后拖动夹点。有时觉得不是很便利。刚好看到网友
;;; 编制的动态拖动程序，正好试试。虽说实际意义不大，
;;; 权作练习啦。还有就是不支持多个属性同时移动，有空时
;;; 准备再想想办法。
;;;备注 :编写中借用了XDCAD上《鼠标移动动态显示》函数。
;;; 作者的名字没能记下来，深表歉意。
;;;--------------------------------------------------------
(DEFUN c:mm (/ ss1 att-en1 obj-att1 pt eveal obj-type loop_ID pt1 vptent
)
(SETQ olderr *error*
*error* err
) ;_ 结束setq
(COMMAND "_.undo" "_begin")
(SETQ att-en1 (CAR (NENTSEL "选择块属性:")))
(while (not att-en1)
(SETQ att-en1 (CAR (NENTSEL "选择块属性:")))
)
(SETQ ;;att-en1 (CAR (NENTSEL "选择块属性:"))
obj-att1 (VLAX-ENAME->VLA-OBJECT att-en1)
pt (VLAX-SAFEARRAY->LIST
(VLAX-VARIANT-VALUE
(VLA-GET-TEXTALIGNMENTPOINT obj-att1)
) ;_ 结束vlax-variant-value
) ;_ 结束vlax-safearray->list
eveal (CADDR pt) ;_高程
) ;_ 结束setq
;;不知为何，选择了无点位高程值时，用VLA-GET-TEXTALIGNMENTPOINT得到的坐标前两位为0.0 0.0
;;此时换VLA-GET-INSERTIONPOINT来处理
(IF (EQUAL (LIST (CAR pt) (CADR pt)) '(0.0 0.0))
;;说明是却掉了点位的块属性
(SETQ pt (VLAX-SAFEARRAY->LIST
(VLAX-VARIANT-VALUE
(VLA-GET-INSERTIONPOINT obj-att1)
) ;_ 结束vlax-variant-value
) ;_ 结束vlax-safearray->list
obj-type T ;_标记一下，后面更新块属性的位置时需根据块的不同用不同的方法
) ;_ 结束setq
) ;_endif
;;构造一条直线，用以模拟CAD在MOVE时的那条指示线
(SETQ obj-lin (VLA-ADDLINE
(model-space)
(VLAX-3D-POINT pt)
(VLAX-3D-POINT pt)
) ;_ 结束vla-AddLine
) ;_ 结束setq
(vla-put-Layer obj-lin "0");_为了补救不知什么原因出现的指示线未删除的情况，将之放到0层(因我们作图时0层只放临时实体)
(PRINC "\n指定新的位置...")
(SETQ LOOP_ID T)
(WHILE LOOP_ID
(SETQ vptent (GRREAD T (+ 4 8) 0))
(COND
((AND vptent (= (CAR vptent) 5))
(PROGN
(SETQ
pt1 (APPEND (3dPoint->2dPoint (CADR vptent)) (LIST eveal))
) ;_ 结束setq
;;更新指示线的终点坐标
(VLA-PUT-ENDPOINT obj-lin (VLAX-3D-POINT pt1))
;;更新属性（高程注记）的位置
(IF obj-type ;_根据obj-type的值来确定使用的方法
(VLA-PUT-INSERTIONPOINT obj-att1 (VLAX-3D-POINT pt1))
(VLA-PUT-TEXTALIGNMENTPOINT obj-att1 (VLAX-3D-POINT pt1))
) ;_endif
) ;_ 结束progn
)
((= 3 (CAR vptent)) (SETQ LOOP_ID NIL))
(T
(PROGN
(SETQ LOOP_ID NIL)
;;
) ;_ 结束progn
)
) ;_ 结束cond
) ;_ 结束while
(VLA-DELETE obj-lin);_删除指示线
(COMMAND "_.undo" "_end")
(SETQ *error* olderr)
(princ)
) ;_ 结束defun
;;错误处理，用以在用户按下了ESC键后取消所有的修改并删除指示线。
(DEFUN err (s)
;;当用户点击了块、线等其它实体，会出现“ActiveX 服务器返回错误: 未知名称: TextAlignmentPoint”
;;的错误，搞了个笨办法，对这种情况和用户按ESC的情况进行了区分。
;;(princ s)
;;本来不想用“U”，不用的话要将PT定义为全局变量。害怕有冲突，还是就这样了。
(if (vl-string-search "ActiveX" s)
(princ "\t 该实体不支持此操作!命令被取消!")
(progn
(COMMAND "u")
(if obj-lin ;_若生成了指示线且未删除则删除掉
(if (not(vlax-erased-p obj-lin))
(vla-delete obj-lin)
)
)
(princ "\t *取消操作*")
);_end progn
);_endif
(SETQ *error* olderr)
) ;_ 结束defun
[/FONT]

[FONT=courier new] 
;;;-------------------------------------------------------- 
;;;函数：mm                                
;;;-------------------------------------------------------- 
;;;来源：           　作者：CADDOG 
;;;编制时间：2007.8.24 
;;;功能    :模拟CAD的MOVE命令实现对cass中高程块属性（高程值） 
;;;         的动态移动。因为CASS中高程注记不能用M来移动，只能 
;;;         选择后拖动夹点。有时觉得不是很便利。刚好看到网友 
;;;         编制的动态拖动程序，正好试试。虽说实际意义不大， 
;;;         权作练习啦。还有就是不支持多个属性同时移动，有空时 
;;;         准备再想想办法。 
;;;备注  :编写中借用了XDCAD上《鼠标移动动态显示》函数。 
;;;      作者的名字没能记下来，深表歉意。 
;;;-------------------------------------------------------- 
(DEFUN c:mm (/ ss1 att-en1 obj-att1 pt eveal obj-type loop_ID pt1 vptent 
             ) 
  (SETQ        olderr        *error* 
        *error*        err 
        ) ;_ 结束setq 
  (COMMAND "_.undo" "_begin") 
  (SETQ        att-en1         (CAR (NENTSEL "选择块属性:"))) 
  (while (not att-en1) 
    (SETQ        att-en1         (CAR (NENTSEL "选择块属性:"))) 
    ) 
  (SETQ        ;;att-en1         (CAR (NENTSEL "选择块属性:")) 
        obj-att1 (VLAX-ENAME->VLA-OBJECT att-en1) 
        pt         (VLAX-SAFEARRAY->LIST 
                   (VLAX-VARIANT-VALUE 
                     (VLA-GET-TEXTALIGNMENTPOINT obj-att1) 
                     ) ;_ 结束vlax-variant-value 
                   ) ;_ 结束vlax-safearray->list 
        eveal         (CADDR pt) ;_高程 
        ) ;_ 结束setq 
  ;;不知为何，选择了无点位高程值时，用VLA-GET-TEXTALIGNMENTPOINT得到的坐标前两位为0.0 0.0 
  ;;此时换VLA-GET-INSERTIONPOINT来处理 
  (IF (EQUAL (LIST (CAR pt) (CADR pt)) '(0.0 0.0)) 
    ;;说明是却掉了点位的块属性 
      (SETQ pt             (VLAX-SAFEARRAY->LIST 
                       (VLAX-VARIANT-VALUE 
                         (VLA-GET-INSERTIONPOINT obj-att1) 
                         ) ;_ 结束vlax-variant-value 
                       ) ;_ 结束vlax-safearray->list 
            obj-type T ;_标记一下，后面更新块属性的位置时需根据块的不同用不同的方法 
            ) ;_ 结束setq 
    ) ;_endif 
  ;;构造一条直线，用以模拟CAD在MOVE时的那条指示线 
  (SETQ        obj-lin        (VLA-ADDLINE 
                  (model-space) 
                  (VLAX-3D-POINT pt) 
                  (VLAX-3D-POINT pt) 
                  ) ;_ 结束vla-AddLine 
        ) ;_ 结束setq 
  (vla-put-Layer obj-lin "0");_为了补救不知什么原因出现的指示线未删除的情况，将之放到0层(因我们作图时0层只放临时实体) 
  (PRINC "\n指定新的位置...") 
  (SETQ LOOP_ID T) 
  (WHILE LOOP_ID 
    (SETQ vptent (GRREAD T (+ 4 8)  0)) 
    (COND 
      ((AND vptent (= (CAR vptent) 5)) 
       (PROGN 
         (SETQ 
           pt1 (APPEND (3dPoint->2dPoint (CADR vptent)) (LIST eveal)) 
           ) ;_ 结束setq 
         ;;更新指示线的终点坐标 
         (VLA-PUT-ENDPOINT obj-lin (VLAX-3D-POINT pt1)) 
         ;;更新属性（高程注记）的位置 
         (IF obj-type ;_根据obj-type的值来确定使用的方法 
           (VLA-PUT-INSERTIONPOINT obj-att1 (VLAX-3D-POINT pt1)) 
           (VLA-PUT-TEXTALIGNMENTPOINT obj-att1 (VLAX-3D-POINT pt1)) 
           ) ;_endif 
         ) ;_ 结束progn 
       ) 
      ((= 3 (CAR vptent)) (SETQ LOOP_ID NIL)) 
      (T 
       (PROGN 
         (SETQ LOOP_ID NIL) 
         ;; 
         ) ;_ 结束progn 
 
       ) 
      ) ;_ 结束cond 
    ) ;_ 结束while 
  (VLA-DELETE obj-lin);_删除指示线 
  (COMMAND "_.undo" "_end") 
  (SETQ *error* olderr) 
  (princ) 
  ) ;_ 结束defun 
 
;;错误处理，用以在用户按下了ESC键后取消所有的修改并删除指示线。 
(DEFUN err (s) 
  ;;当用户点击了块、线等其它实体，会出现“ActiveX 服务器返回错误: 未知名称: TextAlignmentPoint” 
  ;;的错误，搞了个笨办法，对这种情况和用户按ESC的情况进行了区分。 
  ;;(princ s) 
  ;;本来不想用“U”，不用的话要将PT定义为全局变量。害怕有冲突，还是就这样了。 
  (if (vl-string-search "ActiveX" s) 
    (princ "\t 该实体不支持此操作!命令被取消!") 
    (progn 
      (COMMAND "u") 
      (if obj-lin ;_若生成了指示线且未删除则删除掉 
        (if (not(vlax-erased-p obj-lin)) 
          (vla-delete obj-lin) 
          ) 
        ) 
      (princ "\t *取消操作*") 
      );_end progn 
    );_endif 
  (SETQ *error* olderr) 
  ) ;_ 结束defun 
 
 
 
 
  [/FONT]

sony123 · 发表于 2007-8-28 21:33:35

顶楼上的一下：下面的这个功能没有那么强大：
;;;=========================================
;;1。快速移动属性文本(比如地形图中属性块压线等)
;;程序——————4-!nVade[3#],源于dream.fei的vba
(defun c:x1(/ en obj pt px typ)
(vl-load-com)
(while (setq en (car (nentsel "\n选择属性文字<退出>:")))
(cond((= (cdr (assoc 0 (entget en))) "ATTRIB")
(setq obj (vlax-ename->vla-object en))
(setq pt(vlax-get obj "insertionpoint"))
(if (setq px (getpoint pt "新的位置："))
(vlax-invoke obj 'move pt px)
)
)
(t
(princ "** 并非属性对象，请重新选择**")
)
)
)
)

jxdiy · 发表于 2007-8-29 08:18:04

只能多支持啊

攒钱下载

sony123 · 发表于 2007-8-31 09:21:27

1楼的程序对属性块不起作用只有cass中的才起作用
实际意义不大！！！！！

zml84 · 发表于 2007-8-31 10:08:03

2楼代码的改进：

(vl-load-com)
(defun C:X1 (/ EN OBJ PT PT_OLD PX TEST TMP)
(while (setq EN (car (nentsel "\n选择属性文字<退出>:")))
(if (= (cdr (assoc 0 (entget EN))) "ATTRIB")
(progn
(setq OBJ (vlax-ename->vla-object EN))
(setq PT (vlax-get OBJ "insertionpoint")
PT_OLD PT
)
(princ "\n指定新的位置: ")
(setq TEST t)
(while TEST
(setq TMP (grread t 7 1))
(redraw)
(cond ((= (car TMP) 3) ;_左键
(setq TEST NIL)
)
((= (car TMP) 11) ;_右键
(vlax-invoke OBJ 'MOVE PT PT_OLD)
(setq TEST NIL)
)
((= (car TMP) 5) ;_移动
(setq PX (cadr TMP))
(vlax-invoke OBJ 'MOVE PT PX)
(grdraw PT_OLD PX 1 0)
(setq PT PX)
)
)
) ;_结束 while
)
(princ "** 并非属性对象，请重新选择**")
)
) ;_结束 while
(princ)
) ;_结束 defun

(vl-load-com) 
(defun C:X1 (/ EN OBJ PT PT_OLD PX TEST TMP) 
    (while (setq EN (car (nentsel "\n选择属性文字<退出>:"))) 
        (if (= (cdr (assoc 0 (entget EN))) "ATTRIB") 
            (progn 
                (setq OBJ (vlax-ename->vla-object EN)) 
                (setq PT     (vlax-get OBJ "insertionpoint") 
                      PT_OLD PT 
                ) 
                (princ "\n指定新的位置: ") 
                (setq TEST t) 
                (while TEST 
                    (setq TMP (grread t 7 1)) 
                    (redraw) 
                    (cond ((= (car TMP) 3) ;_左键 
                           (setq TEST NIL) 
                          ) 
                          ((= (car TMP) 11) ;_右键 
                           (vlax-invoke OBJ 'MOVE PT PT_OLD) 
                           (setq TEST NIL) 
                          ) 
                          ((= (car TMP) 5) ;_移动 
                           (setq PX (cadr TMP)) 
                           (vlax-invoke OBJ 'MOVE PT PX) 
                           (grdraw PT_OLD PX 1 0) 
                           (setq PT PX) 
                          ) 
                    ) 
                ) ;_结束 while 
            ) 
            (princ "** 并非属性对象，请重新选择**") 
        ) 
    ) ;_结束 while 
    (princ) 
) ;_结束 defun

asdttkjn · 发表于 2007-8-31 18:09:26

多多赐教

sony123 · 发表于 2007-9-1 07:33:52

感谢184 在这里改进拉同时也感谢你在acad.net.cn对我的解答

jx2008 · 发表于 2008-10-24 15:26:40

1楼、4楼的程序好，顶

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

[LISP函数]：移动CASS中高程块的属性（高程注记）

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子