功能强大的序号程序

hnfsf · 发表于 2009-7-27 08:17:00

转贴一个功能强大的序号程序，那位大侠修正完善？

;;
(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.")

;; 
(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;}
}
}

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;} 
           } 
        }

feelg · 发表于 2010-8-29 13:06:00

麻烦，整个完整的出来吧。

fangmin723 · 发表于 2024-4-9 07:57:14

本帖最后由 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))
)
)
)
)
)

;;书写模式 
(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)) 
        ) 
      ) 
    ) 
  ) 
)

huxu823 · 发表于 2024-4-9 11:35:27

fangmin723 发表于 2024-4-9 07:57
整合lsp和dcl
支持一下上推荐

程序有BUG，书写模式，选用的文字样式的文字高度必须设置为0才行，否则标出来全是倾斜的0，求助修改！

jialiang168 · 发表于 2010-8-21 00:26:00

真可惜了。这么强大的序号程序不能用也没有高手帮忙修正。唉浪费了

fengshi0519 · 发表于 2010-8-21 13:28:00

楼主不是演示了吗？

fengshi0519 · 发表于 2010-8-21 13:32:00

我在2008里试了一下，不能用，遗憾。

xyp1964 · 发表于 2010-8-21 14:23:00

程序代码超繁琐，估计修改起来费劲。

fengshi0519 · 发表于 2010-8-24 12:55:00

还是没有人修改一下啊，可惜了这么好的程序了

fengshi0519 · 发表于 2010-8-26 16:21:00

再顶

kkt123 · 发表于 2010-8-26 20:19:00

再顶

xfyy · 发表于 2010-8-26 20:58:00

再顶

xyp1964

龙龙仔 · 发表于 2010-8-27 07:24:00

本帖最后由作者于 2010-9-18 12:07:42 编辑

DCL檔在1樓

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

功能强大的序号程序

本帖子中包含更多资源

本帖被以下淘专辑推荐:

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源