;;; ============================================================
;;; 图块编辑工具 - 增强版（性能优化版）ucuc2003编制
;;; 命令：RB
;;; 新增功能1：改块基点（参考论坛Gu_xl的代码，感谢论坛大佬）
;;; 新增功能2：修改块描述
;;; 新增功能3：匿名块改名（直接使用已选中的块）
;;; 新增功能4：普通块转匿名块
;;; 新增功能5：多重加密块（直接使用已选中的对象）
;;; 优化说明：替换了原有的卡顿中心点计算函数
;;; https://bbs.mjtd.com/thread-195046-1-1.html
;;; ============================================================

;;; ============================================================
;;; 【新增】快速中心点计算函数（替换原有的卡顿函数）
;;; ============================================================

;;; 选择集转VLA对象列表（内部使用）
(defun SS->VLA-List (ss / i lst)
  (if (and ss (> (sslength ss) 0))
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq lst (cons (vlax-ename->vla-object (ssname ss i)) lst)
              i (1+ i))
      )
      (reverse lst)
    )
  )
)

;;; 快速获取选择集中心点（轴对齐包围盒）
;;; 参数：ss - 选择集
;;; 返回：中心点坐标 (x y z) 或 nil
;;; 特点：极快、无副作用、不创建临时对象
(defun GetCenterFast (ss / ll ur xmin xmax ymin ymax zmin zmax obj)
  (if (and ss (> (sslength ss) 0))
    (progn
      ;; 初始化极值
      (setq xmin 1e99 xmax -1e99
            ymin 1e99 ymax -1e99
            zmin 1e99 zmax -1e99)
      
      ;; 遍历选择集，计算合并包围盒
      (foreach obj (SS->VLA-List ss)
        (vla-getboundingbox obj 'll 'ur)
        (setq ll (vlax-safearray->list ll)
              ur (vlax-safearray->list ur))
        (setq xmin (min xmin (car ll) (car ur))
              xmax (max xmax (car ll) (car ur))
              ymin (min ymin (cadr ll) (cadr ur))
              ymax (max ymax (cadr ll) (cadr ur))
              zmin (min zmin (caddr ll) (caddr ur))
              zmax (max zmax (caddr ll) (caddr ur)))
      )
      
      ;; 返回中心点
      (list (/ (+ xmin xmax) 2.0)
            (/ (+ ymin ymax) 2.0)
            (/ (+ zmin zmax) 2.0))
    )
    nil
  )
)

;;; 兼容原接口（替换原有的 GetMinBoundingBoxCenter）
(defun GetMinBoundingBoxCenter (ss)
  (GetCenterFast ss)
)

;;; ============================================================
;;; 以下是原函数（已优化）
;;; ============================================================

;;; 自动生成块名函数
(defun RBB_GDD () 
  (setq cdate_str (menucmd "M=$(edtime,$(getvar,date),YYMODD)"))
  (setq seed (getvar "DATE"))
  (setq rand_num (rem (* seed 1e8) 1e8))
  (setq rand_str (substr (rtos (+ rand_num 1e8) 2 0) 2 8))
  (setq blkname (strcat "GDD" cdate_str "-" rand_str))
)

;;; 删除旧DCL文件
(defun RBB_CleanOldDCL ( / oldfile)
  (setq oldfile (findfile "re-dcl-tmp.dcl"))
  (if oldfile (vl-file-delete oldfile))
  (setq oldfile (findfile "rb_dcl_temp.dcl"))
  (if oldfile (vl-file-delete oldfile))
)

;;; 确定是否建立新图层
(defun XJ_NEW_TC ()
  (setq lay (getvar "clayer"))
  (if (tblsearch "layer" tc_name) ""
    (progn
      (command "-layer" "new" tc_name "color" tc_col tc_name "")
      (setvar "clayer" lay)
    )
  )
  (princ)
)

;;; ============================================================
;;; 改块基点（位置保持不变）辅助函数
;;; ============================================================

;;; 矢量叉积
(defun RBB_VectorCrossProduct (InputVector1 InputVector2)
  (list (- (* (cadr InputVector1) (caddr InputVector2))
           (* (cadr InputVector2) (caddr InputVector1)))
        (- (* (caddr InputVector1) (car InputVector2))
           (* (caddr InputVector2) (car InputVector1)))
        (- (* (car InputVector1) (cadr InputVector2))
           (* (car InputVector2) (cadr InputVector1)))
  )
)

