求帮忙添加板面按键与功能函数链接函数（此前看到一个前辈发的批量操作希望实现功能）
本帖最后由 dami 于 2021-11-6 17:16 编辑(defun LM:GetFiles
(
title default ext
/
*error*
_PopulateListBox
_GetFiles
_BrowseForFolder
_Full->Relative
_str->lst
_UpdateFileList
_UpdateSelected
_UpDir
_FixDir
data dir filename files id openfile result
)
(defun *error* ( msg )
(if (< 0 id) (unload_dialog id))
(if (and filename (findfile filename)) (vl-file-delete filename))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun _PopulateListBox ( key lst )
(start_list key)
(foreach item lst (add_list item))
(end_list)
lst
)
(defun _GetFiles ( dir ext files )
(vl-remove-if
(function (lambda ( file ) (member (strcat dir "\\" file) files)))
(cond
( (cdr (assoc dir data)) )
( (cdar
(setq data
(cons
(cons dir
(append
(vl-sort (vl-remove "." (vl-directory-files dir nil -1)) '<)
(if (member ext '(("") ("*")))
(vl-directory-files dir nil 1)
(vl-sort
(vl-remove-if-not
(function
(lambda ( file / extn )
(and
(setq extn (vl-filename-extension file))
(setq extn (strcase (substr extn 2)))
(vl-some
(function (lambda ( wc ) (wcmatch extn wc)))
ext
)
)
)
)
(vl-directory-files dir nil 1)
)
(function
(lambda ( a b )
(<
(vl-filename-extension a)
(vl-filename-extension b)
)
)
)
)
)
)
)
data
)
)
)
)
)
)
)
(defun _BrowseForFolder ( msg dir flag / err shell fold self path )
(setq err
(vl-catch-all-apply
(function
(lambda ( / acapp hwnd )
(if (setq acapp (vlax-get-acad-object)
shell (vla-getinterfaceobject acapp "Shell.Application")
hwnd(vl-catch-all-apply 'vla-get-hwnd (list acapp))
fold(vlax-invoke-method shell 'BrowseForFolder (if (vl-catch-all-error-p hwnd) 0 hwnd) msg flag dir)
)
(setq self (vlax-get-property fold 'self)
path (vlax-get-property self 'path)
path (vl-string-right-trim "\\" (vl-string-translate "/" "\\" path))
)
)
)
)
)
)
(if self(vlax-release-objectself))
(if fold(vlax-release-objectfold))
(if shell (vlax-release-object shell))
(if (vl-catch-all-error-p err)
(prompt (vl-catch-all-error-message err))
path
)
)
(defun _Full->Relative ( dir path / p q )
(setq dir (vl-string-right-trim "\\" dir))
(cond
( (and
(setq p (vl-string-position 58dir))
(setq q (vl-string-position 58 path))
(not (eq (strcase (substr dir 1 p)) (strcase (substr path 1 q))))
)
path
)
( (and
(setq p (vl-string-position 92dir))
(setq q (vl-string-position 92 path))
(eq (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
)
(_Full->Relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
)
( (and
(setq q (vl-string-position 92 path))
(eq (strcase dir) (strcase (substr path 1 q)))
)
(strcat ".\\" (substr path (+ 2 q)))
)
( (eq "" dir)
path
)
( (setq p (vl-string-position 92 dir))
(_Full->Relative (substr dir (+ 2 p)) (strcat "..\\" path))
)
( (_Full->Relative "" (strcat "..\\" path)))
)
)
(defun _str->lst ( str del / pos )
(if (setq pos (vl-string-search del str))
(cons (substr str 1 pos) (_str->lst (substr str (+ pos 1 (strlen del))) del))
(list str)
)
)
(defun _UpdateFileList ( dir ext files )
(_PopulateListBox "box1" (_GetFiles dir ext files))
)
(defun _UpdateSelected ( dir files )
(_PopulateListBox "box2" (mapcar (function (lambda ( file ) (_Full->Relative dir file))) files))
files
)
(defun _UpDir ( dir )
(substr dir 1 (vl-string-position 92 dir nil t))
)
(defun _FixDir ( dir )
(vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)
(cond
(
(not
(and
(setq filename (vl-filename-mktemp nil nil ".dcl"))
(setq openfile (open filename "w"))
(progn
(foreach line
'(
"listbox : list_box { width = 40; height =20; fixed_width = true; fixed_height = true;"
" alignment = centered; multiple_select = true; }"
"abutton : button { width = 20; height = 1.8; fixed_width = true; fixed_height = true;"
" alignment = centered; }"
""
"getfiles : dialog { key = \"title\"; spacer;"
" : row { alignment = centered;"
" : edit_box { key = \"directory\"; label = \"文件夹:\"; }"
" : button { key = \"browse\"; label = \"浏览\"; fixed_width = true; }"
" }"
" spacer;"
;;//添加命令
" :boxed_radio_row {"
;" label="选择操作内容";
" :radio_button{label=\"批量清理\" ; key = \"ea\" ;}"
" :radio_button{label=\"批量绑定\" ;key = \"eb\" ;}"
" :radio_button{label=\"批量关非打印图层\" ;key = \"ec\" ; }"
" :radio_button{label=\"批量颜色随层\" ;key = \"ed\" ; }"
" }"
" spacer;"
" : row {"
" : column {"
" : listbox { key = \"box1\"; }"
" : abutton { key = \"add\" ; label = \"添加文件\"; }"
" }"
" : column {"
" : listbox { key = \"box2\"; }"
" : abutton { key = \"del\" ; label = \"删除文件\"; }"
" }"
" }"
" spacer; ok_cancel;"
"}"
)
(write-line line openfile)
)
(close openfile)
(< 0 (setq id (load_dialog filename)))
)
(new_dialog "getfiles" id)
)
)
)
( t
(setq ext (_str->lst (strcase ext) ";"))
(set_tile "title" (if (eq "" title) "Select Files" title))
(set_tile "directory"
(setq dir
(_FixDir
(if
(or
(eq "" default)
(null (vl-file-directory-p (_FixDir default)))
)
(getvar 'DWGPREFIX)
default
)
)
)
)
(setq files (_UpdateFileList dir ext nil))
(mode_tile "add" 1)
(mode_tile "del" 1)
(action_tile "browse"
(vl-prin1-to-string
'(if (setq tmp (_BrowseForFolder "" nil 512))
(setq files(_UpdateFileList (set_tile "directory" (setq dir tmp)) ext result)
result (_UpdateSelected dir result)
)
)
)
)
(action_tile "directory"
(vl-prin1-to-string
'(if (= 1 $reason)
(setq files(_UpdateFileList (set_tile "directory" (setq dir (_FixDir $value))) ext result)
result (_UpdateSelected dir result)
)
)
)
)
(action_tile "box1"
(vl-prin1-to-string
'(
(lambda ( / items tmp )
(setq items
(mapcar
(function (lambda ( n ) (nth n files)))
(read (strcat "(" $value ")"))
)
)
(if (= 4 $reason)
(cond
( (equal '("..") items)
(setq files(_UpdateFileList (set_tile "directory" (setq dir (_UpDir dir))) ext result)
result (_UpdateSelected dir result)
)
)
( (and
(null (vl-filename-extension (car items)))
(vl-file-directory-p (setq tmp (strcat dir "\\" (car items))))
)
(setq files(_UpdateFileList (set_tile "directory" (setq dir tmp)) ext result)
result (_UpdateSelected dir result)
)
)
( t
(setq result (_UpdateSelected dir (vl-sort (append result (mapcar '(lambda ( file ) (strcat dir "\\" file)) items)) '<))
files(_UpdateFileList dir ext result)
)
)
)
(if (vl-some (function (lambda ( item ) (vl-filename-extension item))) items)
(mode_tile "add" 0)
)
)
)
)
)
)
(action_tile "box2"
(vl-prin1-to-string
'(
(lambda ( / items )
(setq items
(mapcar
(function (lambda ( n ) (nth n result)))
(read (strcat "(" $value ")"))
)
)
(if (= 4 $reason)
(setq result (_UpdateSelected dir (vl-remove (car items) result))
files(_UpdateFileList dir ext result)
)
(mode_tile "del" 0)
)
)
)
)
)
(action_tile "add"
(vl-prin1-to-string
'(
(lambda ( / items )
(if (setq items
(vl-remove-if-not
(function (lambda ( file ) (vl-filename-extension file)))
(mapcar
(function (lambda ( n ) (nth n files)))
(read (strcat "(" (get_tile "box1") ")"))
)
)
)
(setq result (_UpdateSelected dir (vl-sort (append result (mapcar '(lambda ( file ) (strcat dir "\\" file)) items)) '<))
files(_UpdateFileList dir ext result)
)
)
(mode_tile "add" 1)
(mode_tile "del" 1)
)
)
)
)
(action_tile "del"
(vl-prin1-to-string
'(
(lambda ( / items )
(if
(setq items
(mapcar
(function (lambda ( n ) (nth n result)))
(read (strcat "(" (get_tile "box2") ")"))
)
)
(setq result (_UpdateSelected dir (vl-remove-if (function (lambda ( file ) (member file items))) result))
files(_UpdateFileList dir ext result)
)
)
(mode_tile "add" 1)
(mode_tile "del" 1)
)
)
)
)
(if (zerop (start_dialog))
(setq result nil)
)
)
)
(if (< 0 id)
(unload_dialog id)
)
(if (and filename (findfile filename))
(vl-file-delete filename)
)
result
)
;; 作者：秋枫，参考了灯火的VBA程序
;; 用法：(qf_getFolder message)
;; 例子：(qf_getFolder "选择文件夹:")
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil
(defun getFolder (message / WinShell shFolder path catchit)
(vl-load-com)
(setq winshell (vlax-create-object "Shell.Application"))
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 message 1))
(setq
catchit (vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (vlax-get-property shFolder 'path))
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path
)
)
;;;以下程序为批量绑定的主程序
(defun c:1698 ( )
(setvar "cmdecho" 0)
(vl-load-com)
(setq sfiles
(LM:GetFiles
"选择处理的文件 批量清理 "
(getvar "dwgprefix")
"dwg"
)
)
(dcl_1698)
(setvar "cmdecho" 1)
(prin1)
)
(defun dcl_1698 ( )
;(SETQ CHULI "ea206")
;(set_tile CHULI "1")
;(SETQ NAME (GET_ATTR CHULI "LABEL"))
(setq chuli1 (atof (get_tile "ea"))
chuli2 (atof (get_tile "eb"))
chuli3 (atof (get_tile "ec"))
chuli4 (atof (get_tile "ed"))
)
(if (not chuli1)(caozuo1));
(if (not chuli2)(caozuo2));
(if (not chuli3)(caozuo3));
(if (not chuli4)(caozuo4));
;(action_tile "ea" "(caozuo1)")
;(action_tile "eb" "(caozuo2)")
;(action_tile "ec" "(caozuo3)")
;(action_tile "ed" "(caozuo4)")
(princ)
)
(defun caozuo1()
(setq targetdir (getFolder "选择文件夹，以便保存绑定后的文件"))
(setq scrfile (open "c:/bind.scr" "w"))
(foreach dwgfile sfiles
(write-line (strcat "open \"" dwgfile "\"") scrfile)
(write-line "_.purge all * n" scrfile)
(write-line "zoom e" scrfile)
(write-line "zoom e" scrfile)
(write-line "saveas" scrfile)
(write-line "2010" scrfile)
(setq sfdir (strcat targetdir"\\" (vl-filename-basedwgfile)))
(write-line(strcat "\"" sfdir "\"" ) scrfile)
(write-line(strcat "(if (findfile \"" sfdir "\") (command \"yes\"))") scrfile)
(write-line "close" scrfile)
)
(close scrfile)
(command "script" "c:/bind.scr")
)
(defun caozuo2()
(setq scrfile (open "c:/plql.scr" "w"))
(foreach dwgfile sfiles
(write-line (strcat "open \"" dwgfile "\"") scrfile)
(write-line "_.purge all * n" scrfile)
(write-line "ggppa" scrfile)
(write-line "zoom e" scrfile)
(write-line "qsave" scrfile)
(write-line "close" scrfile)
)
(close scrfile)
(command "script" "c:/plql.scr")
)
(defun caozuo3()
(setq scrfile (open "c:/ggtt.scr" "w"))
(foreach dwgfile sfiles
(write-line (strcat "open \"" dwgfile "\"") scrfile)
(write-line "_.purge all * n" scrfile)
(write-line "ggtt" scrfile)
(write-line "zoom e" scrfile)
(write-line "qsave" scrfile)
(write-line "close" scrfile)
)
(close scrfile)
(command "script" "c:/ggtt.scr")
)
(defun caozuo4()
(setq scrfile (open "c:/plsc.scr" "w"))
(foreach dwgfile sfiles
(write-line (strcat "open \"" dwgfile "\"") scrfile)
(write-line "_.purge all * n" scrfile)
(write-line "cb11" scrfile)
(write-line "zoom e" scrfile)
(write-line "qsave" scrfile)
(write-line "close" scrfile)
)
(close scrfile)
(command "script" "c:/plsc.scr")
)
已经将该功能实现
页:
[1]