南子 发表于 2002-3-3 17:41:00

新作一个写常用文字的程序,命令是ztext

本帖最后由 作者 于 2002-3-3 17:41:59 编辑

新作一个写字的程序,命令是ztext。欢迎大家试用。
添加新词:在新词的编辑框填写完之后,在其他空间上一点击,
如:在'字高'编辑框点击一下就添加到列表中去了。
如果要大量编辑词库,可以用命令:zedittext
注意:该文本第一列为词库名称,每行的词一"Tab"键分隔.
    可以在r14下调用.


uploadImages/20023317415011545.rar

龙龙仔 发表于 2002-3-2 11:50:00

有繁体版吗?

有繁体版吗?
E_MAIL: lai_wan_lung@pchome.com.tw

mccad 发表于 2002-3-2 12:07:00

看来以后程序都应该增加繁体版及英文版才行 :)

南子 发表于 2002-3-3 17:52:00

已经把源代码给上传明经下载中心了

您有空可以改改。
对话框:

dcl_settings : default_dcl_settings { audit_level = 3; }
ztext : dialog {
      label="XZ";
      : popup_list {
            label = "词库";
            key = "libs";
            edit_width = 10;
            fixed_width = true;
            fixed_height = false;
      }
      : list_box {
            key = "libword";   
            width = 20;
            fixed_width = true;
            height = 15;
            is_default=true;
      }
      : edit_box {
            label = "字高";
            key = "height";
            edit_width = 10;
            width = 10;
            fixed_width = true;
      }
      : popup_list {
            label = "字型";
            key = "style";
            edit_width = 10;
            width = 5;
            fixed_width = true;
      }
      : edit_box {
            label = "新词";
            key = "new";
            edit_width = 10;
            width = 10;
            fixed_width = true;
      }
      : button {
            label = "南子休息";
            key = "cancel";
//            is_default = true;
            is_cancel = true;
            fixed_width = true;
            alignment=centered;
      }   
}



