lisp将jpg放入sld图库_图库 - AutoLISP/Visual LISP 编程技术 - CAD论坛 - 明经CAD社区 - Powered by Discuz!...
;20150401 增加删除确认.
(defun c:tk ()
;(setvar "cmdecho" 0)
(vl-load-com)
(setq path "D:\\百度云同步盘\\CAD\\程序\\研究衍伸\\自制幻灯片\\")
;可不用设置搜索目录
(setq keylst '("a1" "a2" "a3" "a4" "a5" "a6" "a7" "a8" "a9"))
;将image key 设置成表
(if nn
(setq nn nn)
(setq nn "0")
)
(if mm
(setq mm mm)
(setq mm "0")
)
(if curpage
(setq curpage curpage)
(setq curpage 0)
)
(if xsc
(setq xsc xsc)
(setq xsc "1")
)
(if sc_uniform
(setq sc_uniform sc_uniform)
(setq sc_uniform "0")
)
(setq poplst (get_poplst "tk.ini"))
(setq boxlst (get_boxlst "tk.ini"))
(dcl_tk)
)
(defun dcl_tk ()
(setq dcl_id (load_dialog (strcat path "tk.dcl")))
(new_dialog "tk" dcl_id)
(show_list "poptk" poplst)
(set_tile "poptk" nn) ;设定初始值
(setq subitem (nth (atoi nn) boxlst))
(setq sub_boxlst (sub_readfile subitem)) ;取得分列表
(setq sub_showboxlst (get_del_address_newlist sub_boxlst))
;删除地址的新字符串
(setq len (length sub_showboxlst))
(show_listnum len)
(show_list "tk_list" sub_showboxlst)
(set_tile "tk_list" "0")
(show_tk_sld keylst sub_boxlst)
(setq laylst (layer_get_all)) ;得到所有图层
(show_list "poplay" laylst) ;laylst
(set_tile "poplay" mm) ;设定lay初始值
(set_tile "xsc" xsc)
(set_tile "sc_uniform" sc_uniform)
(if (= sc_uniform "1")
(progn
(setq sc (get_tile "xsc"))
(set_tile "ysc" sc)
(set_tile "zsc" sc)
(mode_tile "ysc" 1)
(mode_tile "zsc" 1)
)
(progn
(mode_tile "ysc" 0)
(mode_tile "zsc" 0)
(set_tile "ysc" "1") ;可修改为统一之前的值，像cad那样
(set_tile "zsc" "1")
)
)
(set_tile "tkang" "0")
(set_tile "extra" "pannel\n修改显示顺序在ini文中修改\n插入的图块不对中")
(action_tile "item" "(sub_openfile \"tk.ini\")")
(action_tile "sub_item" "(sub_openfile subitem)")
(action_tile "sub_dir" "(open_sub_dir subitem )")
(action_tile "poptk" "(setcurpage) (setq nn $value) (setq subitem (nth (atoi $value) boxlst))(setq sub_boxlst (sub_readfile subitem)) (setq sub_showboxlst (get_del_address_newlist sub_boxlst)) (show_list \"tk_list\" sub_showboxlst)(set_tile_tk_list)(show_tk_sld keylst sub_boxlst)(setq len (length sub_showboxlst)) (show_listnum len)(mod_tile_sld)"
)
(action_tile "tk_up" "(tkup keylst sub_boxlst)")
(action_tile "tk_down" "(tkdown keylst sub_boxlst)")
(action_tile "tk_list" "(get_tk $value keylst sub_boxlst)")
;显示图像
(action_tile "xsc" "(setq xsc $value)(y_z_sc)")
(action_tile "sc_uniform" "(setq sc_uniform $value)(set_tksc)")
(action_tile "a1" "(setq aa 1)(get_tk_filename aa sub_boxlst)") ;图像指定lst
(action_tile "a2" "(setq aa 2)(get_tk_filename aa sub_boxlst)")
(action_tile "a3" "(setq aa 3)(get_tk_filename aa sub_boxlst)")
(action_tile "a4" "(setq aa 4)(get_tk_filename aa sub_boxlst)")
(action_tile "a5" "(setq aa 5)(get_tk_filename aa sub_boxlst)")
(action_tile "a6" "(setq aa 6)(get_tk_filename aa sub_boxlst)")
(action_tile "a7" "(setq aa 7)(get_tk_filename aa sub_boxlst)")
(action_tile "a8" "(setq aa 8)(get_tk_filename aa sub_boxlst )")
(action_tile "a9" "(setq aa 9)(get_tk_filename aa sub_boxlst)")
(mode_tile "a1" 4)
(action_tile "tk_add" "(done_dialog 1)")
(action_tile "tk_del" "(del_tk)")
(action_tile "poplay" "(setq mm $value)")
(action_tile "tk_insert" "(ok_diatk) (done_dialog 2)")
(setq dd (start_dialog))
(cond
((= dd 1) (add_tk) (dcl_tk))
((= dd 2) (insert_tk))
)
)
(defun ok_diatk ()
(setq inserttk (strcat path (nth (atoi (get_tile "tk_list")) sub_boxlst) ".dwg" ))
(setq lay (nth (atoi mm) laylst))
(setq ang (get_tile "tkang"))
(setq xsc (get_tile "xsc"))
(setq ysc (get_tile "ysc"))
(setq bom (get_tile "bom"))
)
(defun insert_tk ()
;(setvar "clayer" lay)
(command "insert" inserttk "x" (atof xsc) "y" (atof ysc) "r" ang pause)
;;;;拖拽插入 ,x,y ,r分别代表x比例,y比例，循环角度. 0代表
(setq en1 (entlast))
(if (= bom "1")
(command "explode" en1 "")
)
)
;删除 c:\ 目录中的文件 newauto.bat：
;_$ (vl-file-delete "c:/newauto.bat")
(defun del_tk ()
(if (/= sub_boxlst nil)
(progn
(setq del_n (atoi (get_tile "tk_list")))
(setq deldata (nth del_n sub_boxlst))
(setq filedir (vl-filename-directory subitem))
(setq deldatadwg (strcat path deldata ".dwg"))
(setq deldatasld (strcat path deldata ".sld"))
;确认是否删除，并标出文件名，
(del_tk_ifnot)
(if (= dd1 3)
(progn (vl-file-delete deldatadwg) ;删除文件
(vl-file-delete deldatasld)
(setq sub_boxlst (vl-remove deldata sub_boxlst))
(sub_writedata subitem sub_boxlst)
)
)
(setq sub_boxlst (sub_readfile subitem)) ;取得分列表
(setq sub_showboxlst (get_del_address_newlist sub_boxlst))
;删除地址的新字符串
(show_list "tk_list" sub_showboxlst)
(show_tk_sld keylst sub_boxlst)
;更新页码;
;程序代码
(setq len (length sub_showboxlst))
(show_listnum len)
)
(progn
(alert "list无")
)
)
)
;删除图块确认
(defun del_tk_ifnot()
(setq dcl_id (load_dialog (strcat path "tk.dcl")))
(new_dialog "del_con" dcl_id)
(set_tile "del_tk_name" (vl-filename-base deldatadwg) )
(action_tile "accept" "(done_dialog 3)")
(action_tile "cancel" "(done_dialog 4)")
(setq dd1 (start_dialog))
)
;增加图块
(defun add_tk ()
(setq filedir (vl-filename-directory subitem))
;返回文件名前面的路径
(setq p1 (getpoint "\n-->请选左下角点:"))
(setq p2 (getcorner p1 "\n-->请选右上角点:"))
;亮显选择实体
;*************代码**********
;
;
;
;
;
;*****************
(while (member (setq name (getstring "请输入图块名")) sub_showboxlst )
(alert "重名") ;重名重输
(dcl_tk)
)
(setq dwgname (strcat path filedir "\\" name)) ;包含地址.
(setq name_subitem (strcat filedir "\\" name))
(setq ss1 (ssget "w" p1 p2))
(command "zoom" p1 p2)
(command "ucs" "d" "uc") ;删除名为uc的ucs
(command "ucs" "s" "uc" "ucs" "") ; save名为uc的 ucs
;(command "ucs" "o" (polar p1 (angle p1 p2) (* 0.5 (distance p1 p2)))) ;重新定义原点中心
(setq sld (strcat dwgname ".sld"))
;(setq pt (getpoint "\n选择插入点坐标:"))
; (command "-WBLOCK" dwgname "" pt ss "" "oops")
(command "wblock" dwgname "" '(0 0 ) ss1 "" "oops")
;name中含地址.oops用途:恢复删除的对象?
;(command "u")
(command "mslide" sld) ;创建幻灯文件
(command "zoom" "p") ;放大上一个文件
(command "ucs" "r" "uc") ;恢复名为uc的ucs
;加入name到list中
(setq sub_boxlst (append sub_boxlst (list name_subitem)))
;写入文件
(sub_writedata subitem sub_boxlst)
)
(defun set_tile_tk_list ()
(set_tile "tk_list" "0")
)
(defun mod_tile_sld ()
(mode_tile "a1" 4)
)
;比例设置
(defun set_tksc ()
(if (= sc_uniform "1")
(progn
(setq sc (get_tile "xsc"))
(set_tile "ysc" sc)
(set_tile "zsc" sc)
(mode_tile "ysc" 1)
(mode_tile "zsc" 1)
)
(progn
(mode_tile "ysc" 0)
(mode_tile "zsc" 0)
)
)
)
;当统一比例时，实时变化
;实际上没达到cad那样的功能
(defun y_z_sc ()
(if (= (get_tile "sc_all") "1")
(progn
(set_tile "ysc" xsc)
(set_tile "zsc" xsc)
(mode_tile "ysc" 1)
(mode_tile "zsc" 1)
)
)
)
;表显示
(defun show_list (key newlist)
(start_list key) ;
(mapcar 'add_list newlist)
(end_list)
)
;显示单个image
(defun show_sld (key sld)
(setq x (dimx_tile key)) ;取得图像的右下角x坐标
(setq y (dimy_tile key)) ;取得图像的右下角y坐标
(start_image key) ;开始处理图像对象
(fill_image 0 0 x y 254) ;先以背景颜色填满图像x1,y1,width,height,color
(slide_image 0 0 x y sld) ;展示幻灯片 x1,y1,width,height,sldname
(end_image)
)
;初始化页码
(defun setcurpage ()
(setq curpage 0)
)
;;设置目录并打开目录文件
;;;可用(vl-filename-directory "c:\\acadwin\\acad.exe"),返回"c:\\acadwin"
(defun open_sub_dir (subitem)
(setq filedir (vl-filename-directory subitem))
(setq filedir (strcat path filedir))
(startapp "EXPLORER.EXE" filedir)
)
;显示子项目长度
(defun show_listnum (length)
(set_tile "list_num" (itoa length))
)
;把列表中的内容定向image key
(defun show_tk_sld (keylst lst)
(setq sldlst (mapcar '(lambda (x) (strcat path x)) lst))
; list所有字符串加前缀,sld未在搜索路径下必须加上地址,不必加后缀
(setq i (* curpage 9) j 0)
(setq num (* curpage 9))
(setq allnum (length sldlst)) ;所有图像sld长度
(mode_tile "tk_down" (if (>= (+ (* curpage 9) 9) allnum) 1 0 ))
(mode_tile "tk_up" (if (= curpage 0) 1 0 ))
(while (< j 9)
(setq key (nth j keylst))
(setq x (dimx_tile key)) ;取得图像的右下角x坐标
(setq y (dimy_tile key)) ;取得图像的右下角y坐标
(start_image key)
(fill_image 0 0 x y -16) ;-16:当前对话框的前景色
(if (< i allnum) ;如果无值，不显示
(progn
(setq sld (nth i sldlst))
(slide_image 0 0 x y sld) ;显示图像
)
)
(end_image)
(setq i (1+ i)
j (1+ j)
)
)
)
;;上一页
(defun tkup (keylst sldlst)
(setq curpage (- curpage 1))
(show_tk_sld keylst sldlst)
)
;下一页
(defun tkdown (keylst sldlst)
(setq curpage (+ curpage 1)) ;取得页码
(show_tk_sld keylst sldlst)
)
;显示指定sld并指向list
(defun get_tk (vvs keylst lst)
(setq n (atoi vvs))
(setq curpage (fix (/ n 9))) ;截去实数小数部分,求得页码.
(show_tk_sld keylst lst)
(setq num (rem n 9)) ;求余数
(setq key (nth num keylst))
;(setq sldlst (mapcar '(lambda (x) (strcat path x )) lst) )
;(setq sld (nth n sldlst))
;(show_sld key sld)
(mode_tile key 4)
)
;取得文件名
(defun get_tk_filename (aa lst)
(setq bb (+ (* curpage 9) (- aa 1))) ;list位置
(show_tk_sld keylst lst)
(set_tile "tk_list" (itoa bb))
(setq key (strcat "a" (itoa aa))) ;，由于show_tk_sld中有key值为a9,需重新计算key
;(setq sldlst (mapcar '(lambda (x) (strcat path x )) lst) )
;(if (setq sld (nth bb sldlst))
;(show_sld key sld)
(mode_tile key 4)
)
;将表指定给tk_list并显示
(defun show_sub_box_lst (lst)
(setq key "tk_list")
(show_list key lst)
)
;;;[功能]字符串取得特定字符"\\"之后的字符串 ,去除空字符串 ,允许lst为空值
;;;可用(vl-filename-base "c:\\acadwin\\acad.exe"),返回"acad"
(defun get_del_address_newlist (lst)
(setq lst (vl-remove "" lst)) ;这里重要，,去除空值
(setq lst (mapcar '(lambda (x) (vl-filename-base x)) lst))
)
(defun sub_readfile (file) ;TEMP词库
(setq pathfile (strcat path file))
(setq file (findfile pathfile))
(if file
(progn
(setq fn (open file "r"))
(setq tmplst nil)
(while (setq x (read-line fn))
(if (/= (substr x 1 1) ";")
(setq tmplst (append tmplst (list x)))
)
) ;while
)
nil
) ;progn
(close fn)
tmplst
(setq tempst (vl-remove "" tmplst))
)
;取得第一行信息
(defun get_poplst (file)
(setq alllst (sub_readfile file))
(setq len (length alllst))
(setq i 0
poplst nil
)
(setq str (nth i alllst))
(while (and str (< i len))
(setq poplst (cons str poplst))
(setq i (+ i 2))
(setq str (nth i alllst))
)
(setq poplst (reverse poplst))
(setq poplst (vl-remove "" poplst));删除空白元素
poplst
)
;取得第二行信息
(defun get_boxlst (file)
(setq alllst (sub_readfile file))
(setq len (length alllst))
(setq i 1
boxlst nil
)
(setq str (nth i alllst))
(while (and str (< i len))
(setq boxlst (cons str boxlst))
(setq i (+ i 2))
(setq str (nth i alllst))
)
(setq boxlst (reverse boxlst))
(setq boxlst (vl-remove "" boxlst))
boxlst
)
;;;打开文件
(defun sub_openfile (files)
(setq path_txt (strcat path files))
(if (findfile path_txt)
(startapp "notepad.exe" path_txt)
(alert (strcat "无" files "文件"))
)
)
;将字符串写入文本文件
(defun sub_writedata (pathfile lst)
(setq ffn (open (strcat path pathfile) "w"))
;;写模式.
(foreach x lst (write-line x ffn))
(close ffn)
;;关闭文件
)
;返回所有图层
(defun layer_get_all ()
(setq layer nil)
(setq lay (tblnext "LAYER" T)) ;重头开始找
(while (/= lay nil)
;(setq layer (append layer (list (cdr (assoc 2 lay)))))
(setq layer (cons (cdr (assoc 2 lay)) layer))
(setq lay (tblnext "LAYER"))
)
(setq layer (acad_strlsort layer))
layer ;返回值
)