[源码]智能技术要求库

cabinsummer · 发表于 2012-2-21 22:35

本帖最后由 cabinsummer 于 2016-12-24 15:06 编辑

本程序是十几年前开发的。这几天匆匆整理了一下，优化了一下代码，将原来500多行的程序精简到200多行，但总觉得没有达到乔布斯那样的理念。现在有了一些新思路，但群友们强烈要求，所以先把这个版本公布出来，以后进一步优化后再另立新帖。

程序效果：

程序命令：TCF
将对话框文件存成tcf.dcl
再建立一个tcf.ini文本文件放技术要求库，这个务必要有，否则将出错。
采集入库目前只能选择单行文本
这几个文件都要在搜索路径中

teclib :dialog
{
label="技术要求";
:boxed_row
{
label="技术要求库";
:column
{
:list_box
{
key="itemlist";
value="0";
width=43;
height=10;
fixed_width=true;
allow_accept=true;
value="0";
}
:edit_box
{
key="item";
width=24;
allow_accept=true;
}
spacer;
}
:column
{
fixed_width = true;
alignment = centered;
:button
{
label="添加";
key="add";
fixed_width=true;
}
:button
{
label="删除";
key="del";
fixed_width=true;
}
:button
{
label="上移";
key="up";
fixed_width=true;
}
:button
{
label="下移";
key="down";
fixed_width=true;
}
:button
{
label="修改";
key="mdf";
fixed_width=true;
}
}
}
:boxed_row
{
label="技术要求项";
:list_box
{
key="itemlist0";
value="0";
width=43;
height=10;
fixed_width=true;
value="0";
}
:column
{
fixed_width=true;
alignment = centered;
:button
{
label="加入";
key="addlist";
fixed_width=true;
}
:button
{
label="去除";
key="removelist";
fixed_width=true;
}
:button
{
label="上移";
key="up0";
fixed_width=true;
}
:button
{
label="下移";
key="down0";
fixed_width=true;
}
}
}
:row
{
:button
{
label="采集入库";
key="pick";
fixed_width=true;
}
ok_cancel;
}
}

teclib :dialog 
{ 
  label="技术要求"; 
  :boxed_row 
  { 
    label="技术要求库"; 
    :column 
    { 
      :list_box 
      { 
        key="itemlist"; 
        value="0"; 
        width=43; 
        height=10; 
        fixed_width=true; 
        allow_accept=true; 
        value="0"; 
      } 
      :edit_box 
      { 
        key="item"; 
        width=24; 
        allow_accept=true; 
      } 
      spacer; 
    } 
    :column 
    { 
      fixed_width = true; 
      alignment = centered; 
      :button 
      { 
        label="添加"; 
        key="add"; 
        fixed_width=true; 
      } 
      :button 
      { 
        label="删除"; 
        key="del"; 
        fixed_width=true; 
      } 
      :button 
      { 
        label="上移"; 
        key="up"; 
        fixed_width=true; 
      } 
      :button 
      { 
        label="下移"; 
        key="down"; 
        fixed_width=true; 
      } 
      :button 
      { 
        label="修改"; 
        key="mdf"; 
        fixed_width=true; 
      } 
    } 
  } 
  :boxed_row 
  { 
    label="技术要求项"; 
    :list_box 
    { 
      key="itemlist0"; 
      value="0"; 
      width=43; 
      height=10; 
      fixed_width=true; 
      value="0"; 
    } 
    :column 
    { 
      fixed_width=true; 
      alignment = centered; 
      :button 
      { 
        label="加入"; 
        key="addlist"; 
        fixed_width=true; 
      } 
      :button 
      { 
        label="去除"; 
        key="removelist"; 
        fixed_width=true; 
      } 
      :button 
      { 
        label="上移"; 
        key="up0"; 
        fixed_width=true; 
      } 
      :button 
      { 
        label="下移"; 
        key="down0"; 
        fixed_width=true; 
      } 
    } 
  } 
  :row 
  { 
    :button 
    { 
      label="采集入库"; 
      key="pick"; 
      fixed_width=true; 
    } 
    ok_cancel; 
  } 
}