程序段:
(defun tabstr (tab / num str)
(setq
    str        (apply 'strcat
             (mapcar '(lambda (x) (strcat x "\t")) tab)
        )
)
(substr str 1 (- (strlen str) 1))        ; _ 结束repeat
)
;;;(tabstr '("1" "2" "3" "4"))
(defun strtab (str / len num tab str1 s)
(setvar "cmdecho" 0)
(setq        len(strlen str)
        num1
        tabnil
        str1 ""
)                                        ; _ end of setq
(while (< num (+ 1 len))
    (setq s (substr str num 1))
    (cond
      ((= "\t" s)
       (setq tab(cons str1 tab)
             num(+ 1 num)
             str1 ""
       )                                ; _ end of setq
      )
      (T
       (setq str1 (strcat str1 s)
             num(+ 1 num)
       )                                ; _ end of setq
      )
    )
    (if        (> num len)
      (setq tab (cons str1 tab))
    )
)                                        ; _ end of while
(reverse tab)
)
(defun tab_to_str (tab / len num str)
(setq        str (apply 'strcat
                   (mapcar '(lambda (x) (strcat x " ")) tab)
          )
)
(substr str 1 (- (strlen str) 1))
)
(defun str_to_tab
       (str sym / len num tmp len0 len1 a d_len pick pick_list)
(setq len (strlen str))
(setq        num 1
        tmp num
)                                        ; _ end of setq
(setq len0 len)
(setq pick_list nil)
(repeat len
    (setq a (substr str num 1))
    (if        (= sym a)
      (progn
        (setq len1 (strlen (substr str num)))
        (setq d_len (- len0 len1))
        (setq pick (substr str tmp d_len))
        (setq pick_list (cons pick pick_list))
        (setq num (+ 1 num))
        (setq tmp num)
        (setq len0 (- len1 1))
      )                                        ; _ end of progn
      (if (= len num)
        (progn
          (setq num (+ 1 num))
          (setq pick (substr str tmp))
          (setq pick_list (cons pick pick_list))
        )                                ; _ end of progn
        (setq num (+ 1 num))
      )                                        ; _ end of if
    )                                        ; _ end of if
)                                        ; _ end of repeat
(setq pick_list (reverse pick_list))
)
;;;(progn (setq f (open "c:\\ztext.xz" "w"))(princ "" f)(close f))
(defun c:ztext (/          dcl_id        filename    ztext_styles
                ztext_records                ztext_libsid
                dd          in                os          ZTEXT_TEXT
             )
(defun ztext_saverecords (filename ztext_records / F STRRECORDS)
    (setq strrecords
           (apply 'strcat
                  (mapcar '(lambda (x) (strcat (tabstr x) "\n"))
                          (reverse ztext_records)
                  )
           )
    )
    (setq strrecords (substr strrecords 1 (- (strlen strrecords) 1)))
    (setq f (open filename "w"))
    (princ strrecords f)
    (close f)
    (princ)
)
(defun ztext_new (key value reason)
    (setq ztext_lib (nth (read (get_tile "libs")) ztext_libs))
    (if        (and (/= "" value)
             (= reason 2)
             (not (member value
                          (cdr (assoc ztext_lib
                                      ztext_records
                             )
                          )
                  )
             )
        )
      (progn
        (setq ztext_records
             (subst
               (cons
                   ztext_lib
                   (cons value
                       (cdr (assoc ztext_lib
                                     ztext_records
                              )
                       )
                   )
               )
               (assoc        ztext_lib
                        ztext_records
               )
               ztext_records
             )
        )
        (start_list "libword" 3)
        (mapcar        'add_list
                (cdr (assoc ztext_lib
                          ztext_records
                     )
                )
        )
        (end_list)
      )
    )
)

;;;(zgetstylenames)
(defun zgetstylenames        (/ style stylename0 stylenames)
    (setq style (tblnext "style" t))
    (if        style
      (setq stylename0 (cdr (assoc 2 style)))
    )
    (while (setq style (tblnext "style"))
      (setq stylenames (cons (cdr (assoc 2 style)) stylenames))
    )
    (setq stylenames (cons stylename0 stylenames))
)
(defun ztext_REMOVE (ele lst)                        ; by Serge Volkov
(apply 'append (subst nil (list ele) (mapcar 'list lst)))
)
(defun c:zedittext()
    (alert "编辑文件时请用'Tab'键做分隔符\n每行的第一个字符串为词库名称")
    (command "shell" "notepad.exe c:\\ztext.xz"))
;;;(defun Zgetstyles (/ styles)
;;;(vl-load-com)
;;;(vlax-for x
;;;              (vlax-get        (vla-get-activedocument (vlax-get-acad-object))
;;;                        "TextStyles"
;;;              )
;;;    (setq styles (cons (vlax-get x "name") styles))
;;;)
;;;)
(defun zgetfilerecords (filename / f readme text ztext_records)
    (if        (findfile filename)
      (progn
        (setq f (open filename "r"))
        (while (setq readme (read-line f))
          (if (/= "" readme)
          (setq ztext_records (cons (strtab readme) ztext_records))
          )
        )
        (close f)
      )
    )
    ztext_records
)
(defun ztext_libword (key value reason / IN OS)
    (setq ztext_lib (nth (read (get_tile "libs")) ztext_libs))
    (if        (cdr (assoc ztext_lib
                  ztext_records
             )
        )
      (setq
        ztext_text
       (nth (read value)
              (cdr (assoc ztext_lib
                          ztext_records
                   )
              )
       )
      )
      (setq ztext_text nil)
    )
    (cond      
      ((= 1 reason) (setq ztext_dclpos (done_dialog 1)))
;;;      ((= 4 reason)
;;;       (progn
;;;       (setq ztext_records
;;;                (subst
;;;                  (cons
;;;                  ztext_lib
;;;                  (ztext_REMOVE ztext_text
;;;                             (cdr (assoc ztext_lib
;;;                                           ztext_records
;;;                                  )
;;;                             )
;;;                  )
;;;                  )
;;;                  (assoc ztext_lib
;;;                       ztext_records
;;;                  )
;;;                  ztext_records
;;;                )
;;;       )
;;;       (start_list "libword" 3)
;;;       (mapcar (function add_list)
;;;               (cdr (assoc ztext_lib
;;;                             ztext_records
;;;                      )
;;;               )
;;;       )
;;;       (end_list)
;;;       )
;;;      )
    )
)
(defun ztext_selectlibs (key value)
    (setq ztext_lib (nth (read value) ztext_libs))
    (start_list "libword" 3)
    (mapcar 'add_list
          (cdr (assoc        ztext_lib
                        ztext_records
               )
          )
    )
    (end_list)
)


(setq filename "c:\\ztext.xz")
(setq ztext_styles (Zgetstylenames))
(setq ztext_records (zgetfilerecords filename))
(if (not ztext_records)
    (setq ztext_records
           '(("通用词库")
             ("南子" "单元" "楼梯" "阳台")
             ("用户1")
             ("用户2")
             ("用户3")
             ("用户4")
             ("用户5")
          )
    )
)
(setq ztext_libs (mapcar 'car ztext_records))
(setq ztext_dclpos '(-1 -1))
;;;(unload_dialog id)
(if        (< (setq id
                  (load_dialog "ztext.dcl")
           ) ;_ end of setq
           0
        ) ;_ end of <
      (exit)
    )
(setq dd 1)
(while (> dd 0)   
    (if        (not (new_dialog "ztext" id "" ztext_dclpos))
      (exit)
    )
    (if        (and ztext_height
             (= 'STR (type ztext_height))
             (numberp (read ztext_height))
        )
      (set_tile "height" ztext_height)
      (set_tile "height" (setq ztext_height "0.4"))
    ) ;_ end of if
    (progn (start_list "style" 3)
           (mapcar 'add_list ztext_styles)
           (end_list)
    )
    (setq ztext_style (nth (read (get_tile "style")) ztext_styles))
    (progn (start_list "libs" 3)
           (mapcar 'add_list ztext_libs)
           (end_list)
    )
    (if        (not ztext_lib)
      (setq ztext_lib "通用词库")
    )
    (set_tile "libs"
              (itoa (- (length ztext_libs)
                     (length (member ztext_lib ztext_libs))
                  )
              )
    )
    (progn (start_list "libword" 3)
           (mapcar 'add_list
                   (cdr        (assoc ztext_lib
                             ztext_records
                        )
                   )
           )
           (end_list)
    )
    (action_tile
      "style"
      "(setq ztext_style (nth (read $value) ztext_styles))"
    )
    (action_tile
      "height"
      "(setq ztext_height (if (read $value) $value \"0.4\"))"
    )
    (action_tile "cancel" "(setq ztext_dclpos (done_dialog 0))")
    (action_tile
      "libword"
      "(ztext_libword $key $value $reason)"
    )
    (action_tile "new" "(ztext_new $key $value $reason)")
    (action_tile "libs" "(ztext_selectlibs $key $value)")
    (setq dd (start_dialog))
    (cond ((= 0 dd) (ztext_saverecords filename ztext_records))
          (t
           (if ztext_text
             (progn
             (setq os (getvar "osmode"))
             (setvar "osmode" 0)
             (setq in (getpoint "\n 请选择文字位置:"))
             (setvar "osmode" os)
             (if in
               (entmake
                   (list '(0 . "TEXT")
                       (cons 8 (getvar "clayer"))                       
;;;                     (cons 62
;;;                           (cond ((= "BYLAYER" (getvar "cecolor")) 256)
;;;                               ((= "BYBLOCK" (getvar "cecolor")) 0)
;;;                                 (t (atoi (getvar "cecolor")))                               
;;;                           )
;;;                     )
                       '
                          (10 0.000 0.000 0.000)
                       (cons 40 (atof ztext_height))
                       (cons 50 0.0)
                       (cons 1 ztext_text)
                       (cons 7 ztext_style)
                       '(71 . 0)
                       '(72 . 1)
                       '(73 . 0)
                       (cons 11 in)
                       '(210 0.000 0.000 0.000)
                   )
               )
               (progn        (setq dd 0)
                        (ztext_saverecords filename ztext_records)
               )
             )
             )
           )
          )
    )
    (princ)
) ;_ end of while
)

liminnet 发表于 2008-6-23 17:58:00

页: [1]
查看完整版本: 新作一个写常用文字的程序,命令是ztext