Excel工作薄保存

dcl1214

1. (Defun vlxls-app-saveas
   
2.        (xlapp Filename quit? lst / Rtn save kzm wjm f wb)
   
3.           ;保存工作薄
   
4.   (if (and xlapp
   
5.      (setq wb (vl-catch-all-apply
   
6.           'vlax-get-property
   
7.           (list xlapp 'activeworkbook)
   
8.         )
   
9.      )
   
10.      (not (vl-catch-all-error-p wb))
    
11.       )
    
12.     ()
    
13.     (setq xlapp  (vl-catch-all-apply
    
14.       (function (lambda () ($xlapp-New$ 0 t nil)));$xlapp-New$晓东将首尾美元符号给删除了，自己加上
    
15.     )
    
16.     )
    
17.   )
    
18.   (setq  wb (vl-catch-all-apply
    
19.        'vlax-get-property
    
20.        (list xlapp 'activeworkbook)
    
21.      )
    
22.   )
    
23.   (OR (and Filename
    
24.      (setq kzm (vl-filename-extension Filename))
    
25.      (wcmatch kzm "[,*.xls,*.XLS,]")
    
26.       )          ;扩展名
    
27.       (SETQ KZM ".xls")
    
28.   )
    
29.   (or (and Filename
    
30.      (setq wjm (vl-filename-base Filename))
    
31.      (> (strlen wjm) 0)
    
32.       )
    
33.       (setq wjm "data")
    
34.   )
    
35.   (or (and Filename
    
36.      (setq f (vl-filename-directory Filename))
    
37.      (setq f (vl-string-right-trim "\\" f))
    
38.       )
    
39.       (and (setq f (getvar "dwgprefix"))
    
40.      (setq f (vl-string-right-trim "\\" f))
    
41.       )
    
42.   )
    
43.   (setq Filename (strcat f "\\" wjm kzm))
    
44.   (vl-catch-all-apply
    
45.     'vlax-put-property
    
46.     (LIST xlapp 'DisplayAlerts :vlax-False)
    
47.   )          ;保存的时候不弹出警告的窗口  
    
48.   (setq  save (vl-catch-all-apply
    
49.          (function (lambda ()
    
50.          (vlax-invoke-method
    
51.            wb      "SaveAs"     Filename
    
52.            msxlc-xlNormal         ""
    
53.            ""      :vlax-False  :vlax-False
    
54.            nil
    
55.           )
    
56.        )
    
57.          )
    
58.        )
    
59.   )
    
60.   (if (vl-catch-all-error-p save)
    
61.     (progn (setq save nil)
    
62.      (setq Filename (vl-filename-mktemp Filename))
    
63.      (setq save (vl-catch-all-apply
    
64.       (function (lambda ()
    
65.             (vlax-invoke-method
    
66.               wb     "SaveAs"
    
67.               Filename     msxlc-xlNormal
    
68.               ""     ""
    
69.               :vlax-False  :vlax-False
    
70.               nil
    
71.              )
    
72.           )
    
73.       )
    
74.           )
    
75.      )
    
76.     )
    
77.   )
    
78.   (if quit?
    
79.     (progn
    
80.       (vlax-invoke-method
    
81.   (vlax-get-property xlapp 'activeworkbook)
    
82.   'Close
    
83.       )
    
84.       (vlax-invoke-method xlapp 'Quit)
    
85.     )
    
86.   )
    
87.   (if (vl-catch-all-error-p save)
    
88.     nil
    
89.     (findfile Filename)
    
90.   )
    
91. )

(Defun vlxls-app-saveas<br />        (xlapp Filename quit? lst / Rtn save kzm wjm f wb)<br />           ;保存工作薄<br />   (if (and xlapp<br />      (setq wb (vl-catch-all-apply<br />           'vlax-get-property<br />           (list xlapp 'activeworkbook)<br />         )<br />      )<br />      (not (vl-catch-all-error-p wb))<br />       )<br />     ()<br />     (setq xlapp  (vl-catch-all-apply<br />       (function (lambda () ($xlapp-New$ 0 t nil)));$xlapp-New$晓东将首尾美元符号给删除了，自己加上<br />     )<br />     )<br />   )<br />   (setq  wb (vl-catch-all-apply<br />        'vlax-get-property<br />        (list xlapp 'activeworkbook)<br />      )<br />   )<br />   (OR (and Filename<br />      (setq kzm (vl-filename-extension Filename))<br />      (wcmatch kzm "[,*.xls,*.XLS,]")<br />       )          ;扩展名<br />       (SETQ KZM ".xls")<br />   )<br />   (or (and Filename<br />      (setq wjm (vl-filename-base Filename))<br />      (> (strlen wjm) 0)<br />       )<br />       (setq wjm "data")<br />   )<br />   (or (and Filename<br />      (setq f (vl-filename-directory Filename))<br />      (setq f (vl-string-right-trim "\\" f))<br />       )<br />       (and (setq f (getvar "dwgprefix"))<br />      (setq f (vl-string-right-trim "\\" f))<br />       )<br />   )<br />   (setq Filename (strcat f "\\" wjm kzm))<br />   (vl-catch-all-apply<br />     'vlax-put-property<br />     (LIST xlapp 'DisplayAlerts :vlax-False)<br />   )          ;保存的时候不弹出警告的窗口  <br />   (setq  save (vl-catch-all-apply<br />          (function (lambda ()<br />          (vlax-invoke-method<br />            wb      "SaveAs"     Filename<br />            msxlc-xlNormal         ""<br />            ""      :vlax-False  :vlax-False<br />            nil<br />           )<br />        )<br />          )<br />        )<br />   )<br />   (if (vl-catch-all-error-p save)<br />     (progn (setq save nil)<br />      (setq Filename (vl-filename-mktemp Filename))<br />      (setq save (vl-catch-all-apply<br />       (function (lambda ()<br />             (vlax-invoke-method<br />               wb     "SaveAs"<br />               Filename     msxlc-xlNormal<br />               ""     ""<br />               :vlax-False  :vlax-False<br />               nil<br />              )<br />           )<br />       )<br />           )<br />      )<br />     )<br />   )<br />   (if quit?<br />     (progn<br />       (vlax-invoke-method<br />   (vlax-get-property xlapp 'activeworkbook)<br />   'Close<br />       )<br />       (vlax-invoke-method xlapp 'Quit)<br />     )<br />   )<br />   (if (vl-catch-all-error-p save)<br />     nil<br />     (findfile Filename)<br />   )<br /> )

hh_lj007

感谢分享源码，已收藏。