[源码]智能技术要求库
本帖最后由 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;
}
}
(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:24 编辑
这个配置文件里面的内容像这样的是怎么回事？又可以解答的吗？
还是希望技术要求库的内容能分类，要不然找起来太麻烦了 哇
非常不错哦
谢谢了 我还是沙发呢！！
荣幸！！ 前面几个对表进行操作的函数可以做成通用函数，分别是：
delsame删除表中相同的项
fwrdlist 元素之前所有元素的列表
backlist 元素之后所有元素的列表
swapfwrd 表中元素向前交换
swapback 表中元素向后交换
add_item 在表中当前位置添加元素
del_item 删除表中当前元素
mdfylist 修改表中当前元素 虽然用不到，但很支持分享源码！ 风吹到那里，我就跟到那里 本帖最后由 langjs 于 2012-2-22 10:35 编辑
我们要风一年前的作品！ 感谢版主，跟“风”开始啦~ 风大侠的程序非常不错，不过不知最后生成的文字能否换成单行文字？谢谢 风大侠的程序非常不错，不过不知最后生成的文字能否换成单行文字？谢谢