|
|
Lisp矩阵数据快速写入Excel
(defun $jz>excel$ (xlapp sheet address jz
app-release? visible? lst
/ colwidths rowheights urange
xlbook xlbooks xlcells xlrange
xlsheet xlsheets zimu xlapp-add? WB SHS sh-ns
)
(defun $get-sheet-n$ (xlsheets / ss)
(if xlsheets
(VLAX-FOR SH xlsheets
(set 'ss (cons (VLA-GET-NAME SH) ss))
)
)
(reverse ss)
)
(zx:debug "$jz>excel$ -1")
(IF (AND JZ (APPLY '= (MAPCAR 'LENGTH JZ)))
(PROGN
(if (and
xlapp
(setq xlbooks (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
)
(not (vl-catch-all-error-p xlbooks))
)
()
(progn (setq xlapp ($xlapp-New$ 0 nil nil))
(setq xlapp-add? 't)
(setq xlbooks (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
)
)
)
(zx:debug "$jz>excel$ -2")
(if (and xlapp
(not (vl-catch-all-error-p xlbooks))
(zx:debug "$jz>excel$ -2.1")
(SETQ WB (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
)
(zx:debug "$jz>excel$ -2.11")
(SETQ SHS (vl-catch-all-apply
'vlax-get-property
(list WB 'Sheets)
)
)
(zx:debug "$jz>excel$ -2.12")
(progn (vlax-for item SHS
(if (= (vla-get-name item) sheet)
(setq xlsheet item)
)
)
(if xlsheet
t
nil
)
)
;;; (setq xlsheet
;;; (vl-catch-all-apply
;;; 'vlax-get-property
;;; (list SHS 'Item sheet)
;;; )
;;; )
(zx:debug "$jz>excel$ -2.13")
(not (vl-catch-all-error-p xlsheet))
) ;如果成立，说明sheet名字为 ** 的表单存在了
(progn
(zx:debug "$jz>excel$ -2.3")
(if msxl-clear
()
(print "Excel 缺少 msxl-clear 函数")
)
(vl-catch-all-apply
(FUNCTION (LAMBDA ()
(msxl-clear
(vl-catch-all-apply
'vlax-get-property
(list xlsheet 'UsedRange)
)
)
)
)
)
(zx:debug "$jz>excel$ -2.4")
(SETQ xlbook (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
)
(zx:debug "$jz>excel$ -2.5")
)
(if xlapp-add? ;如果excel对象是新建的
(PROGN(zx:debug "$jz>excel$ -2.6")
(setq xlbook (vl-catch-all-apply
'vlax-invoke-method
(list xlbooks 'Add)
)
))
(progn
(zx:debug "$jz>excel$ -2.7")
(SETQ xlbook (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
)
(zx:debug "$jz>excel$ -2.8")
(if (not xlbook)
(setq xlbook (vl-catch-all-apply
'vlax-invoke-method
(list xlbooks 'Add)
)
)
)
(zx:debug "$jz>excel$ -2.9")
)
)
)
(zx:debug "$jz>excel$ -3")
(and (not (vl-catch-all-error-p xlbook))
(setq xlsheets (vl-catch-all-apply
'vlax-get-property
(list xlbook 'Sheets)
)
)
)
(vlax-for item xlsheets
(setq n (vla-get-name item))
(setq sh-ns(cons n sh-ns))
)
(zx:debug "$jz>excel$ -4")
(if (and (not (vl-catch-all-error-p xlsheets))
sheet
(zx:debug "$jz>excel$ -4.1")
sh-ns
(member sheet sh-ns)
;;; (not
;;; (vl-catch-all-error-p
;;; (vl-catch-all-apply
;;; (FUNCTION (LAMBDA ()
;;; (vlax-get-property xlsheets 'Item sheet)
;;; )
;;; )
;;; )
;;; )
;;; )
(zx:debug "$jz>excel$ -4.2")
)
(PROGN(zx:debug "$jz>excel$ -4.4"))
(progn
(zx:debug "$jz>excel$ -4.5")
(vl-catch-all-apply
'vlax-put-property
(list
(vl-catch-all-apply
'vlax-invoke-method
(list
(vl-catch-all-apply
'vlax-get-property
(list Xlapp "sheets")
)
"Add"
)
)
"name"
sheet
)
)
(zx:debug "$jz>excel$ -4.6")
(and sheet
(vl-catch-all-apply
'vlax-get-property
(list xlsheets 'Item sheet)
)
)
)
)
(zx:debug "$jz>excel$ -5")
(or (and (not (vl-catch-all-error-p xlsheets))
sheet
(setq xlsheet (vl-catch-all-apply
'vlax-get-property
(list xlsheets 'Item sheet)
)
)
)
(and (not (vl-catch-all-error-p xlsheets))
(setq xlsheet (vl-catch-all-apply
'vlax-get-property
(list xlsheets 'Item 1)
)
)
)
)
(zx:debug "$jz>excel$ -6")
(and (not (vl-catch-all-error-p xlsheet))
(setq xlcells (vl-catch-all-apply
'vlax-get-property
(list xlsheet 'Cells)
)
)
)
(zx:debug "$jz>excel$ -7")
(if
(and xlcells
(not (vl-catch-all-error-p xlcells))
)
()
(progn
(alert
"
启动Excel错误，请检查微软的OFFICE的Excel是否正确安装
"
)
(exit)
)
)
(zx:debug "$jz>excel$ -8")
(and jz (car jz)(setq colwidths (length (car jz))))
(and jz (setq rowheights (length jz)))
(if (not address)
(progn
(setq zimu ($26个字母任意组合$ colwidths))
(AND zimu
rowheights
(SETQ address
(strcat "A1:"
(last zimu)
(vl-princ-to-string rowheights)
)
)
)
)
)
(zx:debug "$jz>excel$ -9")
(SETQ
JZ
(MAPCAR (FUNCTION
(LAMBDA (A)
(MAPCAR (FUNCTION (LAMBDA (B)
(IF (= (TYPE B) 'STR)
B
(VL-PRINC-TO-STRING B)
)
)
)
A
)
)
)
JZ
)
)
(zx:debug "$jz>excel$ -10")
(progn
;;; (setq urange (vl-catch-all-apply
;;; 'vlax-get-property
;;; (list xlsheet 'UsedRange)
;;; )
;;; );可用区域
(IF (or msxlp-get-range msxl-get-range)
()
(PRINT "当前excel的vba相关dll调用失败了")
) ;msxlp-get-range;msxl-get-range
(SETQ urange
(vl-catch-all-apply
(function
(lambda () (msxlp-get-range xlapp address))
;msxlp-get-range;msxl-get-range
)
)
) ;单元格对象
(setq xlrange (vl-catch-all-apply
'vlax-get-property
(list urange 'Range address)
)
)
(vl-catch-all-apply
'vlax-put-property
(list xlrange
'NumberFormat
(vlax-make-variant
"@"
8
)
)
)
(vl-catch-all-apply
'vlax-put-property
(list urange 'HorizontalAlignment -4108)
)
;水平对齐方式居中
(vl-catch-all-apply
'vlax-put-property
(list urange "VerticalAlignment" -4108)
)
;垂直水平方式对齐
(setgridlines xlapp urange) ;加边框线
)
(zx:debug "$jz>excel$ -11")
(vlxls-cell-put-value xlapp address JZ) ;数组写入
(IF visible?
(vla-put-visible xlapp :vlax-true)
) ;聚焦显示
(vl-catch-all-apply
(function (lambda () (CAD-excel-ping-pu xlapp)))
)
(zx:debug "$jz>excel$ -12")
(if app-release? ;如果传入了释放excel对象
(mapcar
'(lambda (x)
(vl-catch-all-apply
'(lambda ()
(vlax-release-object x)
)
)
)
(list xlcells xlsheet xlsheets xlbook xlbooks xlapp)
)
)
(zx:debug "$jz>excel$ -13")
)
)
xlapp
) |
|
发表于 2024-6-22 09:46:18
