求一个一一键插入D盘的所有dwg块的lsp

yz1223

求一个一一键插入D盘的所有dwg块的lsp

杨张张

1. [code="lisp]
   
2. (defun c:mlpt (/ distx disty ent file files maxpoint minpoint path pmax
   
3.           pmin pt1 pt2 sca
   
4.        )
   
5. 
   
6. (command ".UNDO" "BE")
   
7.   (setq sca (getvar "dimscale"))
   
8.   (setq cmd (getvar "cmdecho"))
   
9.   (setq oldos (getvar "OSMODE"))
   
10.   (setvar "cmdecho" 0)
    
11.   (setvar "OSMODE" 0)
    
12.    (getstring "\n本程序将合并指定目录内的所有文件，执行速度较慢，请耐心等待。回车继续...")
    
13.   (setq pt2 (getpoint "\n请选择插入点:"))
    
14.   (setq path (browseforfolder "请选择要合并图纸的目录"))
    
15.   (if (/= path nil)
    
16.     (progn
    
17.       (if (/= (substr path (strlen path) 1) "\")
    
18.   (setq path (strcat path "\"))
    
19.       )
    
20.       (setq files (vl-directory-files path "*.dwg" 0))
    
21.       (while files
    
22.   (setq file (strcat path (car files)));;;  (princ file)
    
23. ;;;  (princ "\n")
    
24.   (command "-INSERT" file pt2 1 1 0)
    
25.   (setq ent (entlast));;;  (princ ent)
    
26.   (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
    
27.   (setq pmax (vlax-safearray->list maxpoint)
    
28.         pmin (vlax-safearray->list minpoint)
    
29.   )
    
30.   (setq distx (- (car pmax) (car pmin)))
    
31.   (setq disty (- (cadr pmax) (cadr pmin)))
    
32.   (setq pt1 (list (car pmax) (cadr pmin)))
    
33.   (command "move" ent "" pt1 pt2)
    
34.   (command "EXPLODE" ent "")
    
35.   (setq pt2 (polar pt2 (/ pi 2) (+ disty (* 40 sca))))
    
36.   (setq files (cdr files))
    
37.       )
    
38.     )
    
39.   )
    
40.   (setvar "OSMODE" oldos)
    
41.   (setvar "CMDECHO" cmd)
    
42.   (command ".UNDO" "E")
    
43.   (princ)
    
44. )
    
45. 
    
46. ;;; [功能] 以目录树方式浏览文件夹并返回路径
    
47. ;;; [参数] msg---提示信息
    
48. ;;; [返回] 文件夹路径，如果选择了cancel, 返回nil
    
49. ;;; [测试] (browseforfolder "选择文件保存路径: ")
    
50. (defun browseforfolder (msg / shfolder path catchit)
    
51.   (setq shfolder (vlax-invoke-method (vlax-create-object "Shell.Application")
    
52.          'browseforfolder
    
53.          (vlax-get-property
    
54.        (vlax-get-acad-object)
    
55.        'hwnd
    
56.          ) msg 1
    
57.    )
    
58. catchit (vl-catch-all-apply '(lambda ()
    
59.            (setq shfolder
    
60.           (vlax-get-property shfolder
    
61.         'self
    
62.           )
    
63.           path
    
64.           (vlax-get-property shfolder
    
65.         'path
    
66.           )
    
67.            )
    
68.          )
    
69.   )
    
70.   )
    
71.   (if (vl-catch-all-error-p catchit)
    
72.     nil
    
73.     path
    
74.   )
    
75. )
    

[code="lisp]<br /> (defun c:mlpt (/ distx disty ent file files maxpoint minpoint path pmax<br />           pmin pt1 pt2 sca<br />        )<br /> <br /> (command ".UNDO" "BE")<br />   (setq sca (getvar "dimscale"))<br />   (setq cmd (getvar "cmdecho"))<br />   (setq oldos (getvar "OSMODE"))<br />   (setvar "cmdecho" 0)<br />   (setvar "OSMODE" 0)<br />    (getstring "\n本程序将合并指定目录内的所有文件，执行速度较慢，请耐心等待。回车继续...")<br />   (setq pt2 (getpoint "\n请选择插入点:"))<br />   (setq path (browseforfolder "请选择要合并图纸的目录"))<br />   (if (/= path nil)<br />     (progn<br />       (if (/= (substr path (strlen path) 1) "\")<br />   (setq path (strcat path "\"))<br />       )<br />       (setq files (vl-directory-files path "*.dwg" 0))<br />       (while files<br />   (setq file (strcat path (car files)));;;  (princ file)<br /> ;;;  (princ "\n")<br />   (command "-INSERT" file pt2 1 1 0)<br />   (setq ent (entlast));;;  (princ ent)<br />   (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)<br />   (setq pmax (vlax-safearray->list maxpoint)<br />         pmin (vlax-safearray->list minpoint)<br />   )<br />   (setq distx (- (car pmax) (car pmin)))<br />   (setq disty (- (cadr pmax) (cadr pmin)))<br />   (setq pt1 (list (car pmax) (cadr pmin)))<br />   (command "move" ent "" pt1 pt2)<br />   (command "EXPLODE" ent "")<br />   (setq pt2 (polar pt2 (/ pi 2) (+ disty (* 40 sca))))<br />   (setq files (cdr files))<br />       )<br />     )<br />   )<br />   (setvar "OSMODE" oldos)<br />   (setvar "CMDECHO" cmd)<br />   (command ".UNDO" "E")<br />   (princ)<br /> )<br /> <br /> ;;; [功能] 以目录树方式浏览文件夹并返回路径<br /> ;;; [参数] msg---提示信息<br /> ;;; [返回] 文件夹路径，如果选择了cancel, 返回nil<br /> ;;; [测试] (browseforfolder "选择文件保存路径: ")<br /> (defun browseforfolder (msg / shfolder path catchit)<br />   (setq shfolder (vlax-invoke-method (vlax-create-object "Shell.Application")<br />          'browseforfolder<br />          (vlax-get-property<br />        (vlax-get-acad-object)<br />        'hwnd<br />          ) msg 1<br />    )<br /> catchit (vl-catch-all-apply '(lambda ()<br />            (setq shfolder<br />           (vlax-get-property shfolder<br />         'self<br />           )<br />           path<br />           (vlax-get-property shfolder<br />         'path<br />           )<br />            )<br />          )<br />   )<br />   )<br />   (if (vl-catch-all-error-p catchit)<br />     nil<br />     path<br />   )<br /> )<br />

源码来自网络 在此谢过！[/code]