(defun delsame (list0) (if list0 (cons (car list0) (delsame (vl-remove (car list0) list0)))))
(defun fwrdlist (list0 n)
(reverse (cdr (member (nth n list0) (reverse list0))))
)
(defun backlist (list0 n)
(cdr (member (nth n list0) list0))
)
(defun swapfwrd (list0 n)
(if (and (>= (1- n) 0) (> (length crtlst) n))
(setq list0 (append (fwrdlist list0 (1- n)) (list (nth n list0) (nth (1- n) list0)) (backlist list0 n)))
)
list0
)
(defun swapback (list0 n)
(if (and (>= n 0) (> (length crtlst) (1+ n)))
(setq list0 (append (fwrdlist list0 n) (list (nth (1+ n) list0) (nth n list0)) (backlist list0 (1+ n))))
)
list0
)
(defun add_item (list0 n item)
(if (and (>= n 0) (> (length crtlst) n))
(append (fwrdlist list0 n) (list item (nth n list0)) (backlist list0 n))
)
)
(defun del_item (list0 n)
(if (and (>= n 0) (> (length crtlst) n))
(append (fwrdlist list0 n) (backlist list0 n))
)
)
(defun mdfylist (list0 n item)
(if (and (>= n 0) (> (length crtlst) n))
(append (fwrdlist list0 n) (list item) (backlist list0 n))
)
)
(defun readfn (/ fn ftext crtlst)
(setq fn (open (findfile "tcf.ini") "r"))
(while (setq ftext (read-line fn)) (setq crtlst (append crtlst (list ftext))))
(close fn)
(setq textstr (nth 0 crtlst))
crtlst
)
(defun writefn (crtlst / fn)
(setq fn (open (findfile "tcf.ini") "w"))
(foreach x crtlst (write-line x fn))
(close fn)
)
(defun updlst (key lst /)
(start_list key 3)
(mapcar 'add_list lst)
(end_list)
)
(defun do_list (key / n)
(setq n (atoi (get_tile key)))
(setq textstr (nth n crtlst))
(cond
((= key "itemlist")
(if (= (length crtlst) (1+ n))(mode_tile "down" 1)(mode_tile "down" 0))
(if (= n 0)(mode_tile "up" 1)(mode_tile "up" 0))
(set_tile "item" textstr)
(mode_tile "item" 2)
)
((= key "itemlist0")
(if (= (length crtlst0) (1+ n))(mode_tile "down0" 1)(mode_tile "down0" 0))
(if (= n 0)(mode_tile "up0" 1)(mode_tile "up0" 0))
)
)
)
(defun mdfitem (/ n textstr)
(setq n (atoi (get_tile "itemlist")) textstr (get_tile "item"))
(setq crtlst (mdfylist crtlst n textstr))
(writefn crtlst)
(updlst "itemlist" crtlst)
(set_tile "itemlist" (itoa n))
(do_list "itemlist")
)
(defun additem ()
(setq crtlst (add_item crtlst (atoi (get_tile "itemlist")) (get_tile "item")))
(writefn crtlst)
(updlst "itemlist" crtlst)
(set_tile "itemlist" "0")
(do_list "itemlist")
)
(defun delitem ()
(setq crtlst (del_item crtlst (atoi (get_tile "itemlist"))))
(writefn crtlst)
(updlst "itemlist" crtlst)
(set_tile "itemlist" "0")
(do_list "itemlist")
)
(defun upitem (/ n textstr0 val)
(if (> (setq n (atoi (get_tile "itemlist"))) 0)
(progn
(setq crtlst (swapfwrd crtlst n))
(writefn crtlst)
(updlst "itemlist" crtlst)
(set_tile "itemlist" (itoa (1- n)))
(do_list "itemlist")
)
)
)
(defun downitem (/ n)
(if (< (setq n (atoi (get_tile "itemlist"))) (1- (length crtlst)))
(progn
(setq crtlst (swapback crtlst n))
(writefn crtlst)
(updlst "itemlist" crtlst)
(set_tile "itemlist" (itoa (1+ n)))
(do_list "itemlist")
)
)
)
(defun upitem0 (/ n)
(if (> (setq n (atoi (get_tile "itemlist0"))) 0)
(progn
(setq crtlst0 (swapfwrd crtlst0 n))
(updlst "itemlist0" crtlst0)
(set_tile "itemlist0" (itoa (1- n)))
(do_list "itemlist0")
)
)
)
(defun downitem0 (/ n val temp)
(if (< (setq n (atoi (get_tile "itemlist0"))) (1- (length crtlst0)))
(progn
(setq crtlst0 (swapback crtlst0 n))
(updlst "itemlist0" crtlst0)
(set_tile "itemlist0" (itoa (1+ n)))
(do_list "itemlist0")
)
)
)
(defun addlist ()
(setq crtlst0 (delsame (append crtlst0 (list (get_tile "item")))))
(updlst "itemlist0" crtlst0)
(set_tile "itemlist0" (itoa (1- (length crtlst0))))
(mode_tile "removelist" 0)
(do_list "itemlist0")
)
(defun removelist (/ n)
(setq n (atoi (get_tile "itemlist0")))
(setq crtlst0 (del_item crtlst0 n))
(updlst "itemlist0" crtlst0)
(set_tile "itemlist0" "0")
(if (null crtlst0)(mode_tile "removelist" 1))
(do_list "itemlist0")
)
(defun tolib (/ ss fn n txt)
(setq ss (ssget '((0 . "text"))) do_what nil)
(if ss
(progn
(setq n 0)
(repeat (sslength ss)
(setq crtlst (append crtlst (list (cdr (assoc 1 (entget (ssname ss n)))))) n (1+ n))
)
(setq crtlst (delsame crtlst))
(writefn crtlst)
(updlst "itemlist" crtlst)
)
)
(setq crtlst0 nil)
(princ)
)
(defun c:tcf (/ textstr0 scl DLG_ID index result crd crtlst n crtlst0 kd do_what)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq syserr *error* *error* '(nil (princ)))
(setq scl (getvar "dimscale"))
(setq crtlst (readfn))
(if (> (setq DLG_ID (load_dialog (findfile "tcf.dcl"))) 0)
(while (and (/= result 1) (/= result 0))
(if (= do_what 3)
(tolib)
)
(if (new_dialog "teclib" DLG_ID)
(progn
(updlst "itemlist" crtlst)
(set_tile "itemlist" "0")
(set_tile "item" textstr)
(mode_tile "item" 2)
(mode_tile "up" 1)
(mode_tile "up0" 1)
(mode_tile "down0" 1)
(if (null crtlst0)(mode_tile "removelist" 1))
(action_tile "itemlist" "(do_list \"itemlist\")")
(action_tile "item" "(setq textstr $value)")
(action_tile "mdf" "(mdfitem)")
(action_tile "add" "(additem)")
(action_tile "del" "(delitem)")
(action_tile "up" "(upitem)")
(action_tile "down" "(downitem)")
(action_tile "itemlist0" "(do_list \"itemlist0\")")
(action_tile "addlist" "(addlist)")
(action_tile "removelist" "(removelist)")
(action_tile "up0" "(upitem0)")
(action_tile "down0" "(downitem0)")
(action_tile "pick" "(setq do_what 3)(done_dialog)")
(action_tile "accept" "(setq result 1)(done_dialog)")
(action_tile "cancel" "(setq result 0)(done_dialog 0)")
(start_dialog)
)
)
)
)
(unload_dialog DLG_ID)
(if (and (= result 1) (setq crd (getpoint "\n文本位置:")))
(if crtlst0
(progn
(setq n 0 textstr0 "")
(repeat (length crtlst0)
(setq textstr0 (strcat textstr0 (itoa (1+ n)) ". " (nth n crtlst0) "\\P"))
(setq n (1+ n))
)
(vl-string-right-trim "\\P" textstr0)
(setq kd (getcorner crd "\n段落宽:"))
(entmake (list '(0 . "MTEXT")'(100 . "AcDbEntity")'(100 . "AcDbMText")(cons 10 crd)(cons 40 (* scl 3.5))(cons 41 (- (car kd)(car crd)))'(71 . 1)'(72 . 5)(cons 1 textstr0)'(8 . "TEXT")))
(entmake (list '(0 . "TEXT")'(10 0.0 0.0 0.0)(cons 40 (* scl 5.0))'(72 . 1)'(73 . 1)(cons 11 (list (/ (+ (car crd)(car kd)) 2.0) (+ (cadr crd)(* 4.0 scl)) 0.0))'(1 . "技术要求")'(8 . "TEXT")))
)
(entmake (list '(0 . "TEXT")(cons 10 crd)(cons 40 (* scl 3.5))(cons 1 textstr)'(8 . "TEXT")))
)
)
(setq *error* syserr)
(command "undo" "e")
(princ)
)

(defun delsame (list0) (if list0 (cons (car list0) (delsame (vl-remove (car list0) list0))))) 
(defun fwrdlist (list0 n) 
  (reverse (cdr (member (nth n list0) (reverse list0)))) 
) 
(defun backlist (list0 n) 
  (cdr (member (nth n list0) list0)) 
) 
(defun swapfwrd (list0 n) 
  (if (and (>= (1- n) 0) (> (length crtlst) n)) 
    (setq list0 (append (fwrdlist list0 (1- n)) (list (nth n list0) (nth (1- n) list0)) (backlist list0 n))) 
  ) 
  list0 
) 
(defun swapback (list0 n) 
  (if (and (>= n 0) (> (length crtlst) (1+ n))) 
    (setq list0 (append (fwrdlist list0 n) (list (nth (1+ n) list0) (nth n list0)) (backlist list0 (1+ n)))) 
  ) 
  list0 
) 
(defun add_item (list0 n item) 
  (if (and (>= n 0) (> (length crtlst) n)) 
    (append (fwrdlist list0 n) (list item (nth n list0)) (backlist list0 n)) 
  ) 
) 
(defun del_item (list0 n) 
  (if (and (>= n 0) (> (length crtlst) n)) 
    (append (fwrdlist list0 n) (backlist list0 n)) 
  ) 
) 
(defun mdfylist (list0 n item) 
  (if (and (>= n 0) (> (length crtlst) n)) 
    (append (fwrdlist list0 n) (list item) (backlist list0 n)) 
  ) 
) 
(defun readfn (/ fn ftext crtlst) 
  (setq fn (open (findfile "tcf.ini") "r")) 
  (while (setq ftext (read-line fn)) (setq crtlst (append crtlst (list ftext)))) 
  (close fn) 
  (setq textstr (nth 0 crtlst)) 
  crtlst 
) 
(defun writefn (crtlst / fn) 
  (setq fn (open (findfile "tcf.ini") "w")) 
  (foreach x crtlst (write-line x fn)) 
  (close fn) 
) 
(defun updlst (key lst /) 
  (start_list key 3) 
  (mapcar 'add_list lst) 
  (end_list) 
) 
(defun do_list (key / n) 
  (setq n (atoi (get_tile key))) 
  (setq textstr (nth n crtlst)) 
  (cond 
    ((= key "itemlist") 
      (if (= (length crtlst) (1+ n))(mode_tile "down" 1)(mode_tile "down" 0)) 
      (if (= n 0)(mode_tile "up" 1)(mode_tile "up" 0)) 
      (set_tile "item" textstr) 
      (mode_tile "item" 2) 
    ) 
    ((= key "itemlist0") 
      (if (= (length crtlst0) (1+ n))(mode_tile "down0" 1)(mode_tile "down0" 0)) 
      (if (= n 0)(mode_tile "up0" 1)(mode_tile "up0" 0)) 
    ) 
  ) 
) 
(defun mdfitem (/ n textstr) 
  (setq n (atoi (get_tile "itemlist")) textstr (get_tile "item")) 
  (setq crtlst (mdfylist crtlst n textstr)) 
  (writefn crtlst) 
  (updlst "itemlist" crtlst) 
  (set_tile "itemlist" (itoa n)) 
  (do_list "itemlist") 
) 
(defun additem () 
  (setq crtlst (add_item crtlst (atoi (get_tile "itemlist")) (get_tile "item"))) 
  (writefn crtlst) 
  (updlst "itemlist" crtlst) 
  (set_tile "itemlist" "0") 
  (do_list "itemlist") 
) 
(defun delitem () 
  (setq crtlst (del_item crtlst (atoi (get_tile "itemlist")))) 
  (writefn crtlst) 
  (updlst "itemlist" crtlst) 
  (set_tile "itemlist" "0") 
  (do_list "itemlist") 
) 
(defun upitem (/ n textstr0 val) 
  (if (> (setq n (atoi (get_tile "itemlist"))) 0) 
    (progn 
      (setq crtlst (swapfwrd crtlst n)) 
      (writefn crtlst) 
      (updlst "itemlist" crtlst) 
      (set_tile "itemlist" (itoa (1- n))) 
      (do_list "itemlist") 
    ) 
  ) 
) 
(defun downitem (/ n) 
  (if (< (setq n (atoi (get_tile "itemlist"))) (1- (length crtlst))) 
    (progn 
      (setq crtlst (swapback crtlst n)) 
      (writefn crtlst) 
      (updlst "itemlist" crtlst) 
      (set_tile "itemlist" (itoa (1+ n))) 
      (do_list "itemlist") 
    ) 
  ) 
) 
(defun upitem0 (/ n) 
  (if (> (setq n (atoi (get_tile "itemlist0"))) 0) 
    (progn 
      (setq crtlst0 (swapfwrd crtlst0 n)) 
      (updlst "itemlist0" crtlst0) 
      (set_tile "itemlist0" (itoa (1- n))) 
      (do_list "itemlist0") 
    ) 
  ) 
) 
(defun downitem0 (/ n val temp) 
  (if (< (setq n (atoi (get_tile "itemlist0"))) (1- (length crtlst0))) 
    (progn 
      (setq crtlst0 (swapback crtlst0 n)) 
      (updlst "itemlist0" crtlst0) 
      (set_tile "itemlist0" (itoa (1+ n))) 
      (do_list "itemlist0") 
    ) 
  ) 
) 
(defun addlist () 
  (setq crtlst0 (delsame (append crtlst0 (list (get_tile "item"))))) 
  (updlst "itemlist0" crtlst0) 
  (set_tile "itemlist0" (itoa (1- (length crtlst0)))) 
  (mode_tile "removelist" 0) 
  (do_list "itemlist0") 
) 
(defun removelist (/ n) 
  (setq n (atoi (get_tile "itemlist0"))) 
  (setq crtlst0 (del_item crtlst0 n)) 
  (updlst "itemlist0" crtlst0) 
  (set_tile "itemlist0" "0") 
  (if (null crtlst0)(mode_tile "removelist" 1)) 
  (do_list "itemlist0") 
) 
(defun tolib (/ ss fn n txt) 
  (setq ss (ssget '((0 . "text"))) do_what nil) 
  (if ss 
    (progn 
      (setq n 0) 
      (repeat (sslength ss) 
        (setq crtlst (append crtlst (list (cdr (assoc 1 (entget (ssname ss n)))))) n (1+ n)) 
      ) 
      (setq crtlst (delsame crtlst)) 
      (writefn crtlst) 
      (updlst "itemlist" crtlst) 
    ) 
  ) 
  (setq crtlst0 nil) 
  (princ) 
) 
(defun c:tcf (/ textstr0 scl DLG_ID index result crd crtlst n crtlst0 kd do_what) 
  (setvar "cmdecho" 0) 
  (command "undo" "be") 
  (setq syserr *error* *error* '(nil (princ))) 
  (setq scl (getvar "dimscale")) 
  (setq crtlst (readfn)) 
  (if (> (setq DLG_ID (load_dialog (findfile "tcf.dcl"))) 0) 
    (while (and (/= result 1) (/= result 0)) 
      (if (= do_what 3) 
        (tolib) 
      ) 
      (if (new_dialog "teclib" DLG_ID) 
        (progn 
          (updlst "itemlist" crtlst) 
          (set_tile "itemlist" "0") 
          (set_tile "item" textstr) 
          (mode_tile "item" 2) 
          (mode_tile "up" 1) 
          (mode_tile "up0" 1) 
          (mode_tile "down0" 1) 
          (if (null crtlst0)(mode_tile "removelist" 1)) 
          (action_tile "itemlist" "(do_list \"itemlist\")") 
          (action_tile "item" "(setq textstr $value)") 
          (action_tile "mdf" "(mdfitem)") 
          (action_tile "add" "(additem)") 
          (action_tile "del" "(delitem)") 
          (action_tile "up" "(upitem)") 
          (action_tile "down" "(downitem)") 
          (action_tile "itemlist0" "(do_list \"itemlist0\")") 
          (action_tile "addlist" "(addlist)") 
          (action_tile "removelist" "(removelist)") 
          (action_tile "up0" "(upitem0)") 
          (action_tile "down0" "(downitem0)") 
          (action_tile "pick" "(setq do_what 3)(done_dialog)") 
          (action_tile "accept" "(setq result 1)(done_dialog)") 
          (action_tile "cancel" "(setq result 0)(done_dialog 0)") 
          (start_dialog) 
        ) 
      ) 
    ) 
  ) 
  (unload_dialog DLG_ID) 
  (if (and (= result 1) (setq crd (getpoint "\n文本位置:"))) 
    (if crtlst0 
      (progn 
        (setq n 0 textstr0 "") 
        (repeat (length crtlst0) 
          (setq textstr0 (strcat textstr0 (itoa (1+ n)) ". " (nth n crtlst0) "\\P")) 
          (setq n (1+ n)) 
        ) 
        (vl-string-right-trim "\\P" textstr0) 
        (setq kd (getcorner crd "\n段落宽:")) 
        (entmake (list '(0 . "MTEXT")'(100 . "AcDbEntity")'(100 . "AcDbMText")(cons 10 crd)(cons 40 (* scl 3.5))(cons 41 (- (car kd)(car crd)))'(71 . 1)'(72 . 5)(cons 1 textstr0)'(8 . "TEXT"))) 
        (entmake (list '(0 . "TEXT")'(10 0.0 0.0 0.0)(cons 40 (* scl 5.0))'(72 . 1)'(73 . 1)(cons 11 (list (/ (+ (car crd)(car kd)) 2.0) (+ (cadr crd)(* 4.0 scl)) 0.0))'(1 . "技术要求")'(8 . "TEXT"))) 
      ) 
      (entmake (list '(0 . "TEXT")(cons 10 crd)(cons 40 (* scl 3.5))(cons 1 textstr)'(8 . "TEXT"))) 
    ) 
  ) 
  (setq *error* syserr) 
  (command "undo" "e") 
  (princ) 
)

Bdj · 发表于 2023-3-10 00:23

本帖最后由 Bdj 于 2023-3-10 00:24 编辑

这个配置文件里面的内容像这样的是怎么回事？又可以解答的吗？

Michael527 · 发表于 2017-8-7 22:27

还是希望技术要求库的内容能分类，要不然找起来太麻烦了

yang198910204 · 发表于 2012-2-21 22:43

哇
非常不错哦
谢谢了

yang198910204 · 发表于 2012-2-21 22:45

我还是沙发呢！！
荣幸！！

cabinsummer · 发表于 2012-2-21 23:17

前面几个对表进行操作的函数可以做成通用函数，分别是：
delsame 删除表中相同的项
fwrdlist 元素之前所有元素的列表
backlist 元素之后所有元素的列表
swapfwrd 表中元素向前交换
swapback 表中元素向后交换
add_item 在表中当前位置添加元素
del_item 删除表中当前元素
mdfylist 修改表中当前元素

669423907 · 发表于 2012-2-21 23:32

虽然用不到，但很支持分享源码！

gdslqs · 发表于 2012-2-21 23:46

风吹到那里，我就跟到那里

langjs · 发表于 2012-2-22 10:34

本帖最后由 langjs 于 2012-2-22 10:35 编辑

我们要风一年前的作品！

qcw911 · 发表于 2012-2-22 10:39

感谢版主，跟“风”开始啦~

ALXY · 发表于 2012-2-22 10:58

风大侠的程序非常不错，不过不知最后生成的文字能否换成单行文字？谢谢

ALXY · 发表于 2012-2-22 10:58

风大侠的程序非常不错，不过不知最后生成的文字能否换成单行文字？谢谢

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

[【风之影】] [源码]智能技术要求库

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

相关帖子

本帖子中包含更多资源

点评