功能强大的序号程序
转贴一个功能强大的序号程序，那位大侠修正完善？;;
(vl-load-com)
;;(arx)
(defun &GetEntDxf (ent_name code / ent vla_name result)
(if (and ent_name code)
(progn
(setq result nil)
(setq vla_name (vlax-ename->vla-object ent_name))
(cond ((= code 62)
(setq result (vlax-get-property vla_name 'color))
)
((= code 6)
(setq result (vlax-get-property vla_name 'linetype))
)
((= code 48)
(setq result (vlax-get-property vla_name 'linetypescale))
)
(T
(progn
(setq ent (entget ent_name))
(setq result (cdr (assoc code ent)))
)
)
)
)
nil
)
result
)
;;
(defun &SortSs_X (ss /)
(&SortSs ss 1)
)
(defun &SortSs_X2 (ss /)
(&SortSs ss 2)
)
(defun &SortSs_Y (ss /)
(&SortSs ss 3)
)
(defun &SortSs_Y2 (ss /)
(&SortSs ss 4)
)
(defun &SortSs (ss ii / i ii pts ss ss1 index)
(setq ss ss)
(setq ii ii)
(if (and ss
(> (sslength ss) 1)
)
(progn
(setq i 0)
(setq pts nil)
(repeat (sslength ss)
(setq pts (cons (&GetEntDxf (ssname ss i) 10) pts))
(setq i (+ i 1))
)
(setq pts (reverse pts)
ss1 (ssadd)
)
(cond
((= ii 1) (setq index (&SortX_Index pts)))
((= ii 2) (setq index (&SortX2_Index pts)))
((= ii 3) (setq index (&SortY_Index pts)))
((= ii 4) (setq index (&SortY2_Index pts)))
)
(setq i 0)
(repeat (sslength ss)
(setq ss1 (ssadd (ssname ss (nth i index)) ss1))
(setq i (+ i 1))
)
(setq i 0)
(setq pts nil)
(repeat (sslength ss1)
(setq pts (cons (&GetEntDxf (ssname ss1 i) 10) pts))
(setq i (+ i 1))
)
)
)
(list ss1 (reverse pts))
)
;;
;;;(&SortX_Index '((1 3) (2 5) (3 1)(4 6)))
(defun &SortX_Index (lst / lst e1 e2)
(setq lst lst)
(setq lst (vl-sort-i lst
(function
(lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
)
)
;;;(&SortX2_Index '((1 3) (2 5) (3 1)(4 6)))
(defun &SortX2_Index (lst / lst e1 e2)
(setq lst lst)
(setq lst (vl-sort-i lst
(function
(lambda (e1 e2)
(> (car e1) (car e2))
)
)
)
)
)
;;;(&SortY_Index '((1 4) (1 2) (1 3)(1 1)))
(defun &SortY_Index (lst / lst e1 e2)
(setq lst lst)
(setq lst (vl-sort-i lst
(function
(lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
)
)
;;;(&SortY2_Index '((1 4) (1 2) (1 3)(1 1)))
(defun &SortY2_Index (lst / lst e1 e2)
(setq lst lst)
(setq lst (vl-sort-i lst
(function
(lambda (e1 e2)
(> (cadr e1) (cadr e2))
)
)
)
)
)
;;
(defun &SsNameList (ss / n lst)
(if (= 'PICKSET (type ss))
(repeat (setq n (sslength ss))
(setq n (1- n)
lst (cons (ssname ss n) lst)
)
)
)
)
;;
(defun &EntMod (ent_name dxf_lst / i ent
num input1 input2 color linetype
linetypescale
)
(if (and
ent_name
(setq ent (entget ent_name))
(> (setq num (/ (length dxf_lst) 2)) 0)
)
(progn
(setq i 0)
(repeat num
(setq input1 (nth (* i 2) dxf_lst))
(setq input2 (nth (+ (* i 2) 1) dxf_lst))
(cond
((= input1 62)
(vlax-put-property
(vlax-ename->vla-object ent_name)
'color
input2
)
)
((= input1 6)
(vlax-put-property
(vlax-ename->vla-object ent_name)
'linetype
input2
)
)
((= input1 48)
(vlax-put-property
(vlax-ename->vla-object ent_name)
'linetypescale
input2
)
)
((and (/= input1 62) (/= input1 6) (/= input1 48))
(progn
(setq
ent (subst (cons input1 input2) (assoc input1 ent) ent)
)
(setq ent (entmod ent))
)
)
)
(setq i (+ i 1))
)
(cdr (assoc -1 ent))
)
nil
)
)
;;
(defun &Begin (SysVarLst / x y)
(Defun *Error* (St)
(If (/= St "函数已取消")
(Princ "\n**函数已取消**")
)
(&End)
(Princ)
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
(if (/= (length SysVarLst) 0)
(setq *OriSysVars*
(mapcar
'(lambda (x / y)
(if (= (type x) 'LIST)
(setq y (list (car x) (getvar (car x))))
(setq y (list x (getvar x)))
)
(if (/= (type x) 'STR)
(eval (cons 'setvar x))
)
y
)
SysVarLst
)
)
)
(setq &error *error*
*error* &error
)
(princ)
)
(Defun &End ()
(If *Orisysvars*
(Mapcar '(Lambda (X)
(Eval (Cons 'Setvar X))
)
*Orisysvars*
)
)
(Vla-Endundomark
(Vla-Get-Activedocument (Vlax-Get-Acad-Object))
)
(Setq *Error* &Error)
(Setq *Orisysvars*
Nil
&Error Nil
)
(Princ)
)
;;
(defun &ListTable (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
(vl-remove 'nil (acad_strlsort (reverse r)))
)
;;
(defun &PutVarible (Varible Varible_Save Val_default)
(if (null Varible_Save)
(setq Varible Val_default)
(setq Varible Varible_Save)
)
)
;;
(defun &TileEnable (clist)
(mapcar
'(lambda (x)
(mode_tile x 0)
)
clist
)
)
;;禁用按钮
;;clist 按钮关键字列表
(defun &TileDisable (clist)
(mapcar
'(lambda (x)
(mode_tile x 1)
)
clist
)
)
;;
;|;(If (Member "acetutil.arx" (Arx))
(setq Acetutil_loaded T)
(If (Findfile "Acetutil.Arx")
(if (Arxload "Acetutil.Arx")
(setq Acetutil_loaded T)
(setq Acetutil_loaded nil)
)
(setq Acetutil_loaded nil)
)
);|;
;;
(defun c:AutoNum (/ Dcl_Id Do_What
List_Sort Style_Cur List_Style
Index_Style Edit_Type Prefix
Start_Num Suffix Inc_Num
Index_Sort Judge_Replace Pt_Screen
Txt_Height Sort_Type
)
(Defun Edit_Write
(/ Ss I Ss_List N Txt_Ori Txt_Num Txt_New Pt1 Pt Ent_Txt)
;;编辑模式
(If (= Edit_Type 1)
(Progn
(If (And (Setq Ss (Ssget '((0 . "TEXT"))))
(Setq I -1)
)
(Progn
(Cond ((= Index_Sort "0") (Setq Ss (Car (&SortSs_Y2 Ss))))
((= Index_Sort "2") (Setq Ss (Car (&SortSs_X Ss))))
((= Index_Sort "1") (Setq Ss (Car (&SortSs_Y Ss))))
((= Index_Sort "3") (Setq Ss (Car (&SortSs_X2 Ss))))
)
(Setq Ss_List (&SsNameList Ss))
(Foreach N Ss_List
(Progn
(Setq Txt_Ori (&GetEntDxf N 1)
Txt_Num (Itoa (+ (Atoi Start_Num)
(* (Setq I (1+ I)) (Atoi Inc_Num))
)
)
)
(If (= Start_Num "")
(Setq Txt_Num "")
)
(Cond
((= Judge_Replace "0")
(Setq Txt_New (Strcat Prefix Txt_Num Txt_Ori Suffix))
)
((= Judge_Replace "1")
(Setq Txt_New (Strcat Prefix Txt_Num Suffix))
)
)
(&EntMod N (List 1 Txt_New))
)
)
(redraw)
)
)
)
)
;;书写模式
(If (= Edit_Type 2)
(Progn
(Setq I -1)
(while (setq pt (getpoint "\n点取文字插入点[退出]"))
(Setq
Txt_Num
(Itoa (+ (Atoi Start_Num)
(* (Setq I (1+ I)) (Atoi Inc_Num))
)
)
)
(If (= Start_Num "")
(Setq Txt_Num "")
)
(Setq Txt_New (Strcat Prefix Txt_Num Suffix))
(Vl-Cmdf "Text" "S" Txt_Style pt Txt_Height 0 Txt_New)
)
;|;(if Acetutil_loaded
(progn
(Setq Pt1 (Car (&GetScreenPts)))
(Setq I -1)
(While
(And
(Progn (Setq
Txt_Num
(Itoa (+ (Atoi Start_Num)
(* (Setq I (1+ I)) (Atoi Inc_Num))
)
)
)
(If (= Start_Num "")
(Setq Txt_Num "")
)
(Setq Txt_New (Strcat Prefix Txt_Num Suffix))
)
(Progn
(Vl-Cmdf "Text" "S" Txt_Style Pt1 Txt_Height 0 Txt_New)
(Setq Ent_Txt (Entlast)
Ss (Ssadd)
Ss (Ssadd Ent_Txt Ss)
)
(&Redraw_Ss Ss 2)
)
(Setq Pt (Acet-Ss-Drag-Move Ss Pt1 "\n插入位置:"))
)
(Command ".Move" Ss "" Pt1 Pt)
)
(If (And SS (Null Pt))
(&Erase_Ss Ss)
)
);|;
)
)
)
;;Main
(&Begin '(("Cmdecho" 0)("Orthomode" 0)))
(Setq Dcl_Id (Load_Dialog "AutoNum.Dcl"))
(Setq Do_What 2)
(Setq List_Sort '("上 => 下" "上 <= 下" "左 => 右" "左 <= 右"))
(Setq Style_Cur (Getvar "TEXTSTYLE")
List_Style(&ListTable "STYLE")
Index_Style (Itoa (Vl-Position Style_Cur List_Style))
Txt_Style (Nth (Atoi Index_Style) List_Style)
)
(Setq Edit_Type (&PutVarible Edit_Type AutoNum_Edit_Type_Save 1)
Prefix (&PutVarible Prefix AutoNum_Prefix_Save "No.")
Start_Num (&PutVarible Start_Num AutoNum_Start_Num_Save "1")
Suffix (&PutVarible Suffix AutoNum_Suffix_Save "")
Inc_Num (&PutVarible Inc_Num AutoNum_Inc_Num_Save "1")
Index_Sort (&PutVarible Index_Sort AutoNum_Index_Sort_Save "0")
Judge_Replace (&PutVarible
Judge_Replace
AutoNum_Judge_Replace_Save
"0"
)
Pt_Screen (&Putvarible
Pt_Screen
AutoNum_Pt_Screen_Save
(List 500 600)
)
Txt_Height (&PutVarible
Txt_Height
AutoNum_Txt_Height_Save
(Rtos (Getvar "TEXTSIZE") 2 2)
)
)
;;(Setq Prefix "No.")
(Setq Sort_Type (Nth (Atoi Index_Sort) List_Sort))
(Vl-Cmdf "Undo" "Be")
(While (= Do_What 2)
(Progn
(If (Not (New_Dialog "AutoNum" Dcl_Id "" Pt_Screen))
(Exit)
)
;;初始化
(Start_List "Sort_Type")
(Mapcar 'Add_List List_Sort)
(End_List)
(Start_List "Style")
(Mapcar 'Add_List List_Style)
(End_List)
(Set_Tile "Prefix" Prefix)
(Set_Tile "Start_No" Start_Num)
(Set_Tile "Suffix" Suffix)
(Set_Tile "Inc" Inc_Num)
(Set_Tile "Sort_Type" Index_Sort)
(Set_Tile "Replace" Judge_Replace)
(Set_Tile "Height" Txt_Height)
(Set_Tile "Style" Index_Style)
(cond ((= Edit_Type 1)
(Progn (Set_Tile "Edit_Mode" "1")
(Set_Tile "Write_Mode" "0")
;;(Setq Prefix "No.")
(Set_Tile "Prefix" Prefix)
(&TileEnable '("Sort_Type" "Replace"))
(&TileDisable '("Height" "Style"))
)
)
((= Edit_Type 2)
(Progn (Set_Tile "Edit_Mode" "0")
(Set_Tile "Write_Mode" "1")
;;(Setq Prefix "KL-")
(Set_Tile "Prefix" Prefix)
(&TileEnable '("Height" "Style"))
(&TileDisable '("Sort_Type" "Replace"))
)
)
)
;;定义动作
(Action_Tile "Prefix" "(Setq Prefix $Value)")
(Action_Tile "Start_No" "(Setq Start_Num $Value)")
(Action_Tile "Suffix" "(Setq Suffix $Value)")
(Action_Tile "Inc" "(Setq Inc_Num $Value)")
(Action_Tile
"Sort_Type"
"(Setq Index_Sort $Value)
(Setq Sort_Type (Nth (Atoi Index_Sort) List_Sort))"
)
(Action_Tile "Replace" "(Setq Judge_Replace $Value)")
(Action_Tile
"Edit_Mode"
"(Setq Edit_Type 1)
(Set_Tile \"Prefix\" Prefix)
(Set_Tile \"Edit_Mode\" \"1\")
(Set_Tile \"Write_Mode\" \"0\")
(&TileEnable '("Sort_Type\" \"Replace\"))
(&TileDisable '(\"Height\" \"Style\"))"
)
(Action_Tile
"Write_Mode"
"(Setq Edit_Type 2)
(Set_Tile \"Prefix\" Prefix)
(Set_Tile \"Edit_Mode\" \"0\")
(Set_Tile \"Write_Mode\" \"1\")
(&TileDisable '(\"Sort_Type\" \"Replace\"))
(&TileEnable '(\"Height\" \"Style\"))"
)
(Action_Tile "Height" "(Setq Txt_Height $Value)")
(Action_Tile
"Style"
"(Setq Index_Style $Value)
(Setq Txt_Style (Nth (Atoi Index_Style) List_Style))"
)
(Action_Tile "accept" "(Setq Pt_Screen (Done_Dialog 2))")
(Action_Tile "cancel" "(Done_Dialog 0)")
(Setq Do_What (Start_Dialog))
(If (= Do_What 2)
(Edit_Write)
)
)
)
(Unload_Dialog Dcl_Id)
(Vl-Cmdf "Undo" "E")
(Setq AutoNum_Edit_Type_Save
Edit_Type
AutoNum_Prefix_Save
Prefix
AutoNum_Start_Num_Save
Start_Num
AutoNum_Suffix_Save
Suffix
AutoNum_Inc_Num_Save
Inc_Num
AutoNum_Index_Sort_Save
Index_Sort
AutoNum_Judge_Replace_Save
Judge_Replace
AutoNum_Pt_Screen_Save
Pt_Screen
AutoNum_Txt_Height_Save
Txt_Height
)
(&End)
(Princ)
)
(princ "\n'自动序号',命令:AutoNum, Copyright 2006, By JieGa.")
AutoNum : dialog {
label = "自动序号 Copyright 2006, JieGa. ";
initial_focus = "Prefix";
:row{
: boxed_column {
label = "初始设置";
fixed_width = true;
: edit_box {
label = "前 缀";
key = "Prefix";
edit_width=5;
}
: edit_box {
label = "起始编号";
key = "Start_No";
edit_width=5;
}
: edit_box {
label = "后 缀";
key = "Suffix";
edit_width=5;
}
}
: boxed_column {
label = "控制参数";
: edit_box {
label = "序号增量";
key = "Inc";
edit_width=10;
}
: popup_list {
label = "排序方式";
key = "Sort_Type";
width = 9;
}
: toggle {
label = "替代原文字";
key = "Replace";
value = 0;
}
}
}
:row{
:boxed_radio_column{
label="操作方式";
:radio_button{
label="编辑模式 ";
key="Edit_Mode";
value=1;
}
:radio_button{
label="书写模式 ";
key="Write_Mode";
value=0;
}
}
: boxed_column {
label = "文字参数";
: edit_box {
label = "文字高度";
key = "Height";
edit_width=10;
}
: popup_list {
label = "文字样式";
key = "Style";
edit_width=9;
}
}
}
spacer_1;
:row {
:spacer { width = 1;}
:button {
label = "确定";
key = "accept";
width = 5;
fixed_width = true;
}
:spacer { width = 1;}
:button {
label = "退出";
is_cancel = true;
key = "cancel";
width = 5;
fixed_width = true;
}
:spacer { width = 1;}
}
}
麻烦，整个完整的出来吧。 本帖最后由 fangmin723 于 2024-4-9 12:12 编辑
整合lsp和dcl
支持一下上推荐
书写模式下，文字跟随光标移动代码如下，如有需要，自行替换：
;;书写模式
(if(= edit_type 2)
(progn
(setq i -1 pt (cadr (grread T 15 0)))
(while pt
(setq txt_num (itoa (+ (atoi start_num) (* (setq i (1+ i)) (atoi inc_num)))))
(if (= start_num "") (setq txt_num ""))
(setq txt_new (strcat prefix txt_num suffix))
(setq ent (entmakex (list '(0 . "TEXT") (cons 1 txt_new) (cons 7 txt_style) (cons 40 (atof txt_height)) (cons 10 pt) (cons 11 pt) '(71 . 0) '(72 . 4)))
tdata (entget ent)
)
(while (and (setq gr (grread T 15 0)) (or (= (car gr) 5) (= (car gr) 2) (= (car gr) 11) (= (car gr) 25)))
(if (= (car gr) 5)
(progn
(setq pt (cadr gr))
(setq tdata (subst (cons 10 pt) (assoc 10 tdata) tdata) tdata (subst (cons 11 pt) (assoc 11 tdata) tdata))
(entmod tdata)
)
(progn (entdel ent) (setq pt nil))
)
)
)
)
)
fangmin723 发表于 2024-4-9 07:57
整合lsp和dcl
支持一下上推荐
程序有BUG，书写模式，选用的文字样式的文字高度必须设置为0才行，否则标出来全是倾斜的0，求助修改！ <p>真可惜了。这么强大的序号程序不能用也没有高手帮忙修正。唉浪费了</p> 楼主不是演示了吗？ 我在2008里试了一下，不能用，遗憾。 <p>程序代码超繁琐，估计修改起来费劲。</p>
<p> </p>
<p></p>
<p></p> 还是没有人修改一下啊，可惜了这么好的程序了 再顶 再顶 <table cellspacing="0" cellpadding="0">
<tbody>
<tr>
<td>
<div id="textstyle_8" style="FONT-SIZE: 12pt; OVERFLOW: hidden; WORD-BREAK: break-all; TEXT-INDENT: 0px; WORD-WRAP: break-word">再顶 </div></td></tr></tbody></table><font face="Verdana" color="#da2549"><b>xyp1964</b></font> 本帖最后由 作者 于 2010-9-18 12:07:42 编辑 <br /><br /> <p></p>
<p>DCL檔在1樓</p>