;;; 3D变换 A->B
(defun RBB_3DTransformAB (XA YA ZA OA SA P1 /)
  (setq P1 (mapcar '* P1 SA))
  (mapcar '+
    OA
    (list (+ (* (car XA) (car P1)) (* (car YA) (cadr P1)) (* (car ZA) (caddr P1)))
          (+ (* (cadr XA) (car P1)) (* (cadr YA) (cadr P1)) (* (cadr ZA) (caddr P1)))
          (+ (* (caddr XA) (car P1)) (* (caddr YA) (cadr P1)) (* (caddr ZA) (caddr P1)))
    )
  )
)

;;; 3D变换 B->A
(defun RBB_3DTransformBA (XA YA ZA OA SA P1 /)
  (setq P1 (mapcar '- P1 OA))
  (mapcar '/
    (list (+ (* (car XA) (car P1)) (* (cadr XA) (cadr P1)) (* (caddr XA) (caddr P1)))
          (+ (* (car YA) (car P1)) (* (cadr YA) (cadr P1)) (* (caddr YA) (caddr P1)))
          (+ (* (car ZA) (car P1)) (* (cadr ZA) (cadr P1)) (* (caddr ZA) (caddr P1)))
    )
    SA
  )
)

;;; BlockToInsertSetup - 获取块参照的变换矩阵
(defun RBB_BlockToInsertSetup (InsertEname / ZAxis NCSXAxis InsertAngle)
  (if (= 'ename (type InsertEname))
    (setq InsertEname (vlax-ename->vla-object InsertEname))
  )
  (setq ZAxis (RBB_gxl-Num-AX->LispValue (vla-get-Normal InsertEname))
        InsertAngle (vla-get-Rotation InsertEname)
        NCSXAxis (trans (list (cos InsertAngle) (sin InsertAngle) 0.0) ZAxis 0)
  )
  (list
    NCSXAxis
    (RBB_VectorCrossProduct ZAxis NCSXAxis)
    ZAxis
    (trans (RBB_gxl-Num-AX->LispValue (vla-get-InsertionPoint InsertEname)) ZAxis 0)
    (list (vla-get-XScaleFactor InsertEname)
          (vla-get-YScaleFactor InsertEname)
          (vla-get-ZScaleFactor InsertEname)
    )
  )
)

;;; BlockToInsertXform
(defun RBB_BlockToInsertXform (P1 TransformSpec)
  (RBB_3DTransformAB
    (nth 0 TransformSpec)
    (nth 1 TransformSpec)
    (nth 2 TransformSpec)
    (nth 3 TransformSpec)
    (nth 4 TransformSpec)
    P1
  )
)

;;; InsertToBlockXform
(defun RBB_InsertToBlockXform (P1 TransformSpec)
  (RBB_3DTransformBA
    (nth 0 TransformSpec)
    (nth 1 TransformSpec)
    (nth 2 TransformSpec)
    (nth 3 TransformSpec)
    (nth 4 TransformSpec)
    P1
  )
)

;;; 转换函数
(defun RBB_gxl-Num-AX->LispValue (v)
  (cond
    ((= (type v) 'variant) (RBB_gxl-Num-AX->LispValue (vlax-variant-value v)))
    ((= (type v) 'safearray) (mapcar 'RBB_gxl-Num-AX->LispValue (safearray-value v)))
    ((= (type v) 'list) (mapcar 'RBB_gxl-Num-AX->LispValue v))
    (T v)
  )
)

;;; 改块基点主函数（左键选点改基点，右键自动中心点）
(defun RBB_ChangeInsertPoint (InsertEName / *ACDOCUMENT* blks temp_ss
                              BlockName oldInsPt1 newInsPt1
                              oldInsPt2 newInsPt2 XformSpec blkdef)
  (setq *ACDOCUMENT* (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq blks (vla-get-blocks *ACDOCUMENT*))
  
  ;; 获取块参照信息
  (if (= 'ename (type InsertEName))
    (setq InsertEName (vlax-ename->vla-object InsertEName))
  )
  (setq oldInsPt1 (RBB_gxl-Num-AX->LispValue (vla-get-InsertionPoint InsertEName))
        BlockName (vla-get-name InsertEName)
        XformSpec (RBB_BlockToInsertSetup InsertEName)
  )

  ;; 提示用户选择新基点（右键自动选择中心点）
  (initget 128)  ; 128 允许按 Enter/右键 返回 nil
  (setq newInsPt1 (getpoint (RBB_gxl-Num-AX->LispValue oldInsPt1) 
                            "\n[改块基点] 请拾取块的新基点 <或右键自动计算中心点>: "))
  
  ;; 如果用户按了右键或Enter，自动计算块的中心点
  (if (null newInsPt1)
    (progn
      (princ "\n正在计算块中心点...")
      ;; 将当前块参照转为选择集并计算中心点
      (setq temp_ss (ssadd (vlax-vla-object->ename InsertEName) (ssadd)))
      (setq newInsPt1 (GetCenterFast temp_ss))
      (if newInsPt1
        (princ "\n已自动计算中心点")
        (progn
          (princ "\n无法计算中心点，使用原点")
          (setq newInsPt1 '(0.0 0.0 0.0))
        )
      )
    )
  )
  
  ;; 左键选择了点，转换坐标
  (setq newInsPt1 (trans newInsPt1 1 0))
  (princ (strcat "\n已选择新基点: " 
                 (rtos (car newInsPt1)) "," 
                 (rtos (cadr newInsPt1)) "," 
                 (rtos (caddr newInsPt1))))
  
  ;; 计算变换
  (setq oldInsPt2 (RBB_InsertToBlockXform oldInsPt1 XformSpec)
        newInsPt2 (RBB_InsertToBlockXform newInsPt1 XformSpec)
  )
  
  ;; 移动块定义中的所有实体
  (setq blkdef (vla-item blks BlockName))
  (vlax-for obj blkdef
    (vla-move obj
      (vlax-3d-point newInsPt2)
      (vlax-3d-point oldInsPt2)
    )
  )
  
  ;; 移动所有同名块参照（保持块位置不变）
  (vlax-for blk blks
    (vlax-for obj blk
      (cond
        ((and (= "AcDbBlockReference" (vla-get-ObjectName obj))
              (= (strcase BlockName) (strcase (vla-get-name obj)))
         )
         (setq XformSpec (RBB_BlockToInsertSetup obj))
         (setq oldInsPt1 (RBB_BlockToInsertXform oldInsPt2 XformSpec)
               newInsPt1 (RBB_BlockToInsertXform newInsPt2 XformSpec)
         )
         (vla-move obj
           (vlax-3d-point oldInsPt1)
           (vlax-3d-point newInsPt1)
         )
         ;; 处理属性
         (if (setq atts (RBB_gxl-Num-AX->LispValue (vla-GetAttributes obj)))
           (foreach att atts
             (vla-move att
               (vlax-3d-point newInsPt1)
               (vlax-3d-point oldInsPt1)
             )
           )
         )
        )
        ((and (= "AcDbMInsertBlock" (vla-get-ObjectName obj))
              (= (strcase BlockName) (strcase (vla-get-name obj)))
         )
         (setq XformSpec (RBB_BlockToInsertSetup obj))
         (setq oldInsPt1 (RBB_BlockToInsertXform oldInsPt2 XformSpec)
               newInsPt1 (RBB_BlockToInsertXform newInsPt2 XformSpec)
         )
         (vla-move obj
           (vlax-3d-point oldInsPt1)
           (vlax-3d-point newInsPt1)
         )
         ;; 处理属性
         (if (setq atts (RBB_gxl-Num-AX->LispValue (vla-GetAttributes obj)))
           (foreach att atts
             (vla-move att
               (vlax-3d-point newInsPt1)
               (vlax-3d-point oldInsPt1)
             )
           )
         )
        )
      )
    )
  )
  
  (vla-regen *ACDOCUMENT* acActiveViewport)
  (princ (strcat "\n图块 <" BlockName "> 的基点已修改完成。"))
)

;;; ============================================================
;;; 修改块描述
;;; ============================================================
(defun RBB_BlockDesc (bl_name bl_desc / bl_item bl_list)
  (if (and bl_desc (/= bl_desc ""))
    (cond
      ((setq bl_item (tblobjname "BLOCK" bl_name))
       (cond
         ((assoc 4 (setq bl_list (entget bl_item)))
          (entmake (subst (cons 4 bl_desc) (assoc 4 bl_list) bl_list))
         )
         (T (entmake (append bl_list (list (cons 4 bl_desc)))))
       )
       (setq bl_item (cdr (assoc -2 bl_list)))
       (while bl_item
         (entmake (entget bl_item))
         (setq bl_item (entnext bl_item))
       )
       (entmake (list (cons 0 "ENDBLK")))
       (princ (strcat "\n块描述已修改为: " bl_desc))
      )
      (T (princ "\n未找到块定义，描述修改失败"))
    )
    (princ "\n描述为空，未修改")
  )
)

;;; ============================================================
;;; 功能1：修改匿名块块名（直接使用已选中的块）
;;; ============================================================
(defun RBB_RenameAnonBlock (en / blks nam new_name)
  (setq blks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
  (if en
    (progn
      (setq nam (vla-get-name (vlax-ename->vla-object en)))
      (if (wcmatch nam "`**")
        (progn
          (setq new_name blkname)
          ;; 检查块名是否已存在
          (if (tblsearch "BLOCK" new_name)
            (alert (strcat "块名 \"" new_name "\" 已存在！"))
            (if (not (snvalid new_name))
              (alert (strcat "无效的块名: " new_name))
              (progn
                (vla-put-name (vla-item blks nam) new_name)
                (princ (strcat "\n匿名块已改名为: " new_name))
                (vla-auditinfo (vla-get-activedocument (vlax-get-acad-object)) :vlax-true)
              )
            )
          )
        )
        (princ "\n当前选择的不是匿名块")
      )
    )
    (princ "\n未选择块")
  )
  (princ)
)

;;; ============================================================
;;; 功能2：普通块转匿名块（直接使用已选中的块）
;;; ============================================================
(defun RBB_BlockToAnon (en / blks old_name)
  (setq blks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
  (if en
    (progn
      (setq old_name (vla-get-name (vlax-ename->vla-object en)))
      (if (not (wcmatch old_name "`*U*"))
        (progn
          (vla-put-name (vla-item blks old_name) "*U")
          (princ (strcat "\n普通块已转换为匿名块: " old_name " -> *U"))
          (vla-auditinfo (vla-get-activedocument (vlax-get-acad-object)) :vlax-true)
        )
        (princ "\n当前选择的已经是匿名块")
      )
    )
    (princ "\n未选择块")
  )
  (princ)
)

;;; ============================================================
;;; 功能3：多重加密块（直接使用已选中的块或对象）
;;; ============================================================
(defun Nblock (ss insertpt / InsPt number blocklist blk index SelectionSetObjs)
  (setq InsPt (vlax-3d-point insertpt))
  (setq number (sslength ss))
  (setq blocklist (vla-get-blocks AcadDocument))
  (setq blk (vla-add blocklist InsPt "*U"))
  (setq SelectionSetObjs (vlax-make-safearray vlax-vbobject (cons 0 (- number 1))))
  (defun item (ss index)
    (vlax-ename->vla-object (ssname ss index))
  )
  (setq index 0)
  (repeat number
    (vlax-safearray-put-element SelectionSetObjs index (item ss index))
    (setq index (1+ index))
  )
  (vla-copyobjects AcadDocument SelectionSetObjs blk)
  (vla-insertblock ModelSpace InsPt (vlax-get-property blk 'name) 1 1 1 0)
)

(defun RBB_MakeMultiInsert (en / ss insertpt s1 e r_zm70 c_zm71 blk_name old_cmdecho ent_list i ent)
  (setq old_cmdecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (setq tc_name "Lock insert layer" tc_col "7")
  (XJ_NEW_TC)
  (if en
    (progn
      (setq ss (ssadd))
      (ssadd en ss)
    )
    (progn
      (princ "\n请选择要制作成多重加密块的对象: ")
      (setq ss (ssget '("_:L")))
    )
  )
  (setq AcadObject   (vlax-get-acad-object)
		AcadDocument (vla-get-activeDocument AcadObject)
		ModelSpace   (vla-get-Modelspace AcadDocument)
  )
  (if ss
    (progn
      (setq insertpt (getpoint "\n[多重加密块] 请指定块基点 <或右键自动计算中心点>: "))
      (if (not insertpt)
         (progn
           (princ "\n正在计算中心点...")
           (setq insertpt (GetCenterFast ss))
           (if insertpt
             (princ "\n已自动计算中心点")
             (setq insertpt '(0.0 0.0 0.0))
           )
         )
      )
	  (Nblock ss insertpt)
	  (vl-cmdf ".erase" ss "")
      (setq s1 (entlast))
	  (setq e (entget s1))
	  (setq stlx (cdr (assoc 0 e)))
      (if (= stlx "INSERT")
		 (progn
			(setq r_zm70 (assoc 70 e))
			(setq c_zm71 (assoc 71 e))
			(setq e (subst (cons 70 1) r_zm70 e))
			(setq e (subst (cons 71 1) c_zm71 e))
			(setq e (subst (list 100  "AcDbMInsertBlock") (list 100  "AcDbBlockReference") e))
			(entmake e)
			(entdel s1)
		 )
	   )
	  (command "change" (entlast) "" "P" "la" tc_name "c" "bylayer" "")
	  (princ (strcat "\n多重加密块完成！加密到可打印层<" tc_name ">层"))
    )
    (princ "\n退出！")
  )
  
  (setvar "cmdecho" old_cmdecho)
  (princ)
)

;;; ============================================================
;;; 主程序（增强版V4.0）- 按用户设计的面板布局
;;; ============================================================
(defun C:RB (/ en xobj name name1 dclname tempname filen stream dcl_re dlg block_desc)
  (vl-load-com)
  (RBB_GDD)
  (defun *Error* (msg)
    (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))
       (princ))
  )
  (princ "图块编辑工具 - 增强版V4.0")
  
  ;; 删除旧的DCL缓存文件
  (RBB_CleanOldDCL)
 
  (setq en (car (entsel "\n选择要编辑的图块<退出>: ")))
  (if (null en)
    (progn (princ "\n未选择块，程序退出！") (exit))
  )
  
  (if (not (or (eq "TCH_BLOCK_INSERT" (cdr (assoc 0 (entget en))))
               (eq "INSERT" (cdr (assoc 0 (entget en))))))
    (progn (alert "没有选择块!") (exit))
  )
  
  (setq xobj (vlax-ename->vla-object en))
  (setq name (vlax-get-property xobj 'EffectiveName))
  
  (setq tempname (vl-filename-mktemp "RB_DCL_" nil ".dcl"))
  (setq filen (open tempname "w"))
  
;; 【DCL对话框V4.0】
  (foreach stream
    (list
      "// 图块编辑工具 - 增强版V4.0\n"
      "RENAME : dialog {\n"
      "    label = \"图块编辑工具 V4.0 BY ucuc2003\";\n"
      "    :boxed_column { label = \"图块改名\";\n"
      "    :row {\n"
      "        :text { label = \"原块名：\"; width = 5; }\n"
      "        :text { key = \"dcl_old_name\"; width = 45; }\n"
      "    }\n"
      "    :row {\n"
      "        :text { label = \"改块名：\"; width = 5; }\n"
      "        :edit_box { key = \"dcl_edit_name\"; edit_width = 45; }\n"
      "    }\n"
      "    spacer_1;\n"
      "    :row {\n"
      "        :button { key = \"all_name\"; label = \"所有块改名\"; width = 8; }\n"
      "        :button { key = \"sign_name\"; label = \"单个块改名\"; width = 8; }\n"
      "    }\n"
      "    :row {\n"
      "        :button { key = \"auto_all_name\"; label = \"所有块自动改名\"; width = 8; }\n"
      "        :button { key = \"auto_sign_name\"; label = \"单个块自动改名\"; width = 8; }\n"
      "    }\n"
      "    :row {\n"
      "        :button { key = \"select_all_name\"; label = \"所有块选字改名\"; width = 8; }\n"
      "        :button { key = \"select_sign_name\"; label = \"单个块选字改名\"; width = 8; }\n"
      "    }\n"
      "    }\n"
      "    :boxed_column { label = \"其他功能\";\n"
      "    :row {\n"
      "        :button { key = \"rename_anon_block\"; label = \"匿名块改名\"; width = 8; }\n"
      "        :button { key = \"block_to_anon\"; label = \"普通转匿名\"; width = 8; }\n"
      "    }\n"
      "    :row {\n"
      "        :button { key = \"make_multi_insert\"; label = \"多重加密\"; width = 8; }\n"
      "        :button { key = \"change_insert_pt\"; label = \"改块基点\"; width = 8; }\n"
      "    }\n"
      "    :row {\n"
      "        :button { key = \"ByLayer_Ren_name\"; label = \"图层改名\"; width = 8; }\n"
      "    }\n"
      "    }\n"
      "    :boxed_column { label = \"修改块描述\";\n"
      "        :edit_box { key = \"block_desc\"; edit_width = 55; height = 4; }\n"
      "    }\n"
      "    spacer_1;\n"
      "    :row {\n"
      "        :button { key = \"accept\"; label = \"确定\"; is_default = true; width = 4; }\n"
      "        :button { key = \"cancel\"; label = \"取消\"; is_cancel = true; width = 4; }\n"
      "    }\n"
      "    spacer_1;\n"
      "}\n"
    )
    (princ stream filen)
  )

  (close filen)
  (setq dclname tempname)
  
  (setq dcl_re (load_dialog dclname))
  (if (or (< dcl_re 0) (not (new_dialog "RENAME" dcl_re)))
    (progn
      (princ "\n对话框加载失败！")
      (if (> dcl_re 0) (unload_dialog dcl_re))
      (vl-file-delete dclname)
      (exit)
    )
  )
  
  (set_tile "dcl_old_name" name)
  (set_tile "dcl_edit_name" name)
  (mode_tile "dcl_edit_name" 2)
  
  (if (assoc 4 (tblsearch "BLOCK" name))
    (set_tile "block_desc" (cdr (assoc 4 (tblsearch "BLOCK" name))))
    (set_tile "block_desc" "")
  )
  
  (action_tile "dcl_edit_name" "(setq name1 $value)")
  (action_tile "block_desc" "(setq block_desc $value)")
  
  (action_tile "all_name"
    "(if (not name1) (setq name1 (get_tile \"dcl_edit_name\")))
     (if (or (null name1) (= name1 \"\"))
       (alert \"块名不能为空！\")
       (if (tblsearch \"block\" name1)
         (alert (strcat \"块名: \" name1 \" 已经存在\"))
         (if (not (snvalid name1))
           (alert (strcat \"错误的块名: \" name1))
           (done_dialog 101)
         )
       )
     )"
  )
  
  (action_tile "sign_name"
    "(if (not name1) (setq name1 (get_tile \"dcl_edit_name\")))
     (if (or (null name1) (= name1 \"\"))
       (alert \"块名不能为空！\")
       (if (tblsearch \"block\" name1)
         (alert (strcat \"块名: \" name1 \" 已经存在\"))
         (if (not (snvalid name1))
           (alert (strcat \"错误的块名: \" name1))
           (done_dialog 102)
         )
       )
     )"
  )
  
  (action_tile "auto_all_name"
    "(if (tblsearch \"block\" blkname)
       (alert (strcat \"块名: \" blkname \" 已经存在\"))
       (if (not (snvalid blkname))
         (alert (strcat \"错误的块名: \" blkname))
         (done_dialog 103)
       )
     )"
  )
  
  (action_tile "auto_sign_name"
    "(if (tblsearch \"block\" blkname)
       (alert (strcat \"块名: \" blkname \" 已经存在\"))
       (if (not (snvalid blkname))
         (alert (strcat \"错误的块名: \" blkname))
         (done_dialog 104)
       )
     )"
  )
  
  (action_tile "select_all_name"
    "(setq temp_name (get_tile \"dcl_edit_name\"))
     (done_dialog 201)"
  )
  
  (action_tile "select_sign_name"
    "(setq temp_name (get_tile \"dcl_edit_name\"))
     (done_dialog 202)"
  )
  
  (action_tile "ByLayer_Ren_name"
    "(done_dialog 105)"
  )
  
  (action_tile "change_insert_pt"
    "(done_dialog 106)"
  )
  
  (action_tile "rename_anon_block"
    "(done_dialog 107)"
  )
  
  (action_tile "block_to_anon"
    "(done_dialog 108)"
  )
  
  (action_tile "make_multi_insert"
    "(done_dialog 109)"
  )
  
  (action_tile "accept" "(setq name1 (get_tile \"dcl_edit_name\")) (setq block_desc (get_tile \"block_desc\")) (done_dialog 301)")
  (action_tile "cancel" "(done_dialog 0)")
  
  (setq dlg (start_dialog))
  (unload_dialog dcl_re)
  (vl-file-delete dclname)
  
  (cond 
    ((= dlg 101)
      (if (and name1 (/= name1 ""))
        (progn
          (command "_.rename" "_block" name name1)
          (princ (strcat "\n图块 \"" name "\" 重命名为 \"" name1 "\""))
          (if block_desc
            (RBB_BlockDesc name1 block_desc)
          )
        )
        (princ "\n块名不能为空！")
      )
    )
    ((= dlg 102)
      (if (and name1 (/= name1 ""))
        (progn
          (LM:RenameBlockReference en name1)
          (princ (strcat "\n图块 \"" name "\" 重命名为 \"" name1 "\""))
          (if block_desc
            (RBB_BlockDesc name1 block_desc)
          )
        )
        (princ "\n块名不能为空！")
      )
    )
    ((= dlg 103)
      (command "_.rename" "_block" name blkname)
      (princ (strcat "\n图块 \"" name "\" 重命名为 \"" blkname "\""))
      (if block_desc
        (RBB_BlockDesc blkname block_desc)
      )
    )
    ((= dlg 104)
      (LM:RenameBlockReference en blkname)
      (princ (strcat "\n图块 \"" name "\" 重命名为 \"" blkname "\""))
      (if block_desc
        (RBB_BlockDesc blkname block_desc)
      )
    )
    ((= dlg 105)
      (if (c:tcgm)
        (princ)
        (alert "图层改名功能(tcgm)未加载，请确保该命令存在！")
      )
    )
    ((= dlg 106)
      (RBB_ChangeInsertPoint en)
    )
    ((= dlg 107)
      (RBB_RenameAnonBlock en)
    )
    ((= dlg 108)
      (RBB_BlockToAnon en)
    )
    ((= dlg 109)
      (RBB_MakeMultiInsert en)
    )
    ((= dlg 201)
      (RBB_SelectAndRenameAll name)
      (c:RB)
    )
    ((= dlg 202)
      (RBB_SelectAndRenameSingle en name)
      (c:RB)
    )
    ((= dlg 301)
      (if (and name1 (/= name1 ""))
        (progn
          (command "_.rename" "_block" name name1)
          (princ (strcat "\n图块 \"" name "\" 重命名为 \"" name1 "\""))
          (if block_desc
            (RBB_BlockDesc name1 block_desc)
          )
        )
        (progn
          (if block_desc
            (RBB_BlockDesc name block_desc)
          )
          (princ "\n块名未修改")
        )
      )
    )
  )
  
  (prin1)
)

;;; 选字改块名（所有同名块）
(defun RBB_SelectAndRenameAll (old_name)
  (setq text_ent (nentsel "\n全部块选字改名，请选择图中文字: "))
  (if (null text_ent)
    (progn (princ "\n未选择文字，操作取消") nil)
    (progn
      (setq en_data (entget (car text_ent))
            entype (cdr (assoc 0 en_data))
            text_name (if (= entype "ATTDEF")
                        (cdr (assoc 2 en_data))
                        (cdr (assoc 1 en_data))
                      )
      )
      (if (and text_name (/= text_name ""))
        (progn
          (if (tblsearch "block" text_name)
            (alert (strcat "块名: " text_name " 已经存在"))
            (progn
              (command "_.rename" "_block" old_name text_name)
              (princ (strcat "\n图块 \"" old_name "\" 重命名为 \"" text_name "\""))
              (princ "\n改名完成！")
            )
          )
        )
        (princ "\n未选择有效文字")
      )
    )
  )
)

;;; 选字改块名（单个块）
(defun RBB_SelectAndRenameSingle (ent old_name)
  (setq text_ent (nentsel "\n单个块选字改名，请选择图中文字: "))
  (if (null text_ent)
    (progn (princ "\n未选择文字，操作取消") nil)
    (progn
      (setq en_data (entget (car text_ent))
            entype (cdr (assoc 0 en_data))
            text_name (if (= entype "ATTDEF")
                        (cdr (assoc 2 en_data))
                        (cdr (assoc 1 en_data))
                      )
      )
      (if (and text_name (/= text_name ""))
        (progn
          (if (tblsearch "block" text_name)
            (alert (strcat "块名: " text_name " 已经存在"))
            (progn
              (LM:RenameBlockReference ent text_name)
              (princ (strcat "\n图块 \"" old_name "\" 重命名为 \"" text_name "\""))
              (princ "\n改名完成！")
            )
          )
        )
        (princ "\n未选择有效文字")
      )
    )
  )
)

;; 单独改块名
(defun LM:RenameBlockReference ( src new / *error* abc app dbc dbx doc dxf old prp tmp vrs )
  (defun *error* ( msg )
    (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
      (vlax-release-object dbx)
    )
    (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (while
    (progn
      (setvar 'errno 0)
      (cond
        ( (= 7 (getvar 'errno))
          (princ "\nMissed, try again.")
        )
        ( (= 'ename (type src))
          (setq dxf (entget src))
          (cond
            ( (/= "INSERT" (cdr (assoc 0 dxf)))
              (princ "\nPlease select a block reference.")
            )
            ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 dxf)))))))
              (princ "\nSelected block is on a locked layer.")
            )
          )
        )
      )
    )
  )
  (if (= 'ename (type src))
    (progn
      (setq app (vlax-get-acad-object)
            doc (vla-get-activedocument app)
            src (vlax-ename->vla-object src)
            old (vlax-get-property src (if (vlax-property-available-p src 'effectivename) 'effectivename 'name))
            tmp 0
      )
      (setq dbx
        (vl-catch-all-apply 'vla-getinterfaceobject
          (list app
            (if (< (setq vrs (atoi (getvar 'acadver))) 16)
              "objectdbx.axdbdocument"
              (strcat "objectdbx.axdbdocument." (itoa vrs))
            )
          )
        )
      )
      (if (or (null dbx) (vl-catch-all-error-p dbx))
        (princ "\nUnable to interface with ObjectDBX.")
        (progn
          (setq abc (vla-get-blocks doc)
                dbc (vla-get-blocks dbx)
          )
          (vlax-invoke doc 'copyobjects (list (vla-item abc old)) dbc)
          (if (wcmatch old "`**")
            (vla-put-name (vla-item dbc (1- (vla-get-count dbc))) new)
            (vla-put-name (vla-item dbc old) new)
          )
          (vlax-invoke dbx 'copyobjects (list (vla-item dbc new)) abc)
          (vlax-release-object dbx)
          (if
            (and
              (vlax-property-available-p src 'isdynamicblock)
              (= :vlax-true (vla-get-isdynamicblock src))
            )
            (progn
              (setq prp (mapcar 'vla-get-value (vlax-invoke src 'getdynamicblockproperties)))
              (vla-put-name src new)
              (mapcar
                '(lambda ( a b )
                  (if (/= "ORIGIN" (strcase (vla-get-propertyname a)))
                    (vla-put-value a b)
                  )
                )
                (vlax-invoke src 'getdynamicblockproperties) prp
              )
            )
            (vla-put-name src new)
          )
        )
      )
    )
  )
  (princ)
)

;; 图层改名
(defun C:TCGM (/ *error*  name name1 dclname tempname filen stream dcl_re dlg new)
 	(defun *error* ( msg )
		(if (wcmatch (strcase msg t) "*break,*cancel*,*exit*")
			(progn
				(unload_dialog dcl_re)
				(vl-file-delete dclname)
				(princ "\nError：图层0不可更改!" )
			)
		)
	)
	
	(setvar "cmdecho" 0)
  (setq key 
		(progn
			(initget "D  " )
			(entsel "\n选择需改图层名的对象[改当前图层名(D)]:")
		)
	)
	
	(cond
		((= key "D")
			(setq name (getvar "CLAYER"))
		)
		
		((= (type key) 'LIST)
			(setq name (cdr (assoc 8 (entget (car key)))))
		)
				
		(t nil)
	) 

	(setq dclname 
		(cond  
			(
				(setq tempname (vl-filename-mktemp "re-dcl-tmp.dcl") filen (open tempname "w"))
				(foreach stream '(  
													 "\n"
													 "RENAME:dialog {\n"
													 "    label = \"修改图层名\" ;\n"
													 "    :row {\n"
													 "        :edit_box {\n"
													 "            key = \"dcl_edit_name\" ;\n"
													 "            width = 50 ;\n"
													 "        }\n"
													 "    }\n"
													 "    :row {\n"
													 "        :button {\n"
													 "            key = \"btn_ok\" ;\n"
													 "            label = \"确认\" ;\n"
													 "        }\n"
													 "        :button {\n"
													 "            is_cancel = true ;\n"
													 "            key = \"btn_cancle\" ;\n"
													 "            label = \"取消\" ;\n"
													 "        }\n"
													 "    }\n"
													 "}\n"
												 )
					(princ stream filen)
				)
				(close filen)
				tempname
			)
		)
	)
	(setq dcl_re (load_dialog dclname))
	(if (not (new_dialog "RENAME" dcl_re)) (exit))
	(set_tile "dcl_edit_name" name)
	(mode_tile "dcl_edit_name" 2)
	(action_tile "dcl_edit_name" "(setq name1 $value)")
	(action_tile "btn_ok"
							 "(if (= name \"0\") 
									(progn
										(alert (strcat \"图层: \" name \" 不可更改！\"))
										(exit)
									)
								)
								(if (tblsearch \"layer\" name1)
									(alert (strcat \"图层: \" name1 \" 已经存在.\"))
									(if (not (snvalid name1))
										(alert (strcat \"错误的图层名: \" name1))
										(done_dialog 1)
									)
								)"
	)
	(setq dlg (start_dialog))
	
	(cond 
		((= dlg 1)
			(command "_.rename" "_layer" name name1)
			(princ (strcat "\n图层 \"" name "\" 重命名为 \"" name1 "\""))
		)
			
		(t nil
			
		)
	)
	
	(unload_dialog dcl_re)
	(vl-file-delete dclname)	
  (prin1)
)

;;; 加载提示
(princ "\n图块编辑工具增强版V4.0已加载，命令：RB")
(princ "\n新增功能：修改块描述 | 改块基点（自动计算中心点）| 匿名块改名 | 转匿名块 | 多重加密块")
(princ)