明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 652|回复: 1

[源码] 请问l这个源码汉化为什么不对啊,请指教

[复制链接]
发表于 2017-12-19 15:22:58 | 显示全部楼层 |阅读模式
请问l这个源码汉化为什么不对啊,请指教

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
"觉得好,就打赏"
还没有人打赏,支持一下
 楼主| 发表于 2017-12-19 20:06:55 | 显示全部楼层
;;--------------------=={ TabSort.lsp }==---------------------;;
(defun c:TabSort

  ( /

   ;; --={  Local Functions  }=--

   *error*
   _addtab
   _archsort
   _copytab
   _deletetabs
   _endundo
   _findreplacetab
   _getlayouts
   _getsavepath
   _list->value
   _listdown
   _listtobottom
   _listtotop
   _listup
   _makelist
   _numsort
   _removeitems
   _removenth
   _renametab
   _reverseitems
   _splitstr
   _startundo
   _tabprefixsuffix
   _tabsort
   _tabsorthelp
   _value->list
   _writedcl

   ;; --={  Local Variables  }=--

   acdoc
   aclay
   aclays
   dch
   dclfname
   dclst
   dcltitle
   express
   found
   fstr
   i
   idx
   l
   lst
   name
   ofile
   pref
   ptr
   reslst
   rstr
   savepath
   suff
   x

   ;; --={  Global Variables  }=--

   ;  *prefdef*  -  Setting to Apply a Prefix/Suffix to All Tabs
   ;  *SortTyp*  -  Sort Type Settings
   ;  *SortOrd*  -  Sort Order Settings

  )

;;------------------------------------------------------------;;
;;                       Local Functions                      ;;
;;------------------------------------------------------------;;

  (defun *error* ( msg )
    (if acdoc (_EndUndo acdoc))
    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and ofile (eq 'FILE (type ofile))) (setq ofile (close ofile)))
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ)
  )

;;------------------------------------------------------------;;

  (defun _StartUndo ( doc ) (_EndUndo doc)
    (vla-StartUndoMark doc)
  )

  (defun _EndUndo ( doc )
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark doc)
    )
  )

;;------------------------------------------------------------;;

  (defun _value->list ( val ) (read (strcat "(" val ")")))

  (defun _list->value ( lst ) (vl-string-trim "()" (vl-princ-to-string lst)))

