关于图库系统的后续改写
本帖最后由 尘缘一生 于 2022-10-2 11:12 编辑请移步帖子：
http://bbs.mjtd.com/thread-186146-1-1.html
[*];新建图块--------
[*](defun c:sl-lib-blockadd (/ dcl_id dlg ss pt sl-blkpath ps p1 p2 ss1 ss2 ss3)
[*] (setq dcl_id (load_dialog (sl_lib_tkmm)))
[*] (new_dialog "tukuairen" dcl_id)
[*] (action_tile "edt_name" "(setq $sl_newname $value)")
[*] (set_tile "txt_name" (slmsg "新建图块" "新建圖塊" "New Block"))
[*] (set_tile "edt_name" (slmsg "新块名" "新塊名" "New Block Name"))
[*] (action_tile "accept" "(done_dialog 1)")
[*] (setq dlg (start_dialog))
[*] (if (= dlg 1)
[*] (progn
[*] (setq $sl_newname (vl-string-translate "|\\/?*:\"<>" "_________" $sl_newname))
[*] (setq sl-blkpath (strcat $sl_libpath (cdr $sl_libcurrent) "\\" $sl_newname))
[*] (prompt (slmsg "\n 选择图形:" "\n選擇圖形:" "\n Select Graph:"))
[*] (setq ps (sl_pm2pt) p1 (car ps)p2 (cadr ps))
[*] (setq ss1 (ssget "x"))
[*] (setq ss2 (ssget))
[*] (command "._Select" ss1 "_Remove" ss2 "")
[*] (setq ss3 (ssget "_p"))
[*] (sl:ycwt ss3) ;;隐藏其余部分
[*] (command "ZOOM" "E")
[*] (setq pt (caddr (sl_pm2pt)))
[*] (command "COPY" ss2 "" pt pt)
[*] (command "-wblock" (strcat sl-blkpath ".dwg") "" pt ss2 "")
[*] (command "._mslide" (strcat sl-blkpath ".sld"))
[*] (sl:xswt) ;;恢复隐藏
[*] (command "ZOOM" "W" p1 p2)
[*] (sl-lib-main1)
[*] )
[*] )
[*])
[*];;替换当前，刷新幻灯---------------
[*](defun sl-lib-slidereplace (/ ss pt)
[*] (slexit
[*] (slmsg
[*] "当前图，作其整图同名幻灯，存与其目录下！"
[*] "當前圖，作其整圖同名幻燈，存與其目錄下！"
[*] "The current image is a slide with the same name as the whole image and stored in its directory！"
[*] )
[*] (slmsg
[*] "是否继续？请选择是否继续!"
[*] "是否繼續？請選擇是否繼續!"
[*] "Do you want to continue? Please select whether to continue!"
[*] )
[*] )
[*] (setq $sl_newname (cadr (assoc $sl_libindex $sl_blocklist)))
[*] (setq $sl_newname (strcat $sl_libpath (cdr $sl_libcurrent) "\\" $sl_newname))
[*] (vl-file-delete (strcat $sl_newname ".dwg"));删除原有dwg文件
[*] (vl-file-delete (strcat $sl_newname ".sld"));删除原有dwg文件
[*] (command "ZOOM" "E")
[*] (setq ss (ssget "x"))
[*] (setq pt (caddr (sl_pm2pt)))
[*] (command "COPY" ss "" pt pt)
[*] (command "-wblock" (strcat $sl_newname ".dwg") "" pt ss "")
[*] (command "._mslide" (strcat $sl_newname ".sld"))
[*] (command "ZOOM" "E")
[*] (sl-lib-main1)
[*])
[*];;选择替换----------------------
[*](defun sl-lib-blockreplace (/ ss1 ss2 ss3 pt ps p1 p2)
[*] (setq $sl_newname (cadr (assoc $sl_libindex $sl_blocklist)))
[*] (setq $sl_newname (strcat $sl_libpath (cdr $sl_libcurrent) "\\" $sl_newname))
[*] (vl-file-delete (strcat $sl_newname ".dwg"))
[*] (vl-file-delete (strcat $sl_newname ".sld"))
[*] (prompt (slmsg "\n 选择图形:" "\n選擇圖形:" "\n Select Graph:"))
[*] (setq ps (sl_pm2pt) p1 (car ps) p2 (cadr ps))
[*] (setq ss1 (ssget "x"))
[*] (setq ss2 (ssget))
[*] (command "._Select" ss1 "_Remove" ss2 "")
[*] (setq ss3 (ssget "_p"))
[*] (sl:ycwt ss3) ;;隐藏其余部分
[*] (command "ZOOM" "E")
[*] (setq pt (caddr (sl_pm2pt)))
[*] (command "COPY" ss2 "" pt pt)
[*] (command "-wblock" (strcat $sl_newname ".dwg") "" pt ss2 "")
[*] (command "._mslide" (strcat $sl_newname ".sld"))
[*] (sl:xswt) ;;恢复隐藏
[*] (command "ZOOM" "W" p1 p2)
[*] (sl-lib-main1)
[*])
链接：https://pan.baidu.com/s/1UCJtFdLy2DlFcLesMeYyqg
提取码：gy87
建议大佬整个独立运行的
建议大佬整个独立运行的 你能帮忙出一个单独图库完整的程序吗？你这个看起来非常好用
这个要钱的，是在推销啊。
页:
[1]