;;------------------------------------------------------------;;

  (defun _GetLayouts ( layouts / lst )
    (vlax-for l layouts
      (if (not (eq "MODEL" (strcase (vla-get-Name l))))
        (setq lst (cons l lst))
      )
    )   
    (vl-sort lst '(lambda ( a b ) (< (vla-get-TabOrder a) (vla-get-TabOrder b))))
  )

;;------------------------------------------------------------;;

  (defun _MakeList ( key lst )
    (start_list key) (mapcar 'add_list lst) (end_list)
  )

;;------------------------------------------------------------;;

  (defun _GetSavePath ( / tmp )
    (cond      
      ( (setq tmp (getvar 'ROAMABLEROOTPREFIX))

        (strcat (vl-string-right-trim "\\" (vl-string-translate "/" "\\" tmp)) "\\Support")
      )
      ( (setq tmp (findfile "ACAD.pat"))

        (vl-string-right-trim "\\" (vl-string-translate "/" "\\" (vl-filename-directory tmp)))
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _WriteDCL ( fname / ofile )
    (cond
      (
        (findfile fname)
      )
      ( (setq ofile (open fname "w"))

        (foreach line
         '(
            "//---------------------=={ TabSort.dcl }==--------------------//"
            "//                                                            //"
            "//  Dialog Definition file for use in conjunction with        //"
            "//  TabSort.lsp                                               //"
            "//------------------------------------------------------------//"
            "//  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       //"
            "//------------------------------------------------------------//"
            ""
            "dcl_settings : default_dcl_settings { audit_level = 1; }"
            ""
            "//------------------------------------------------------------//"
            "//                   SubAssembly Definitions                  //"
            "//------------------------------------------------------------//"
            ""
            "button13 : button   { width = 13; alignment = centered; fixed_width = true; }"
            "button16 : button   { width = 16; alignment = centered; fixed_width = true; }"
            "    eBox : edit_box { alignment = centered; fixed_width = true; allow_accept = true; is_tab_stop = true; }"
            "    fBox : edit_box { alignment = left; fixed_width = true; is_tab_stop = true; }"
            "   title : text     { alignment = centered; is_bold = true; fixed_width = false;}"
            "     txt : text     { alignment = centered; fixed_width = false; }"
            "    ltxt : text     { alignment = left;     fixed_width = false; }"
            ""
            "//------------------------------------------------------------//"
            "//                        Main Dialog                         //"
            "//------------------------------------------------------------//"
            ""
            "tabsort : dialog { key = \"dcltitle\";"
            ""
            "  : image_button { key = \"help\"; label = \"&help\"; color = -15; height = 0.1; width = 0.1; fixed_width = true; }"
            "  spacer;"
            "  "
            "  : row {"
            "    : button13 { key = \"mtop\"; label = \"置顶\"      ; mnemonic = \"T\"; }"
            "    : button13 { key = \"up\"  ; label = \"向上\"       ; mnemonic = \"U\"; }"
            "    : button13 { key = \"down\"; label = \"向下\"     ; mnemonic = \"D\"; }"
            "    : button13 { key = \"mbot\"; label = \"置下\"   ; mnemonic = \"B\"; }"
            "  }"
            "  "
            "  : list_box { key = \"tabs\"; width = 20; fixed_width = false; alignment = centered;  multiple_select = true; }"
            "  "
            "  : row {"
            "    : button13 { key = \"sort\"; label = \"Sort...\"  ; mnemonic = \"S\"; }"
            "    : button13 { key = \"rev\" ; label = \"Reverse\"  ; mnemonic = \"R\"; }"
            "    : button13 { key = \"p_s\" ; label = \"Pref/Suff\"; mnemonic = \"P\"; }"
            "    : button13 { key = \"cur\" ; label = \"Current\"  ; mnemonic = \"n\"; }"
            "  }"
            "  "
            "  spacer;"
            "  "
            "  : row { fixed_width = false;"
            "    : button13 { key = \"add\"   ; label = \"添加\"    ; mnemonic = \"A\"; }"
            "    : button13 { key = \"del\"   ; label = \"删除\" ; mnemonic = \"e\"; }"
            "    : button13 { key = \"copy\"  ; label = \"复制\"   ; mnemonic = \"C\"; }"
            "    : button13 { key = \"fnr\"   ; label = \"查找\"   ; mnemonic = \"F\"; }"
            "  }"
            "  "
            "  : text { label = \"双击重命名布局,输入H查找帮助\" ; alignment = centered; }"
            "  "
            "  : row  { fixed_width = true ; alignment = centered;"
            "    : button13 { key = \"accept\"; label = \"Done\"   ; mnemonic = \"o\"; is_default = true; is_cancel = true; }"
            "    : button13 { key = \"res\"   ; label = \"Reset\"  ; mnemonic = \"s\"; }               "
            "  }"
            "}"
            ""
            "//------------------------------------------------------------//"
            "//                        Rename Dialog                       //"
            "//------------------------------------------------------------//"
            ""
            "rename : dialog { label = \"重命名\"; spacer;"
            "  : eBox { key = \"name\"; edit_width = 20; edit_limit = 255; label = \"新布局名称:\"; }"
            "  : errtile { } "
            "  spacer; ok_cancel;"
            "}"
            ""
            "//------------------------------------------------------------//"
            "//                    Delete Warning Dialog                   //"
            "//------------------------------------------------------------//"
            ""
            "delwarn : dialog { label = \"Warning\"; spacer;"
            "  : text { alignment = centered; label = \"The Selected Tab(s) will be Permanently Deleted\"; }"
            "  : text { alignment = centered; label = \"Proceed?\"; }"
            "  spacer; ok_cancel;"
            "}"
            ""
            "//------------------------------------------------------------//"
            "//                    Prefix/Suffix Dialog                    //"
            "//------------------------------------------------------------//"
            ""
            "prefsuff : dialog { label = \"Add Prefix/Suffix\"; spacer;"
            ""
            "  : row {"
            "    : column {"
            "      : text { alignment = centered; label = \"Prefix\"; }"
            "      : eBox { key = \"pref\"; edit_width = 15; edit_limit = 255; }"
            "    }"
            "    : column {"
            "      : spacer { alignment = centered; width = 10; }"
            "      : text   { alignment = centered; label = \"< Tab Name >\"; }"
            "    }"
            "    : column {"
            "      : text { alignment = centered; label = \"Suffix\"; }"
            "      : eBox { key = \"suff\"; edit_width = 15; edit_limit = 255; }"
            "    }"
            "  }  "
            "  spacer;"
            "  "
            "  : row { spacer;"
            "    : toggle { key = \"all\"; label = \"Apply to all Tabs\"; mnemonic = \"A\"; alignment = right; is_tab_stop = true; }"
            "  }"
            "  : errtile { } ok_cancel;"
            "}"
            ""
            "//------------------------------------------------------------//"
            "//                        Find Dialog                         //"
            "//------------------------------------------------------------//"
            ""
            "find : dialog { label = \"Find and Replace\"; spacer;"
            ""
            "  : row {"
            "    : column { fixed_height = true;"
            "      : text { key = \"fw\"  ; label = \"Find What:\"           ; }"
            "      : fBox { key = \"fstr\"; edit_width = 30; mnemonic = \"W\"; }"
            "      : text { key = \"rw\"  ; label = \"Replace With:\"        ; }"
            "      : fBox { key = \"rstr\"; edit_width = 30; mnemonic = \"R\"; }"
            "    }"
            "    : spacer { width = 4; }"
            "    : column { fixed_height = true;"
            "      : spacer   { height = 0.2   ; }"
            "      : button16 { key = \"fnd\"  ; label = \"Find\"       ; mnemonic = \"F\"; }"
            "      : button16 { key = \"rep\"  ; label = \"Replace\"    ; mnemonic = \"p\"; }"
            "      : button16 { key = \"repa\" ; label = \"Replace All\"; mnemonic = \"A\"; }"
            "    }"
            "  }"
            "  "
            "  spacer;"
            "  : text { key = \"ftxt\"; alignment = left; label = \"String not Found!\"; value = \"\"; }"
            "  spacer;"
            "  : button13 { key = \"accept\";    label = \"Done\"    ; mnemonic = \"o\"; is_default = true; is_cancel = true  ; }"
            "}"
            ""
            "//------------------------------------------------------------//"
            "//                        Sort Dialog                         //"
            "//------------------------------------------------------------//"
            ""
            "sort : dialog { label = \"Sort\"; spacer;"
            ""
            "  : boxed_column { label = \"Sort Type\";"
            "  "
            "    : popup_list { key = \"typ\"; alignment = centered; }"
            "    "
            "    spacer;"
            "    "
            "    : radio_row { children_alignment = centered;"
            "      : radio_button { key = \"asc\"; label = \"Ascending\" ; }"
            "      : radio_button { key = \"des\"; label = \"Descending\"; }"
            "    }"
            "    spacer;"
            "  }"
            "  "
            "  spacer;"
            "  "
            "  : row { fixed_width = false; alignment = centered;"
            "    : button13 { key = \"accept\"; label = \"Sort\"  ; mnemonic = \"S\"; is_default = true; }"
            "    : button13 { key = \"cancel\"; label = \"Cancel\"; mnemonic = \"C\"; is_cancel  = true; }"
            "  }"
            "}"
            ""
            "//------------------------------------------------------------//"
            "//                        Help Dialog                         //"
            "//------------------------------------------------------------//"
            ""
            "help : dialog { key = \"htitle\";"
            "  spacer; : title { label = \"  ---------------------=={ TabSort.lsp }==---------------------  \" ; }"
            "  spacer; : title { label = \"Designed and Created by Lee Mac 2011\" ; }"
            "  spacer; : ltxt  { label = \"   Program Controls:\" ; }"
            "  spacer;"
            "  : row { fixed_width = true; alignment = centered;"
            "    : column {"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"-->\"   ; }"
            "       : txt { label = \"-->\"   ; }"
            "       : txt { label = \"-->\"   ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "       : txt { label = \"[\"     ; }"
            "    }"
            "    : column {"
            "       : txt { label = \"置顶\"          ; }"
            "       : txt { label = \"向上\"           ; }"
            "       : txt { label = \"向下\"         ; }"
            "       : txt { label = \"Bottom\"       ; }"
            "       : txt { label = \"Sort\"         ; }"
            "       : txt { label = \"Alphabetical\" ; }"
            "       : txt { label = \"Numerical\"    ; }"
            "       : txt { label = \"Architectural\"; }"
            "       : txt { label = \"Reverse\"      ; }"
            "       : txt { label = \"Pref/Suff\"    ; }"
            "       : txt { label = \"Add\"          ; }"
            "       : txt { label = \"Delete\"       ; }"
            "       : txt { label = \"Copy\"         ; }"
            "       : txt { label = \"Current\"      ; }"
            "       : txt { label = \"Find\"         ; }"
            "       : txt { label = \"确认\"         ; }"
            "       : txt { label = \"重置\"        ; }"
            "    }"
            "    : column {"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"<--\"   ; }"
            "       : txt { label = \"<--\"   ; }"
            "       : txt { label = \"<--\"   ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "       : txt { label = \"]\"     ; }"
            "    }"
            "    spacer;"
            "    : column {"
            "      : ltxt { label = \"Move selected Tabs to the top of the list.\"             ; }"
            "      : ltxt { label = \"Move selected Tabs up one notch in the list.\"           ; }"
            "      : ltxt { label = \"Move selected Tabs down one notch in the list.\"         ; }"
            "      : ltxt { label = \"Move selected Tabs to the bottom of the list.\"          ; }"
            "      : ltxt { label = \"Opens the Sort Dialog.\"                                 ; }"
            "      : ltxt { label = \"Sort the Tabs Alphabetically.\"                          ; }"
            "      : ltxt { label = \"Sort the Tabs Numerically.\"                             ; }"
            "      : ltxt { label = \"Sort the Tabs using an Architectural sorting method.\"   ; }"
            "      : ltxt { label = \"Reverse the Tab Order.\"                                 ; }"
            "      : ltxt { label = \"Opens the Prefix/Suffix Dialog.\"                        ; }"
            "      : ltxt { label = \"Adds a new layout Tab using the next available name.\"   ; }"
            "      : ltxt { label = \"Deletes the selected Tabs.\"                             ; }"
            "      : ltxt { label = \"Copies the selected Tabs.\"                              ; }"
            "      : ltxt { label = \"Makes the selected Tab the Current Tab.\"                ; }"
            "      : ltxt { label = \"Opens the Find and Replace Dialog.\"                     ; }"
            "      : ltxt { label = \"Finished sorting Tabs, will implement sorting.\"         ; }"
            "      : ltxt { label = \"Will reset Tab names and order - not deleted/added Tabs\"; }"
            "    }"
            "  }"
            "  spacer_1;"
            "  : title { label = \"-------------------------------------------------------------\" ; }"
            "  spacer_1; ok_only;"
            "}"
            ""
            "//------------------------------------------------------------//"
            "//                        End of File                         //"
            "//------------------------------------------------------------//"
          )
          (write-line line ofile)
        )
        (setq ofile (close ofile))

        (while (not (findfile fname))) fname
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _RemoveNth ( n l )
    (if (and l (< 0 n))
      (cons (car l) (_RemoveNth (1- n) (cdr l)))
      (cdr l)
    )
  )

;;------------------------------------------------------------;;

  (defun _RenameTab ( dchand n lst / name )
    (cond
      (
        (not (new_dialog "rename" dchand))

        (cond
          (Express
            (acet-ui-message "Error Loading Rename Dialog" "Warning" 16)
          )
          (t
            (princ "\n** Error Loading Rename Dialog **")
          )
        )
      
        lst
      )
      (t
        (set_tile  "name" (setq name (nth n lst)))
        (mode_tile "name" 2)

        (action_tile "name" "(setq name $value)")

        (action_tile "accept"
          (vl-prin1-to-string
            (quote
              (progn (set_tile "error" "")
                (cond
                  (
                    (eq "" name)

                    (set_tile "error" "Please Enter a Tab Name")
                  )
                  (
                    (wcmatch (strcase name) "*[<>\\/\\\":;`?`*|`,=]*")

                    (set_tile "error" "Invalid Symbol in Tab Name")
                    (mode_tile "name" 2)
                  )
                  (
                    (vl-position (strcase name) (mapcar 'strcase (_RemoveNth n lst)))

                    (set_tile "error" (strcat name " already exists!"))
                    (mode_tile "name" 2)
                  )
                  ( (done_dialog 1) )
                )
              )
            )
          )
        )

        (if (= 1 (start_dialog))
          (cond
            (
              (eq name (nth n lst))

              lst
            )
            (
              (vl-catch-all-error-p
                (vl-catch-all-apply 'vla-put-Name (list (vla-item aclay (nth n lst)) name))
              )
              (cond
                (Express
                  (acet-ui-message "Error Renaming Tab" "Warning" 16)
                )
                (t
                  (alert "\n** Error Renaming Tab **")
                )
              )
              lst
            )
            ( (subst name (nth n lst) lst) )
          )
          lst
        )
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _ListUp ( ind lst ) ; (Gile)
    (cond
      ( (or (null ind) (null lst))

        lst
      )
      ( (= 0  (car ind))

        (cons (car  lst) (_ListUp (cdr (mapcar '1- ind)) (cdr lst)))
      )
      ( (= 1  (car ind))

        (cons (cadr lst) (_ListUp (cdr (mapcar '1- ind)) (cons (car lst) (cddr lst))))
      )
      ( t

        (cons (car  lst) (_ListUp (mapcar '1- ind) (cdr lst)))
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _ListDown ( idx lst )
    (reverse
      (_ListUp
        (reverse
          (mapcar '(lambda ( x ) (- (1- (length lst)) x)) idx)
        )
        (reverse lst)
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _RemoveItems ( idx lst / i )
    (setq i -1)
    (vl-remove-if '(lambda ( x ) (member (setq i (1+ i)) idx)) lst)
  )

;;------------------------------------------------------------;;

  (defun _ListToTop ( idx lst )
    (append (mapcar '(lambda ( i ) (nth i lst)) idx) (_RemoveItems idx lst))
  )

;;------------------------------------------------------------;;

  (defun _ListToBottom ( idx lst )
    (append (_RemoveItems idx lst) (mapcar '(lambda ( i ) (nth i lst)) idx))
  )

;;------------------------------------------------------------;;

  (defun _ReverseItems ( idx lst )
    (
      (lambda ( i l )
        (mapcar
          (function
            (lambda ( x )
              (if (member (setq i (1+ i)) idx)
                (setq x (nth (car l) lst)
                      l (cdr l)
                )
              )
              x
            )
          )
          lst
        )
      )
      -1 (reverse (vl-sort idx '<))
    )
  )

;;------------------------------------------------------------;;

  (defun _TabSort ( dchand lst )
   
    (or *SortTyp* (setq *SortTyp*   "0"))
    (or *SortOrd* (setq *SortOrd* "asc"))

    (cond
      (
        (not (new_dialog "sort" dchand))

        (cond
          (Express
            (acet-ui-message "Error Loading Sort Dialog" "Warning" 16)
          )
          (t
            (princ "\n** Error Loading Sort Dialog **")
          )
        )
        lst
      )
      (t

        (_MakeList "typ" '("Alphabetical" "Numerical" "Architectural"))
      
        (set_tile "typ" *SortTyp*)
        (set_tile *SortOrd*   "1")

        (action_tile "typ" "(setq *SortTyp* $value)")
        (action_tile "asc" "(setq *SortOrd*   $key)")
        (action_tile "des" "(setq *SortOrd*   $key)")

        (if (zerop (start_dialog)) lst
          (progn
            (cond
              ( (eq "0" *SortTyp*)

                (setq lst (acad_strlsort lst))
              )
              ( (eq "1" *SortTyp*)

                (setq lst (_NumSort lst))
              )
              ( (eq "2" *SortTyp*)

                (setq lst (_ArchSort lst))
              )
            )
            (if (eq "asc" *SortOrd*)
              lst
              (reverse lst)
            )
          )
        )
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _SplitStr ( str / lst test rslt num tmp ) ; (Gile)

    (setq lst  (vl-string->list str)
          test (chr (car lst))
    )   
    (if (< 47 (car lst) 58)
      (setq num T)
    )
    (while (setq lst (cdr lst))
      (if num
        (cond
          ( (= 46 (car lst))

            (if
              (and
                (cadr lst)
                (setq tmp (strcat "0." (chr (cadr lst))))
                (numberp (read tmp))
              )
              (setq rslt (cons (read test) rslt)
                    test tmp
                    lst  (cdr lst)
              )
              (setq rslt (cons (read test) rslt)
                    test "."
                    num nil
              )
            )
          )
          ( (< 47 (car lst) 58)

            (setq test (strcat test (chr (car lst))))
          )
          ( t

            (setq rslt (cons (read test) rslt)
                  test (chr (car lst))
                  num  nil
            )
          )
        )
        (if (< 47 (car lst) 58)
          (setq rslt (cons test rslt)
                test (chr (car lst))
                num  T
          )
          (setq test (strcat test (chr (car lst))))
        )
      )
    )
   
    (if num
      (setq rslt (cons (read test) rslt))
      (setq rslt (cons test rslt))
    )   
    (reverse rslt)
  )

;;------------------------------------------------------------;;

  (defun _ArchSort ( lst / comparable ) ; (Gile)
   
    (defun comparable ( e1 e2 )
      (or
        (and (numberp e1) (numberp e2))
        (= 'STR (type e1) (type e2))
        (not e1)
        (not e2)
      )
    )
   
    (mapcar '(lambda ( x ) (nth x lst))      
      (vl-sort-i (mapcar '_SplitStr lst)
        (function
          (lambda ( x1 x2 / n1 n2 comp )
            (while
              (and
                (setq comp
                  (comparable (setq n1 (car x1)) (setq n2 (car x2)))
                )
                (= n1 n2)
              )
              (setq x1 (cdr x1) x2 (cdr x2))
            )            
            (if comp (< n1 n2) (numberp n1))
          )
        )
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _NumSort ( lst )

    (mapcar '(lambda ( x ) (nth x lst))   
      (vl-sort-i (mapcar '(lambda ( x ) (vl-remove-if-not 'numberp (_SplitStr x))) lst)
        (function
          (lambda ( a b )
            (while (and a b (= (car a) (car b)))
              (setq a (cdr a)
                    b (cdr b)
              )
            )
            (if (or a b) (< (car a) (car b)) t)
          )
        )
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _DeleteTabs ( dchand idx lst / x )
    (cond
      (Express
        (setq x
          (acet-ui-message "The Selected Tab(s) Will be Permanently Deleted.\n\nProceed?" "Delete Tab(s)?" 52)
        )
      )
      ( (not (new_dialog "delwarn" dchand))

        (princ "\n** Error Loading Delete Dialog **")
      )
      (t
        (action_tile "accept" "(setq x 6) (done_dialog)")
        (start_dialog)
      )
    )

    (if (= 6 x)
      (if
        (vl-catch-all-error-p
          (vl-catch-all-apply
           '(lambda nil
              (foreach i idx (vla-delete (vla-item aclay (nth i lst))))
            )
          )
        )
        (cond
          (Express
            (acet-ui-message "Error Deleting Tab(s)" "Warning" 16)
          )
          (t
            (alert "\n** Error Deleting Tab(s) **")
          )
        )
        (setq lst (_RemoveItems idx lst))
      )
    )
    lst
  )

;;------------------------------------------------------------;;

  (defun _TabPrefixSuffix ( dchand idx lst / pref suff item tmp i )
   
    (or *prefdef* (setq *prefdef* 0))
   
    (cond
      ( (not (new_dialog "prefsuff" dchand))

        (cond
          (Express
            (acet-ui-message "Error Loading Prefix/Suffix Dialog" "Warning" 16)
          )
          (t
            (princ "\n** Error Loading Prefix/Suffix Dialog **")
          )
        )
        lst
      )
      (t

        (set_tile "all" (itoa *prefdef*))

        (action_tile "accept"
          (vl-prin1-to-string
            (quote
              (progn
                (cond
                  (
                    (and
                      (not (eq "" (setq pref (get_tile "pref"))))
                      (wcmatch (strcase pref) "*[<>\\/\\\":;`?`*|`,=]*")
                    )

                    (set_tile "error" "Invalid Symbol in Prefix")
                    (mode_tile "pref" 2)
                  )
                  (
                    (and
                      (not (eq "" (setq suff (get_tile "suff"))))
                      (wcmatch (strcase suff) "*[<>\\/\\\":;`?`*|`,=]*")
                    )

                    (set_tile "error" "Invalid Symbol in Suffix")
                    (mode_tile "suff" 2)
                  )
                  (
                    (and (zerop *prefdef*) (setq tmp (mapcar 'strcase (_RemoveItems idx lst)))
                      (vl-some
                        (function
                          (lambda ( x )
                            (vl-position (strcase (strcat pref x suff)) tmp)
                          )
                        )
                        (mapcar '(lambda ( x ) (nth x lst)) idx)
                      )
                    )

                    (set_tile "error" "Amendment would create Duplicate tab")
                    (mode_tile "pref" 2)
                  )
                  ( (done_dialog 1) )
                )
              )
            )
          )
        )

        (action_tile "all" "(setq *prefdef* (atoi $value))")

        (if (= 1 (start_dialog))
          (cond
            (
              (zerop *prefdef*)

              (setq i -1)

              (setq lst
                (mapcar
                  (function
                    (lambda ( x )
                      (if (member (setq i (1+ i)) idx)
                        (progn
                          (vla-put-name (vla-item aclay x) (strcat pref x suff))
                          (strcat pref x suff)
                        )
                        x
                      )
                    )
                  )
                  lst
                )
              )
            )
            (
              t

              (setq lst
                (mapcar
                  (function
                    (lambda ( x )
                      (vla-put-name (vla-item aclay x) (strcat pref x suff))
                      (strcat pref x suff)
                    )
                  )
                  lst
                )
              )
            )
          )
        )
      )
    )
    lst
  )
  
;;------------------------------------------------------------;;
  
  (defun _AddTab ( lst / tmp i upp )

    (setq tmp "Layout1" i 1 upp (mapcar 'strcase lst))
   
    (while (member (strcase tmp) upp)
      (setq tmp (strcat "Layout" (itoa (setq i (1+ i)))))
    )
    (vla-add aclay tmp)
    (append lst (list tmp))
  )

;;------------------------------------------------------------;;

  (defun _CopyTab ( idx lst / upp oldname oldlay newname i objlst newlay newblk )
   
    (setq upp (mapcar 'strcase lst))

    (foreach x idx
      (setq oldname (nth x lst)
            oldlay  (vla-item aclay oldname)
            newname (strcat oldname " (2)")
            i       2
            objlst  nil
      )
      (while (member (strcase newname) upp)
        (setq newname (strcat oldname " (" (itoa (setq i (1+ i))) ")"))
      )
      (setq newlay (vla-add aclay newname)
            newblk (vla-get-block newlay)
            lst    (append lst (list newname))
      )
      (vla-copyfrom newlay oldlay)

      (if
        (vlax-for o (vla-get-block oldlay)
          (setq objlst (cons o objlst))
        )
        (vla-copyobjects acdoc
          (vlax-make-variant
            (vlax-safearray-fill
              (vlax-make-safearray vlax-vbobject (cons 0 (1- (length objlst)))) (reverse objlst)
            )
          )
          newblk
        )
      )
    )

    lst
  )
  
;;------------------------------------------------------------;;

  (defun _FindReplaceTab ( dchand lst / fstr rstr found tab idx flen i nstr rlen m n )

    (cond
      (
        (not (new_dialog "find" dchand))

        (cond
          (Express
            (acet-ui-message "Error Loading Find and Replace Dialog" "Warning" 16)
          )
          (t
            (princ "\n** Error Loading Find & Replace Dialog **")
          )
        )
        lst
      )
      (t

        (set_tile "ftxt" "")
        (set_tile "fstr" (setq fstr ""))
        (set_tile "rstr" (setq rstr ""))

        (action_tile "fstr" "(set_tile \"ftxt\" \"\") (setq found nil fstr $value)")
        (action_tile "rstr" "(setq rstr $value)")

        (action_tile "fnd"
          (vl-prin1-to-string
            (quote
              (progn
                (cond
                  (
                    found
                  
                    (set_tile "ftxt" (caar found))
                    (setq tab   (cadar  found)
                          idx   (caddar found)
                          found (cdr    found)
                    )
                  )
                  (
                    t
                    (cond
                      (
                        (eq fstr "")

                        (set_tile "ftxt" "Please Enter a String to Find.")
                        (setq found nil tab nil idx nil)
                      )
                      (t
                        (setq flen (strlen fstr) i 0)
                       
                        (foreach x lst
                          (while (setq i (vl-string-search (strcase fstr) (strcase x) i))
                            (setq found
                              (cons
                                (list
                                  (strcat (substr x 1 i) "[" (substr x (1+ i) flen) "]" (substr x (+ i flen 1)))
                                  x
                                  i
                                )
                                found
                              )
                              i (+ i flen)
                            )
                          )
                        )
                        (setq found (reverse found))

                        (cond
                          (
                            found
                           
                            (set_tile "ftxt" (caar found))
                            (setq tab   (cadar  found)
                                  idx   (caddar found)
                                  found (cdr    found)
                            )
                          )
                          (
                            t

                            (set_tile "ftxt" "String not Found.")
                            (setq tab nil idx nil)
                          )
                        )
                      )
                    )
                  )
                )
              )
            )
          )
        )

        (action_tile "rep"
          (vl-prin1-to-string
            (quote
              (progn
                (cond
                  (
                    (not tab)

                    (set_tile "ftxt" "String not Found.")
                  )
                  (
                    (wcmatch rstr "*[<>\\/\\\":;`?`*|`,=]*")

                    (set_tile "ftxt" "Invalid Symbol in Replace String.")
                  )
                  (
                    (member
                      (vl-string-trim " "
                        (strcase
                          (setq nstr
                            (strcat (substr tab 1 idx) rstr (substr tab (+ 1 idx flen)))
                          )
                        )
                      )
                      (mapcar 'strcase lst)
                    )

                    (set_tile "ftxt" "Replacement would create Duplicate Tab.")
                  )
                  (
                    t
                    (vla-put-Name (vla-item aclay tab) nstr)
                  
                    (set_tile "ftxt" (strcat (get_tile "ftxt") "  ->  " nstr))
                    (setq lst (subst nstr tab lst))

                    (setq found
                      (mapcar
                        (function
                          (lambda ( x )
                            (if (eq tab (cadr x))
                              (progn
                                (if (< idx (setq i (caddr x)))
                                  (setq i (+ (caddr x) (- (strlen rstr) flen)))
                                )
                                (setq i (vl-string-search (strcase fstr) (strcase nstr) i))
                                (list
                                  (strcat (substr nstr 1 i) "[" (substr nstr (1+ i) flen) "]" (substr nstr (+ i flen 1)))
                                  nstr
                                  i
                                )
                              )
                              x
                            )
                          )
                        )
                        found
                      )
                    )
                  )
                )
              )
            )
          )
        )

        (action_tile "repa"
          (vl-prin1-to-string
            (quote
              (progn
                (set_tile "ftxt" "")

                (cond
                  (
                    (eq fstr "")

                    (set_tile "ftxt" "Please Enter a String to Find.")
                    (setq found nil)
                  )
                  (
                    (wcmatch rstr "*[<>\\/\\\":;`?`*|`,=]*")

                    (set_tile "ftxt" "Invalid Symbol in Replace String.")
                  )
                  (
                    t
                    (setq n 0
                          flen (strlen fstr)
                          rlen (strlen rstr)
                    )

                    (foreach tab lst
                      (setq m n
                            i 0
                            nstr tab
                      )                     
                      (while (setq i (vl-string-search (strcase fstr) (strcase nstr) i))
                        (setq nstr (strcat (substr nstr 1 i) rstr (substr nstr (+ 1 i flen)))
                                 i (+ i rlen)
                                 m (1+ m)
                        )
                      )
                      (if (not (member (strcase nstr) (mapcar 'strcase lst)))
                        (progn
                          (vla-put-name (vla-item aclay tab) nstr)
                          (setq n   m
                                lst (subst nstr tab lst)
                          )
                        )
                      )
                    )

                    (set_tile "ftxt"
                      (if (< 0 n)
                        (strcat (itoa n) " Replacements Made.")
                        "String not Found."
                      )
                    )
                  )
                )
              )
            )
          )
        )

        (start_dialog)
      )
    )
    lst
  )

;;------------------------------------------------------------;;

  (defun _TabSortHelp ( dchand title )
    (cond
      (
        (not (new_dialog "help" dchand))

        (cond
          (Express
            (acet-ui-message "Error Loading Help Dialog" "Warning" 16)
          )
          (t
            (princ "\n** Error Loading Help Dialog **")
          )
        )
      )
      (t
        (set_tile "htitle" title)
        (start_dialog)
      )
    )
  )

;;------------------------------------------------------------;;

  (defun _ListDupes ( l )
    (if l
      (if (vl-position (car l) (cdr l))
        (cons (car l) (_ListDupes (vl-remove (car l) (cdr l))))
        (_ListDupes (vl-remove (car l) (cdr l)))
      )
    )
  )

;;------------------------------------------------------------;;

  (setq acdoc (vla-get-activedocument (vlax-get-acad-object))
        aclay (vla-get-layouts acdoc)
  )

  (if (not (vl-file-directory-p (setq SavePath (_GetSavePath))))
    (progn
      (princ "\n** Save Path not Valid **") (exit)
    )
  )

  (setq dclfname (strcat SavePath "\\LMAC_TabSort_V" TabSortVersion# ".dcl")
        dcltitle (strcat "TabSort V" (vl-string-translate "-" "." TabSortVersion#))
  )
  
  (setq Express
    (and (vl-position "acetutil.arx" (arx))
      (not
        (vl-catch-all-error-p
          (vl-catch-all-apply
            (function (lambda nil (acet-sys-shift-down)))
          )
        )
      )
    )
  )

;;------------------------------------------------------------;;
  
  (cond
    (
      (not (_WriteDCL dclfname))

      (cond
        (Express
          (acet-ui-message "DCL File Could not be Written" "Warning" 16)
        )
        (t
          (princ "\n** DCL File Could not be Written **")
        )
      )
    )
    (
      (< (setq dch (load_dialog dclfname)) 0)

      (cond
        (Express
          (acet-ui-message "DCL File not Found" "Warning" 16)
        )
        (t
          (princ "\n** DCL File not Found **")
        )
      )
    )
    (
      (not (new_dialog "tabsort" dch))

      (cond
        (Express
          (acet-ui-message "Error Loading TabSort Dialog" "Warning" 16)
        )
        (t
          (princ "\n** Error Loading TabSort Dialog **")
        )
      )
    )
    (t

      (_StartUndo acdoc)

      (setq dclst  (mapcar 'vla-get-Name (_GetLayouts aclay))
            resLst dclst
      )
      (set_tile "dcltitle" dcltitle)

      (_MakeList "tabs" dclst)
     
      (set_tile "tabs"
        (setq ptr
          (if (zerop (getvar 'TILEMODE))
            (itoa (vl-position (getvar 'CTAB) dclst))
            "0"
          )
        )
      )

      (action_tile "tabs"
        (vl-prin1-to-string
          (quote
            (progn (setq ptr $value)
              (if (= 4 $reason)
                (progn
                  (_MakeList "tabs" (setq dclst (_RenameTab dch (atoi ptr) dclst)))
                  (set_tile "tabs" ptr)
                )
              )
            )
          )
        )
      )

      (action_tile "up"
        (vl-prin1-to-string
          (quote
            (progn
              (setq
                idx (_value->list ptr)
                old (mapcar '(lambda ( x ) (nth x dclst)) idx)
              )
              (_MakeList "tabs" (setq dclst (_ListUp idx dclst)))
              (set_tile  "tabs"
                (setq ptr
                  (_list->value (mapcar '(lambda ( x ) (vl-position x dclst)) old))
                )
              )
            )
          )
        )
      )
         
      (action_tile "down"
        (vl-prin1-to-string
          (quote
            (progn
              (setq
                idx (_value->list ptr)
                old (mapcar '(lambda ( x ) (nth x dclst)) idx)
              )
              (_MakeList "tabs" (setq dclst (_ListDown idx dclst)))
              (set_tile  "tabs"
                (setq ptr
                  (_list->value (mapcar '(lambda ( x ) (vl-position x dclst)) old))
                )
              )
            )
          )
        )
      )

      (action_tile "mtop"
        (vl-prin1-to-string
          (quote
            (progn
              (_MakeList "tabs" (setq dclst (_ListToTop (setq idx (_value->list ptr)) dclst)))

              (setq i -1)
              (set_tile "tabs"
                (setq ptr
                  (_list->value (mapcar '(lambda ( x ) (setq i (1+ i))) idx))
                )
              )
            )
          )
        )
      )

      (action_tile "mbot"
        (vl-prin1-to-string
          (quote
            (progn
              (_MakeList "tabs" (setq dclst (_ListToBottom (setq idx (_value->list ptr)) dclst)))
              
              (setq i (length dclst))
              (set_tile "tabs"
                (setq ptr
                  (_list->value (reverse (mapcar '(lambda ( x ) (setq i (1- i))) idx)))
                )
              )
            )
          )
        )
      )

      (action_tile "sort"
        (vl-prin1-to-string
          (quote
            (progn
              (setq
                idx (_value->list ptr)
                old (mapcar '(lambda ( x ) (nth x dclst)) idx)
              )
              (_MakeList "tabs" (setq dclst (_TabSort dch dclst)))
              (set_tile  "tabs"
                (setq ptr
                  (_list->value (mapcar '(lambda ( x ) (vl-position x dclst)) old))
                )
              )
            )
          )
        )
      )
     
      (action_tile "rev"
        (vl-prin1-to-string
          (quote
            (progn
              (_MakeList "tabs" (setq dclst (_ReverseItems (_value->list ptr) dclst)))
              (set_tile  "tabs" ptr)
            )
          )
        )
      )
         
      (action_tile "del"
        (vl-prin1-to-string
          (quote
            (progn
              (setq
                idx (_value->list ptr)
                old (mapcar '(lambda ( x ) (nth x dclst)) idx)
                tmp dclst
              )
              (setq newres
                (_RemoveItems
                  (mapcar '(lambda ( x ) (1- (vla-get-TabOrder (vla-item aclay x)))) old)
                  resLst
                )
              )
              (_MakeList "tabs"
                (setq dclst
                  (cond
                    ( (_DeleteTabs dch idx dclst) )
                    ( (mapcar 'vla-get-Name (_GetLayouts aclay)) )
                  )
                )
              )
              (if (not (equal tmp dclst)) (setq resLst (cond ( newres ) ( dclst ))))

              (set_tile "tabs"
                (setq ptr
                  (if (zerop (getvar 'TILEMODE))
                    (itoa (vl-position (getvar 'CTAB) dclst))
                    "0"
                  )
                )
              )
            )
          )
        )
      )
         
      (action_tile "p_s"
        (vl-prin1-to-string
          (quote
            (progn
              (_MakeList "tabs" (setq dclst (_TabPrefixSuffix dch (_value->list ptr) dclst)))
              (set_tile  "tabs" ptr)
            )
          )
        )
      )

      (action_tile "res"
        (vl-prin1-to-string
          (quote
            (progn
              (cond
                (
                  (_ListDupes (mapcar 'strcase resLst))

                  (cond
                    (Express
                      (acet-ui-message "Resetting would create Duplicate Tabs" "Warning" 48)
                    )
                    (t
                      (alert "Resetting would create Duplicate Tabs")
                    )
                  )
                )
                (
                  t
                 
                  (_MakeList "tabs" (setq dclst resLst))
                  (mapcar 'vla-put-Name (_GetLayouts aclay) resLst)
                  
                  (set_tile "tabs"
                    (setq ptr
                      (if (zerop (getvar 'TILEMODE))
                        (itoa (vl-position (getvar 'CTAB) dclst))
                        "0"
                      )
                    )
                  )
                )
              )
            )
          )
        )
      )

      (action_tile "add"
        (vl-prin1-to-string
          (quote
            (progn
              (_MakeList "tabs" (setq dclst (_AddTab dclst)))
              (setq resLst (append resLst (list (last dclst))))
              (set_tile "tabs" (setq ptr (itoa (1- (length dclst)))))
            )
          )
        )
      )

      (action_tile "cur"
        (vl-prin1-to-string
          (quote
            (progn
              (setvar "CTAB" (nth (setq ptr (car (_value->list ptr))) dclst))
              (set_tile "tabs" (setq ptr (itoa ptr)))
            )
          )
        )
      )

      (action_tile "copy"
        (vl-prin1-to-string
          (quote
            (progn
              (setq
                idx (_value->list ptr)
                tmp dclst
                i   (1- (length dclst))
                j   i                     
              )
              (_MakeList "tabs" (setq dclst (_CopyTab idx dclst)))
              (setq resLst
                (append resLst
                  (mapcar '(lambda ( x ) (nth (setq i (1+ i)) dclst)) idx)
                )
              )              
              (set_tile "tabs"
                (setq ptr
                  (_list->value (mapcar '(lambda ( x ) (setq j (1+ j))) idx))
                )
              )
            )
          )
        )
      )

      (action_tile "fnr"
        (vl-prin1-to-string
          (quote
            (progn
              (_MakeList "tabs" (setq dclst (_FindReplaceTab dch dclst)))
              (set_tile "tabs" ptr)
            )
          )
        )
      )

      (action_tile "help" "(_TabSortHelp dch (strcat dcltitle \" - Help\"))")

      (start_dialog)
      (setq dch (unload_dialog dch))

      (cond
        (
          (equal (setq dclst (mapcar 'strcase dclst))
            (mapcar 'strcase
              (mapcar 'vla-get-Name
                (setq aclays (_GetLayouts aclay))
              )
            )
          )
        )
        (t
          (foreach lay aclays
            (vla-put-TabOrder lay
              (1+ (vl-position (strcase (vla-get-Name lay)) dclst))
            )
          )
        )
      )
      (_EndUndo acdoc)
    )
  )

  (princ)
)

;;------------------------------------------------------------;;

(vl-load-com) (princ)

(princ
  (strcat
    "\n:: TabSort.lsp | Version " (vl-string-translate "-" "." TabSortVersion#) " | ?Lee Mac 2011 www.lee-mac.com ::"
    "\n:: Type \"TabSort\" to Invoke ::"
  )
)
(princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2025-5-19 21:47 , Processed in 0.196262 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表