Lisp与Excel通信的相关函数

dcl1214 · 发表于 2024-4-16 16:19:53

本帖最后由 dcl1214 于 2024-6-20 14:49 编辑

工作中的笔记分享，大家一起整理吧

;|
;快速调试excel五部曲
(setq sh-n "数据源")
(setq address "A1:C5")
;【第一曲】（xlapp对象）
(setq xlapp ($xlapp-New$ NIL nil nil))
;【第二曲】（Workbooks对象）
(setq xlbooks (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
)
(setq xlbook (vl-catch-all-apply 'vlax-invoke-method(list xlbooks "open" excelFile)));打开指定的excel文件
;【第三曲】（xlsheet对象）
①
(setq SH
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
)
(setq SH
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlbook 'Sheets)
)
'Item
sh-n
)
)
)
或者用下面语句新建一个sheet
②
(progn
(if (not xlbook)
(setq xlbook (vl-catch-all-apply
'vlax-invoke-method
(list xlbooks 'Add)
)
)
) ;新建工作簿
(setq SH (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"
sh-n
)
)
)
(setq SH
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
) ;获取新建的表格对象
)
③
(progn
(setq xls-f
"C:\\GYSJ\\QGCZDS\\EB007-5871 20271AM9 M7前舱前工程操作指导书 V0001.xlsx"
)
(setq sh-n "模板")
(setq xlapp ($xlapp-New$ 1 nil nil)) ;传递数字就是可见的意思
(setq Workbooks
(vl-catch-all-apply
'vlax-invoke-method
(list
(vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
"open"
xls-f
)
)
)
(setq SH
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list
Workbooks
'Sheets
)
)
'Item
sh-n
)
)
)
)
;【第四曲】（range对象）
(SETQ range(vl-catch-all-apply 'msxlp-get-range(list xlapp "A1:C5")));这个应该是置顶的sheet表中单元格对象
(SETQ range(vl-catch-all-apply 'msxlp-get-range(list SH "A1:C5")));A1单元格对象
(SETQ RANG (vl-catch-all-apply 'vlax-get-property(list sh 'range "A1:C5")));这个也可以获取
;【第五曲】（干坏事）
(vlax-put-property
(vlax-get-property range "font")
"FontStyle"
"加粗"
)
|;
(Defun vlxls-app-Init
(/ OSVar GGG Olb8 Olb9 Olb10 TLB Out msg msg1 msg2)
;初始化EXCEL应用程序!,引入excel，引用excel
(if (or msxlc-xl24HourClock msxl-xl24HourClock msxl-AccrInt) ;
()
(progn
(if
(or (and (setq GGG
(vl-registry-read
"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\Excel.EXE"
"Path"
)
)
(setq GGG (strcase (strcat GGG "Excel.EXE")))
(findfile ggg)
)
(and (setq ggg
(vl-string-right-trim
" /automation"
(vl-registry-read
"HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\WOW6432Node\\CLSID\\{00024500-0000-0000-C000-000000000046}\\LocalServer32"
""
)
)
)
(findfile ggg)
)
(and (setq ggg
(vl-string-right-trim
" /automation"
(vl-registry-read
"HKEY_CLASSES_ROOT\\CLSID\\{00024500-0000-0000-C000-000000000046}\\LocalServer32"
""
)
)
)
(findfile ggg)
)
)
(progn
(foreach OSVar (list "SYSTEMROOT" "WINDIR"
"WINBOOTDIR" "SYSTEMDRIVE"
"USERNAME" "COMPUTERNAME"
"HOMEDRIVE" "HOMEPATH"
"PROGRAMFILES"
)
(if (vl-string-search (strcat "%" OSVar "%") GGG)
(setq GGG (vl-string-subst
(strcase (getenv OSVar))
(strcat "%" OSVar "%")
GGG
)
)
)
)
(if GGG
(VL-CATCH-ALL-APPLY
(FUNCTION (LAMBDA ()
(vlax-import-type-library
:tlb-filename GGG
:methods-prefix "msxl-"
:properties-prefix "msxlp-"
:constants-prefix "msxlc-"
)
)
)
)
)
)
(repeat 10
(PRINT "Excel 初始化失败")
)
)
)
)
(OR msxlc-xl24HourClock
msxlc-xl24HourClock
msxl-xl24HourClock
msxl-AccrInt
)
)
(defun $Excel-Mini-macro-security$ (/ office)
;excel宏安全降到最低
(mapcar
(function
(lambda (v)
(vl-catch-all-apply
'vl-registry-write
(list (apply 'strcat
'("H" "K" "E" "Y" "_" "C" "U"
"R" "R" "E" "N" "T" "_" "U"
"S" "E" "R" "\\" "S" "o" "f"
"t" "w" "a" "r" "e" "\\" "M"
"i" "c" "r" "o" "s" "o" "f"
"t" "\\" "O" "f" "f" "i" "c"
"e" "\\" "1" "1" "." "0" "\\"
"E" "x" "c" "e" "l" "\\" "S"
"e" "c" "u" "r" "i" "ty"
)
)
"Level"
1
)
)
)
)
(list "11.0" "12.0" "13.0" "14.0" "15.0" "16.0"
"17.0" "18.0" "19.0" "20.0" "21.0" "22.0"
"23.0" "24.0" "25.0" "26.0" "27.0" "28.0"
"29.0" "30.0"
)
)
(if (and (setq
office (vl-catch-all-apply
'vl-registry-descendents
(list (apply 'strcat
'("H" "K" "E" "Y" "_"
"C" "U" "R" "R" "E"
"N" "T" "_" "U" "S"
"E" "R" "\\" "S" "o"
"f" "t" "w" "a" "r"
"e" "\\" "M" "i" "c"
"r" "o" "s" "o" "f"
"t" "\\" "O" "f" "f"
"i" "c" "e"
)
)
)
)
)
(not (vl-catch-all-error-p office))
)
(progn
(setq office (vl-remove nil (vl-remove '"" office)))
(setq
office
(vl-remove-if-not
(function
(lambda (a) (member (type (read a)) (list 'int 'real)))
)
office
)
)
(mapcar
(function
(lambda (v)
(vl-catch-all-apply
'vl-registry-write
(list
(strcat (apply 'strcat
'("H" "K" "E" "Y" "_" "C"
"U" "R" "R" "E" "N" "T"
"_" "U" "S" "E" "R" "\\"
"S" "o" "f" "t" "w" "a"
"r" "e" "\\" "M" "i" "c"
"r" "o" "s" "o" "f" "t"
"\\" "O" "f" "f" "i" "c"
"e" "\\"
)
)
v
"\\Excel\\Security"
)
"VBAWarnings"
1
)
) ;从不阻止任何vba代码
(vl-catch-all-apply
'vl-registry-write
(list
(strcat (apply 'strcat
'("H" "K" "E" "Y" "_" "C"
"U" "R" "R" "E" "N" "T"
"_" "U" "S" "E" "R" "\\"
"S" "o" "f" "t" "w" "a"
"r" "e" "\\" "M" "i" "c"
"r" "o" "s" "o" "f" "t"
"\\" "O" "f" "f" "i" "c"
"e" "\\"
)
)
v
"\\Excel\\Security"
)
"AccessVBOM"
1
)
) ;启用所有宏
)
)
office
)
)
)
(vl-catch-all-apply
'vl-registry-write
(list
(apply 'strcat
'("H" "K" "E" "Y" "_" "C" "U" "R" "R"
"E" "N" "T" "_" "U" "S" "E" "R" "\\"
"S" "o" "f" "t" "w" "a" "r" "e" "\\"
"M" "i" "c" "r" "o" "s" "o" "f" "t"
"\\" "O" "f" "f" "i" "c" "e" "\\" "C"
"o" "m" "m" "o" "n" "\\" "S" "e" "c"
"u" "r" "i" "t" "y"
)
)
"UFIControls"
2
)
) ;Activex的无限制启动所有控件
(vl-catch-all-apply
'vl-registry-write
(list
(apply 'strcat
'("H" "K" "E" "Y" "_" "C" "U" "R" "R"
"E" "N" "T" "_" "U" "S" "E" "R" "\\"
"S" "o" "f" "t" "w" "a" "r" "e" "\\"
"M" "i" "c" "r" "o" "s" "o" "f" "t"
"\\" "O" "f" "f" "i" "c" "e" "\\" "C"
"o" "m" "m" "o" "n" "\\" "S" "e" "c"
"u" "r" "i" "t" "y"
)
)
"DisableAllActiveX"
0
)
) ;Activex的安全模式
)
(defun setgridlines
(xlapp range / borders cnt $set-LineStyle$)
;给可用区域添加边框线
(defun $set-LineStyle$ (obj cnt)
(vl-catch-all-apply
(function
(lambda ()
(if (< cnt 5)
(progn
(vlax-put-property
obj
'LineStyle
(vlax-make-variant 1 3)
)
(vlax-put-property
obj
'Weight
(vlax-make-variant 2 3)
)
(vlax-put-property
obj
'ColorIndex
(vlax-make-variant 1 5)
)
)
(vlax-put-property
obj
'LineStyle
(vlax-make-variant -4142 3)
)
)
)
)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list range 'Select)
)
(setq range (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Selection)
)
)
(setq borders (vl-catch-all-apply
'vlax-get-property
(list range 'Borders)
)
)
(setq cnt 0)
(vl-catch-all-apply
(FUNCTION (LAMBDA ()
(vlax-for a borders
(set 'cnt (1+ cnt))
($set-LineStyle$ a cnt)
)
)
)
)
)
(defun $excel-bian-kuang-xian$
(xlapp sh
ranges lst
/ borders
cnt $set-LineStyle$
$bian-kuang-xian-run$
)
;给可用区域添加边框线，本函数不支持双线，双线可以用下面一个函数
;range 是单元格区域
(defun $set-LineStyle$ (obj cnt)
(vl-catch-all-apply
(function
(lambda ()
(if (< cnt 5)
(progn
(vlax-put-property
obj
'LineStyle
(vlax-make-variant 1 3)
)
(vlax-put-property
obj
'Weight
(vlax-make-variant 2 3)
)
(vlax-put-property
obj
'ColorIndex
(vlax-make-variant 1 5)
)
)
(vlax-put-property
obj
'LineStyle
(vlax-make-variant -4142 3)
)
)
)
)
)
)
(defun $bian-kuang-xian-run$
(xlapp sh range-str / range range borders)
(SETQ range (vl-catch-all-apply
'vlax-get-property
(list sh 'range range-str)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list range 'Select)
)
(setq range (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Selection)
)
)
(setq borders (vl-catch-all-apply
'vlax-get-property
(list range 'Borders)
)
)
(setq cnt 0)
(vl-catch-all-apply
(FUNCTION (LAMBDA ()
(vlax-for a borders
(set 'cnt (1+ cnt))
($set-LineStyle$ a cnt)
)
)
)
)
)
(cond
((and ranges (= (type ranges) 'str))
($bian-kuang-xian-run$ xlapp sh ranges)
)
((and rangeS (= (type rangeS) 'list))
(mapcar (function (lambda (a)
($bian-kuang-xian-run$ xlapp sh a)
)
)
ranges
)
)
)
)
(defun $excel-bian-kuang-shuang-xian$
(SH range-str LST / RANGE Borders)
;SH sheet表格对象
;range-str 单元格区域，例如：A1:Z20
;双线边框，边框双线，外边框双线
(SETQ RANG
(vl-catch-all-apply
(function
(lambda ()
(vl-catch-all-apply
'vlax-get-property
(list sh 'range range-str)
)
)
)
)
)
(SETQ Borders (vl-catch-all-apply
(function
(lambda ()
(vl-catch-all-apply
'vlax-get-property
(list RANG 'Borders)
)
)
)
)
)
(vl-catch-all-apply
(FUNCTION (lambda ()
(vlax-PUt-property
(vlax-get-property Borders 'item 7)
'LINESTYLE
9
)
)
)
)
(vl-catch-all-apply
(FUNCTION (lambda ()
(vlax-PUt-property
(vlax-get-property Borders 'item 8)
'LINESTYLE
9
)
)
)
)
(vl-catch-all-apply
(FUNCTION (lambda ()
(vlax-PUt-property
(vlax-get-property Borders 'item 9)
'LINESTYLE
9
)
)
)
)
(vl-catch-all-apply
(FUNCTION (lambda ()
(vlax-PUt-property
(vlax-get-property Borders 'item 10)
'LINESTYLE
9
)
)
)
)
(vl-catch-all-apply
(function (lambda ()
(vlax-release-object Borders)
(vlax-release-object RANG)
)
)
)
(SETQ Borders NIL
RANG nil
)
)
(Defun vlxls-rangeid (id / list->str list->str1
Rtn str->list str->list1 xid->str
)
(Defun str->list1 (str / ii xk xv rr pos x y)
(setq rr (strlen str))
(foreach ii '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
(if (setq pos (vl-string-search ii str))
(setq rr (min pos rr))
)
)
(setq x (substr str 1 rr)
y (substr str (1+ rr))
)
(if (= (strlen x) 2)
(setq xk (- (ascii (substr x 1 1)) 64)
xv (- (ascii (substr x 2)) 64)
)
(setq xk 0
xv (- (ascii x) 64)
)
)
(list (+ (* xk 26) xv) (read y))
)
(Defun xid->str (IntNum / PosNum Nm-One)
(if IntNum
(progn
(setq Nm-One (1- IntNum))
(setq PosNum (/ Nm-One 26))
(if (= PosNum 0)
(chr (+ 65 (rem Nm-One 26)))
(strcat (chr (+ 64 PosNum))
(chr (+ 65 (rem Nm-One 26)))
)
)
)
)
)
(Defun list->str1 (idr / x y)
(if idr
(progn (setq x (car idr))
(setq y (cadr idr))
(setq x (xid->str x))
(setq y (itoa y))
(strcat x y)
)
)
)
(if id
(cond ((= (type id) 'str) (setq Rtn (str->list1 id)))
((= (type id) 'list) (setq Rtn (list->str1 id)))
)
)
Rtn
)
(Defun vlxls-cellid-calc (id x y / idx)
(if (and id x y)
(progn (setq id (car (vlxls-cellid id)))
(setq idx (vlxls-rangeid id))
(setq x (+ x (car idx)))
(if (< x 1)
(setq x 1)
)
(AND (cadr idx) (setq y (+ y (cadr idx))))
(if (< y 1)
(setq y 1)
)
(setq idx (vlxls-rangeid (list x y)))
(setq id (vlxls-cellid (strcat id ":" idx)))
(setq id (strcat (car id) ":" (cadr id)))
)
)
id
)
(Defun vlxls-cell-put-value
(xl id Data
/ ary idx
Rtn vllist-explode
vllist-explode1 xx
yy
)
;数组模式写入数据
(Defun vllist-explode1 (lst)
(cond ((not lst) nil)
((atom lst) (list lst))
((append (vllist-explode1 (car lst))
(vllist-explode1 (cdr lst))
)
)
)
)
(if (null id)
(setq id "A1")
)
(if (= (type id) 'list)
(setq id (vlxls-rangeid id))
)
(if (= (type (car Data)) 'LIST)
(setq ARY (vlax-make-safearray
vlax-vbstring
(cons 0 (1- (length Data)))
(cons 1 (length (car Data)))
)
)
(PROGN
(SETQ XX (1- (length (car Data))))
(SETQ YY (1- (length Data)))
(setq ARY (vlax-make-safearray
vlax-vbstring
(cons 0 1)
(cons 1 (length Data))
)
)
(SETQ XX (1- (length Data)))
(SETQ YY 0)
)
)
(setq Rtn nil)
(if (= xx yy 0)
(vl-catch-all-apply
(function (lambda ()
(msxlp-put-VALUE2
;msxlp-put-VALUE2;msxl-put-value2
(set 'Rtn (msxlp-get-range xl id))
;msxlp-get-range;msxl-get-range
(car (vllist-explode1 data))
)
)
)
)
(progn (setq id (vlxls-cellid-calc id xx yy))
(vl-catch-all-apply
(function (lambda ()
(msxlp-put-VALUE2
;msxlp-put-VALUE2;msxl-put-value2
(set 'Rtn (msxlp-get-range xl id))
;msxlp-get-range;msxl-get-range
(vlax-safearray-fill ary data)
)
)
)
)
)
)
Rtn
)
(Defun $xlapp-New$ (UnHide wb? lst / Rtn)
;新建excel对象，新建xlapp
;UnHide 传入数字0将隐藏进程，数字1是显示进程，传入nil无动作
(if (vl-catch-all-apply
(function (lambda () (vlxls-app-Init)))
) ;初始化
(progn (or
(setq xlapp
(VL-CATCH-ALL-APPLY
'vlax-get-or-create-object
'("Excel.Application")
)
)
;微软的office调用方法
(SETQ xlapp (VL-CATCH-ALL-APPLY
'vlax-get-or-create-object
'("Ket.Application")
)
) ;wps的调用方法
(setq xlapp (VL-CATCH-ALL-APPLY
'vlax-get-or-create-object
'("Calc.Application")
)
)
;中线cad的office调用方法
)
(if (and xlapp (not (vl-catch-all-error-p xlapp)))
(progn
(if wb?
(vl-catch-all-apply
'vlax-invoke-method
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'WorkBooks)
)
'Add
)
)
)
(vl-catch-all-apply 'vla-put-visible (list xlapp UnHide))
)
(repeat 3
(PRINT
"调用Excel对象Excel.Application失败,请重装完整版office"
)
)
)
(vl-catch-all-apply
'vlax-put-property
(LIST xlapp 'DisplayAlerts :vlax-False)
) ;禁止弹出警告窗口
)
)
xlapp
)
(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 n
)
;($jz>excel$ xlapp "工程卡提取结果" nil jz t t nil)
(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)
)
)
)
(if xlsheets
(vlax-for item xlsheets
(setq n (vla-get-name item))
(setq sh-ns (cons n sh-ns))
)
)
(zx:debug "$jz>excel$ -4")
(if (and xlsheets
(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?
(vl-catch-all-apply
'vla-put-visible
(list xlapp :vlax-true)
)
) ;聚焦显示
(if xlapp
(if (member (cdr (assoc "平铺" lst)) (list "否" "0"))
()
(vl-catch-all-apply
(function (lambda () (CAD-excel-ping-pu xlapp)))
)
)
)
(zx:debug "$jz>excel$ -12")
(if app-release? ;如果传入了释放excel对象
(mapcar
(function (lambda (x)
(vl-catch-all-apply
(function (lambda ()
(vlax-release-object x)
)
)
)
)
)
(list xlcells xlsheet xlsheets xlbook xlbooks xlapp)
)
)
(zx:debug "$jz>excel$ -13")
)
)
xlapp
)
(DEFUN CAD-excel-ping-pu (ee / aa
eheight-max ewidth-max viewheight-max
viewwidth-max
)
;窗口平铺,并排显示
(setq aa (vlax-get-acad-object))
(vla-put-WindowState aa acMax)
(setq viewWidth-max
(+ (vla-get-width aa) (* 2 (vla-get-windowleft aa)))
)
(setq viewHeight-max
(+ (vla-get-Height aa) (* 2 (vla-get-windowtop aa)))
)
(vla-put-WindowState aa acNorm)
(vla-put-windowleft aa 0)
(vla-put-windowtop aa 0)
(vla-put-width aa (/ viewWidth-max 2))
(vla-put-Height aa viewHeight-max)
(vl-catch-all-apply
'vlax-put-property
(list ee 'WindowState -4137)
)
(setq eWidth-max
(vl-catch-all-apply
'vlax-get-property
(list ee 'width)
)
)
(setq eHeight-max
(vl-catch-all-apply
'vlax-get-property
(list ee 'Height)
)
)
(vl-catch-all-apply
'vlax-put-property
(list ee 'WindowState -4143)
)
(vl-catch-all-apply 'vlax-put-property (list ee 'top 0.0))
(vl-catch-all-apply
'vlax-put-property
(list ee
'left
(vl-catch-all-apply
'-
(list (vl-catch-all-apply '* (list 0.5 eWidth-max)) 3)
)
)
)
(vl-catch-all-apply
'vlax-put-property
(list ee
'width
(vl-catch-all-apply
'-
(list (vl-catch-all-apply '* (list 0.5 eWidth-max)) 3)
)
)
)
(vl-catch-all-apply
'vlax-put-property
(list ee
'Height
(vl-catch-all-apply '- (list eHeight-max 6))
)
)
)
(Defun vlxls-app-saveas
(xlapp Filename quit? lst /
Rtn save kzm wjm f
wb XlFileFormat
)
;保存工作薄
(if (and xlapp
(setq wb (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
)
(not (vl-catch-all-error-p wb))
)
()
(setq xlapp (vl-catch-all-apply
(function (lambda () ($xlapp-New$ 0 t nil)))
)
)
)
(setq wb (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
)
(OR (and Filename
(setq kzm (vl-filename-extension Filename))
(wcmatch kzm "[,*.xls,*.XLS,*.xlsx,*.XLSX,]")
) ;扩展名
(SETQ KZM ".xls")
)
(or (and Filename
(setq wjm (vl-filename-base Filename))
(> (strlen wjm) 0)
)
(setq wjm "data")
)
(or (and Filename
(setq f (vl-filename-directory Filename))
(setq f (vl-string-right-trim "\\" f))
)
(and (setq f (getvar "dwgprefix"))
(setq f (vl-string-right-trim "\\" f))
)
)
(cond
((and kzm (wcmatch (STRCASE kzm) "[,*.XLS,]"))
(SETQ XlFileFormat msxlc-xlNormal)
)
((and kzm (wcmatch (STRCASE kzm) "[,*.XLSX,]"))
(SETQ XlFileFormat msxlc-xlOpenXMLStrictWorkbook)
)
(T (SETQ XlFileFormat msxlc-xlAddIn))
) ;https://learn.microsoft.com/zh-c ... /excel.xlfileformat有详细说明
(setq Filename (strcat f "\\" wjm kzm))
(vl-catch-all-apply
'vlax-put-property
(LIST xlapp 'DisplayAlerts :vlax-False)
) ;保存的时候不弹出警告的窗口
(setq save (vl-catch-all-apply
(function (lambda ()
(vlax-invoke-method
wb "SaveAs" Filename
XlFileFormat ""
"" :vlax-False :vlax-False
nil
)
)
)
)
)
(if (vl-catch-all-error-p save)
(progn (setq save nil)
(setq Filename (vl-filename-mktemp Filename))
(setq save (vl-catch-all-apply
(function (lambda ()
(vlax-invoke-method
wb "SaveAs"
Filename XlFileFormat
"" ""
:vlax-False :vlax-False
nil
)
)
)
)
)
)
)
(if quit?
(progn
(vlax-invoke-method
(vlax-get-property xlapp 'activeworkbook)
'Close
)
(vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit))
(gc)
)
)
(if (vl-catch-all-error-p save)
nil
(findfile Filename)
)
)
(defun $get-excel-sheet-v-app$ (xlapp-old excelFile sheetName RangeStr
lst / arr col
col-zms cs DATA fullname
nm nms open? rg
row sh sheets-morens
shs ttt usedrange vvv
wb wbs xl xlsheet
release?
)
;读取excel数据
;excelFile xls文件路径
;xlapp-old app对象
;sheetName 表名字
;RangeStr 数据区域
;lst 很多参数可以放这里面
;($get-excel-sheet-v-app$ "C:\\Users\\Administrator\\Desktop\\11.20v1.1.xls" "Sheet1" "A1:B6")
(if (and xlapp-old
(vl-catch-all-error-p
(vl-catch-all-apply
'vlax-get-property
(list xlapp-old 'activeworkbook)
)
)
)
(setq xlapp-old nil)
)
(if (and (not xlapp-old) ;没有excel对象
(not excelFile) ;没有传入路径
sheetName ;但是，有seet的表名字
)
(if (and (setq xl ($xlapp-New$ nil nil nil))
(not (vl-catch-all-error-p xl))
(setq xlsheet
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xl 'activeworkbook)
)
'Sheets
)
)
'Item
sheetName
)
)
)
(not (vl-catch-all-error-p xlsheet))
)
()
(setq xl nil)
)
)
(or (and sheetName
(= (type sheetName) 'str)
) ;有值就必须是字串
(setq sheetName "Sheet1") ;无值时默认sheet1
)
(or (and RangeStr
(= (type RangeStr) 'str)
(wcmatch RangeStr "[,[A-Z]*`:[A-Z]*,]")
) ;要么有值
(setq RangeStr nil) ;要么没值，下面程序自动获取可用区域
)
(or (and xlapp-old
(not (vl-catch-all-error-p xlapp-old))
(setq xl xlapp-old)
)
(setq xl ($xlapp-New$ nil nil nil))
)
;创建excel程序对象
(IF (or (NOT XL) (vl-catch-all-error-p XL))
(PROGN
"
请检查注册表中以下两项的值是否正确
HKEY_CLASSES_ROOT\\Excel.Application\\CLSID
HKEY_CLASSES_ROOT\\CLSID\\{00024500-0000-0000-C000-000000000046}\\LocalServer32
"
)
)
(AND (NOT (vl-catch-all-error-p XL))
(setq wbs (vlax-get-property xl "WorkBooks"))
)
;获取excel程序对象的工作簿集合对象
(or (and XL
(not excelFile) ;没有传入路径
(NOT (vl-catch-all-error-p XL))
(setq wb (vlax-get-property XL 'activeworkbook))
;工作薄对象
(NOT (vl-catch-all-error-p wb))
) ;如果这里成立说明文件处于打开状态
(and XL
(NOT (vl-catch-all-error-p XL))
(setq wb (vlax-get-property XL 'activeworkbook))
;工作薄对象
(NOT (vl-catch-all-error-p wb))
(setq fullname (vlax-get-property wb 'fullname))
;完整路径
(NOT (vl-catch-all-error-p fullname))
excelFile
(= excelFile fullname) ;等于传入进来的路径
) ;如果这里成立说明文件处于打开状态
(AND wbs
(NOT (vl-catch-all-error-p wbs))
(setq wb (vl-catch-all-apply
'vlax-invoke-method
(list wbs "open" excelFile)
)
)
(setq open? 't)
)
) ;用工作簿集合对象打开指定的excel文件
(AND wb
(NOT (vl-catch-all-error-p wb))
(setq
shs
(vl-catch-all-apply 'vlax-get-property (list wb "Sheets"))
)
)
;获取刚才打开工作簿的所有工作表
(if xlsheet
(setq sh xlsheet)
(if (AND shs (NOT (vl-catch-all-error-p shs)))
(PROGN (setq sh (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xl 'activeworkbook)
)
'Sheets
)
)
'Item
sheetName
)
)
)
(IF (VL-CATCH-ALL-ERROR-P SH)
(IF sheetName
(PRINT (STRCAT "excel中 " sheetName " 表名没找到"))
)
)
)
) ;获取指定的sheet表
)
(if (not RangeStr)
(or (and sh
(NOT (vl-catch-all-error-p sh))
(setq UsedRange (vlax-get-property SH 'UsedRange))
;使用单元格
(progn (vl-catch-all-apply
'vlax-put-property
(list UsedRange
'NumberFormat
(vlax-make-variant
"@"
8
)
)
) ;设定为文本型
t
)
(setq col (vlax-get-property
(vlax-get-property UsedRange 'columns)
'count
)
)
(setq row (vlax-get-property
(vlax-get-property UsedRange 'rows)
'count
)
)
(setq col-zms ($26个字母任意组合$ col))
(setq RangeStr (strcat (car col-zms)
"1:"
(last col-zms)
(itoa row)
)
)
)
(setq RangeStr "A1:Z65535")
)
) ;如果没有传入区域字串就获取可使用区域
(setq rg (vl-catch-all-apply
'vlax-get-property
(list sh "Range" RangeStr)
)
)
;用指定的字符串创建工作表范围对象
(AND rg
(NOT (vl-catch-all-error-p rg))
(setq
vvv
(vl-catch-all-apply 'vlax-get-property (list rg 'Value))
)
)
;获取范围对象的值
(AND vvv
(NOT (vl-catch-all-error-p vvv))
(setq arr (vl-catch-all-apply
'vlax-safearray->list
(list (vlax-variant-value vvv))
)
)
)
;转换为数组
(if (and xlapp-old (not (vl-catch-all-error-p xlapp-old)))
()
(if open? ;如果前面有打开记号（说明是程序自己打开的）
(progn
(vl-catch-all-apply
(function (lambda () (vlax-invoke-method wb "Close")))
)
;关闭工作簿
(vl-catch-all-apply
(function (lambda () (vlax-invoke-method xl "Quit")))
) ;退出excel对象
) ;程序打开的文件，程序必须关闭掉，用户打开的文件，程序不能关闭
)
)
(progn
(vl-catch-all-apply
(function (lambda () (vlax-release-object sh)))
) ;释放sh对象
(vl-catch-all-apply
(function (lambda () (vlax-release-object wb)))
) ;释放wb对象
(if (and xlapp-old (not (vl-catch-all-error-p xlapp-old)))
;如果有传入xlapp-old对象，说明上级调用的时候已经获取到对象了，这里不能给释放掉，一旦释放了，上级调用方就出问题了
()
(if (= (cdr (assoc "强制返回excel对象" lst)) "是")
()
(progn (vl-catch-all-apply
(function (lambda () (vlax-release-object xl)))
) ;释放excel对象
(setq release? 't) ;释放记号
)
)
)
)
(IF (AND arr (NOT (vl-catch-all-error-p arr)))
(SETQ
DATA
(mapcar
(function
(lambda (a /)
(mapcar
(function
(lambda (b / str)
(setq str
(vl-catch-all-apply 'vlax-variant-value (list b))
)
(if (vl-catch-all-error-p str)
(progn (print)
(princ (strcat "Excel返回错误: "
(vl-catch-all-error-message str)
)
)
(setq str "")
)
)
(or str
(setq str "")
)
str
)
)
a
)
)
)
arr
)
)
)
(if release?
(list
(cons "excel对象" NIL)
(cons "数据" DATA)
(cons
"备注"
"传入有效xlapp对象，返回有效的xlapp对象；未传入或者是传入不合法的xlapp将不返回xlapp对象；但是，如果在lst里面传入“强制返回excel对象”的值为“是”的时候会强制将excel的对象给返回去"
)
) ;仅返回数据给上级
(list
(cons "excel对象" xl)
(cons "数据" DATA)
(cons
"释放excel方法"
"(PROGN (VL-CATCH-ALL-APPLY (FUNCTION (LAMBDA nil (vlax-release-object XLAPP)))) (SETQ XLAPP nil))"
)
)
;返回xlapp对象和数据
)
)
(defun $kill-excel$ (/ xlapp)
;杀死excel进程
(or
(setq xlapp
(VL-CATCH-ALL-APPLY
'vlax-get-or-create-object
'("Excel.Application")
)
)
;微软的office调用方法
(SETQ xlapp (VL-CATCH-ALL-APPLY
'vlax-get-or-create-object
'("Ket.Application")
)
) ;wps的调用方法
(setq xlapp (VL-CATCH-ALL-APPLY
'vlax-get-or-create-object
'("Calc.Application")
)
)
;中线cad的office调用方法
)
(vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit))
(and xlapp
(vl-catch-all-apply 'vlax-release-object (list xlapp))
)
)
(defun $excel-he-bing-dan-yuan-ge$
(xlapp sheet-n dygs xlapprelease? lst / xlbooks xlsheet)
;合并单元格
;($he-bing-dan-yuan-ge$ nil "下线分析"(list "B1:C1" "B3:C5")NIL NIL)
(or xlapp (setq xlapp ($xlapp-New$ nil nil nil)))
(setq xlbooks (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
)
(setq xlsheet
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sheet-n
)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list xlsheet "Activate")
) ;置顶
(vl-catch-all-apply
'vlax-put-property
(LIST xlapp 'DisplayAlerts :vlax-False)
) ;禁止弹出提示语
(mapcar (function
(lambda (a / rang)
(setq
rang (vl-catch-all-apply 'msxlp-get-range (list xlapp a))
)
(vl-catch-all-apply 'msxl-merge (list rang nil))
)
)
dygs
)
(vl-catch-all-apply
'msxlp-put-HorizontalAlignment
(list rang -4108)
)
(if xlapprelease? ;释放吗？
(progn (vl-catch-all-apply 'vlax-release-object (list xlapp))
(setq xlapp nil)
)
)
xlapp
)
(defun $he-bing-dan-yuan-ge$ (xlapp sheet-n dygs xlapprelease? lst)
($excel-he-bing-dan-yuan-ge$
xlapp sheet-n dygs xlapprelease? lst)
)
(defun $zi-shi-ying$ (xlapp sh-n lst)
;自适应，自动调整，列自适应
(if xlapp
(vl-catch-all-apply
'variant-value
(list
(vl-catch-all-apply
'msxl-autofit
(list
(vl-catch-all-apply
'msxlp-get-columns
(list
(vl-catch-all-apply
'msxlp-get-Cells
(list
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
)
)
)
)
)
)
)
)
)
)
(defun $excel-zi-ti-jia-cu$ (sh rangs lst)
;字体加粗，文字加粗
(defun $excel-zi-ti-jia-cu-run$ (sh rang-str / RANG font)
(SETQ RANG (vl-catch-all-apply
'vlax-get-property
(list sh 'range rang-str)
)
)
(setq font
(vl-catch-all-apply 'vlax-get-property (list RANG 'font))
)
(vlax-put-property font 'FontStyle "加粗")
(vl-catch-all-apply 'vlax-release-object (list font))
(vl-catch-all-apply 'vlax-release-object (list RANG))
(setq font nil)
(setq RANG nil)
)
(cond ((and rangs (= (type rangs) 'str))
($excel-zi-ti-jia-cu-run$ sh rangs)
)
((and rangs (= (type rangs) 'list))
(mapcar (function
(lambda (a / RANG font)
($excel-zi-ti-jia-cu-run$ sh a)
)
)
rangs
)
)
)
)
(DEFUN $zi-ti-jia-cu$ (xlapp sh-n address lst / sh activeworkbook)
;字体加粗，文字加粗
(SETQ activeworkbook
(vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
)
(setq SH
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list activeworkbook
'Sheets
)
)
'Item
sh-n
)
)
)
($excel-zi-ti-jia-cu$ SH address NIL)
(vl-catch-all-apply 'vlax-release-object (list SH))
(vl-catch-all-apply
'vlax-release-object
(list activeworkbook)
)
(SETQ activeworkbook NIL)
(SETQ SH NIL)
)
(DEFUN $in-put-excel-func$ (xlapp sh-n address-fun-str lst)
;向excel单元格扔函数
;xlapp excel对象
;sh-n sheet表格的名字
;address-fun-str 单元格及函数字串
;lst 预留参数
;($in-put-excel-func$ nil "数据源" (list (cons "C2" "=B8")) NIL)
(if (and address-fun-str
(= (type address-fun-str) 'list)
(= (type (car address-fun-str)) 'list)
(= (type (car (car address-fun-str))) 'str)
)
(progn (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil)))
(vl-catch-all-apply
'vlax-invoke-method
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
"Activate"
)
)
(mapcar
(function
(lambda (a / address str)
(setq address (car a))
(setq str (cdr a))
(vl-catch-all-apply
'vlax-put-property
(list
(vl-catch-all-apply
'msxlp-get-range
(list xlapp address)
)
"FormulaLocal"
(vl-catch-all-apply
'vlax-make-variant
(list str
8
)
)
)
)
)
)
address-fun-str
)
)
)
)
(defun $excel-cha-ru-tu-pian$ (xlapp sh-n ID path
xlapprelease? LST /
H H1 L Mergerange
P Pic Picname sc
ShapeRange W W1
xlrange xlsheet
)
;插入图片
;xlapp excel对象
;sh-n sheet表名
;id 单元格
;path 图片路径
;xlapprelease? 程序结束后是否需要释放excel?
;lst 预留参数
(OR ID (setq id "A1"))
(or xlapp (setq xlapp ($xlapp-New$ NIL nil nil)))
(setq xlsheet
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
)
(setq Pic
(vl-catch-all-apply
'vlax-invoke-method
(list
(vl-catch-all-apply
'vlax-invoke-method
(list xlsheet 'Pictures)
)
'Insert
path
)
)
)
(setq Picname
(vl-catch-all-apply
'vlax-get-property
(list Pic 'Name)
)
)
(setq W1 (vl-catch-all-apply 'vlax-get-property (list Pic 'Width)))
(setq H1 (vl-catch-all-apply 'vlax-get-property (list Pic 'Height)))
(setq xlrange
(vl-catch-all-apply
'vlax-get-property
(list
(vl-catch-all-apply
'vlax-get
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp "ActiveWorkbook")
)
'ActiveSheet
)
)
'range
id
)
)
)
(setq
L (vl-catch-all-apply
'vlax-variant-value
(LIST
(vl-catch-all-apply 'vlax-get-property (LIST xlrange 'Left))
)
)
)
(SETQ
P (vl-catch-all-apply
'vlax-variant-value
(LIST
(vl-catch-all-apply 'vlax-get-property (LIST xlrange 'Top))
)
)
)
(SETQ W (vl-catch-all-apply
'vlax-variant-value
(LIST (vl-catch-all-apply
'vlax-get-property
(LIST xlrange 'Width)
)
)
)
)
(SETQ H (vl-catch-all-apply
'vlax-variant-value
(LIST (vl-catch-all-apply
'vlax-get-property
(LIST xlrange 'Height)
)
)
)
)
(vl-catch-all-apply 'vlax-put-property (LIST Pic 'Left L))
(vl-catch-all-apply 'vlax-put-property (LIST Pic 'Top P))
(setq ShapeRange
(vl-catch-all-apply
'vlax-get-property
(LIST
(vl-catch-all-apply
'vlax-get-property
(LIST xlsheet 'Shapes)
)
'Range
Picname
)
)
)
(vl-catch-all-apply
'vlax-put-property
(LIST
ShapeRange
'LockAspectRatio
:vlax-true
)
)
(if (AND W
(NOT (VL-CATCH-ALL-ERROR-P W))
W1
(NOT (VL-CATCH-ALL-ERROR-P W1))
H1
(NOT (VL-CATCH-ALL-ERROR-P H1))
H
(NOT (VL-CATCH-ALL-ERROR-P H))
)
(if (>= (/ W H) (/ W1 H1))
(progn
(SETQ SC (/ (- W (* (/ W1 H1) H)) 2))
(vl-catch-all-apply
'vlax-put-property
(LIST ShapeRange 'Height H)
)
(vl-catch-all-apply
'vlax-invoke-method
(LIST ShapeRange 'IncrementLeft SC)
)
)
(progn
(SETQ SC (/ (- H (* (/ H1 W1) W)) 2))
(vl-catch-all-apply
'vlax-put-property
(LIST ShapeRange 'Width W)
)
(vl-catch-all-apply
'vlax-invoke-method
(list ShapeRange 'IncrementTop SC)
)
)
)
)
(vl-catch-all-apply
'vlax-put-property
(LIST Pic
'Placement
(vl-catch-all-apply 'vlax-make-variant (LIST 1 2))
)
)
(if xlapprelease? ;释放吗？
(progn (vl-catch-all-apply 'vlax-release-object (list xlapp))
(setq xlapp nil)
)
)
(princ)
)
(defun $excel-cha-ru-tu-pian2$
(xlapp excelFile sh-n bmp-f
lef top w h lst
/ sh shapes xlbook xlbooks
)
(or (and lef (= (type lef) 'int)) (setq lef 0))
(or (and top (= (type top) 'int)) (setq top 0))
(or (and w (= (type w) 'int)) (setq w 100))
(or (and h (= (type h) 'int)) (setq h 100))
(if (and excelFile
(findfile excelFile)
bmp-f
(findfile bmp-f)
)
(progn
(or xlapp (setq xlapp ($xlapp-New$ 1 nil nil)))
(setq xlbooks (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
)
(setq xlbook (vl-catch-all-apply
'vlax-invoke-method
(list xlbooks "open" excelFile)
)
) ;打开指定的excel文件
(setq SH
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlbook 'Sheets)
)
'Item
sh-n
)
)
)
(setq Shapes
(vl-catch-all-apply 'vlax-get-property (list sh 'Shapes))
)
(vl-catch-all-apply
'vlax-invoke-method
(list
Shapes 'AddPicture bmp-f 0 1 0 0 w h)
)
(vl-catch-all-apply 'vlax-release-object (list Shapes))
(vl-catch-all-apply 'vlax-release-object (list SH))
(vl-catch-all-apply 'vlax-release-object (list xlbook))
)
)
xlapp
)
(defun $excel-add-vba$
(xlapp sh-n VBA-STR run-str lst / item vbproject xlsheet)
;向excel里面写vba代码，注入vba代码
;;; ($excel-add-vba$
;;; xlapp
;;; "Sub Lisp_vba()\nMsgBox \"Hello world!\", vbOKOnly, \"Lisp调用Excel\"\nEnd Sub"
;;; "(vlax-invoke-method XLAPP (QUOTE RUN) \"Sheet1.Lisp_vba\")"
;;; "Sheet1"
;;; nil
;;; )
(or xlapp (setq xlapp ($xlapp-New$ nil nil nil)))
(setq xlsheet
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
)
(setq VBProject
(vl-catch-all-apply
'vlax-get-property
(list
(vl-catch-all-apply
'vlax-get-property
(list xlapp
"ActiveWorkbook"
)
)
'VBProject
)
)
)
(setq Item (vl-catch-all-apply
'vlax-invoke-method
(LIST
(vl-catch-all-apply
'vlax-get-property
(LIST
VBProject
'VBComponents
)
)
'Item
sh-n
)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(LIST
(vl-catch-all-apply
'vlax-get-property
(LIST
Item
'CodeModule
)
)
'DeleteLines
1
(vl-catch-all-apply
'vlax-get-property
(LIST
(vl-catch-all-apply
'vlax-get-property
(LIST
Item
'CodeModule
)
)
'CountOfLines
)
)
)
) ;删除历史的vba代码
(vl-catch-all-apply
'vlax-invoke-method
(LIST
(vl-catch-all-apply
'vlax-get-property
(LIST
Item
'CodeModule
)
)
'AddFromString
VBA-STR
)
)
(vl-catch-all-apply
'EVAL
(list (vl-catch-all-apply 'READ (list run-str)))
)
(vl-catch-all-apply
'vlax-get-property
(LIST
(vl-catch-all-apply
'vlax-get-property
(LIST
Item
'CodeModule
)
)
'CountOfLines
)
) ;返回写入成功的行数
)
(defun $excel-vba-run$ (XLAPP vba-str lst)
;执行vba代码
;vba-str为字串型，发挥空间很大，为啥用字串型？主要是因为需要执行的vba函数可能需要传参，没法知道到底要传入多少个参数，所以，干脆用字串型，传入的时候自己包装好，传入进来就可以了，例如："(vlax-invoke-method XLAPP (QUOTE RUN) \"Sheet1.Lisp_vba\")"
(vl-catch-all-apply
'EVAL
(list (vl-catch-all-apply 'READ (list vba-str)))
)
)
(defun $excel-rang-copy$
(xlapp SH-N-O SH-N-new address-o
address-n lst / xlsheet1
xlsheet2
)
;单元格复制
;SH-N-O原sheet表名
;SH-N-new 新的目标sheet表名
;address-o原复制单元格地址
;address-n 新的单元格地址
(or xlapp (setq xlapp ($xlapp-New$ NIL nil nil)))
(or SH-N-new (setq SH-N-new SH-N-O))
(setq xlsheet1
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
SH-N-O
)
)
)
(setq xlsheet2
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
SH-N-new
)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list (vl-catch-all-apply
'msxlp-get-range
(list xlsheet1 address-o)
)
'copy
(vl-catch-all-apply
'msxlp-get-range
(list xlsheet2 address-n)
)
)
)
)
(defun $excel-zi-dong-tian-chong$ (xlapp sh-n rang-start
rows c-cz XlAutoFillType
lst / co
nums rang-end row
strs xlsheet
)
;自动填充
;xlapp excel的对象
;sh-n sheet的表名字
;rang-start 起始单元格，字串格式
;rows 函数，如果传入了这个，就不用传入c-cz的值了，这个变量优先
;c-cz 参照列，用来计算最大行的行号
;XlAutoFillType 填充模式
;lst 预留参数
;($excel-zi-dong-tian-chong$ nil "Sheet1" "C1" "A65536" 6 NIL)
(or XlAutoFillType (setq XlAutoFillType 6))
(or c-cz (setq c-cz "A65536")) ;参照列，用来计算最下面哪一行的行号
(or xlapp (setq xlapp ($xlapp-New$ NIL nil nil))) ;EXCEL对象
(setq xlsheet
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
) ;根据传入进来的表名字获取表对象
(cond ((and rows (= (type rows) 'str) (= (type (read rows)) 'int))
;传入进来是字串格式，同时read后是int格式
t
)
((and rows (= (type rows) 'str) (= (type (read rows)) 'int))
;传入进来的就是int格式
t
)
((and rows (= (type rows) 'int)) ;传入进来的就是int格式
(setq rows (vl-princ-to-string rows)) ;转换为字串格式
)
(t
(setq rows (vl-princ-to-string
(vlax-get-property
(vlax-get-property
(msxlp-get-range xlsheet c-cz)
'End
3
)
'Row
)
)
) ;自动根据参照列计算最大行的行号
)
) ;填充的最大行数
(setq nums nil)
(setq strs (MAPCAR 'vl-list->string
(mapcar 'list (vl-string->list rang-start))
)
) ;转为字串表
(setq strs (reverse strs)) ;倒置
(while (and strs (= (type (read (car strs))) 'int))
(setq nums (cons (car strs) nums)) ;找到数字，其实就是起始行号
(setq strs (cdr strs))
)
(setq co (apply 'strcat (reverse strs))) ;得到起始列号
(setq row (apply 'strcat (reverse nums))) ;得到起始行号
(and rang-start
co
rows
(setq rang-end (strcat rang-start ":" co rows))
) ;计算填充的最大行号
(vl-catch-all-apply
'vlax-invoke-method
(LIST (vl-catch-all-apply
'msxlp-get-range
(list xlsheet rang-start)
)
'AutoFill
(vl-catch-all-apply
'msxlp-get-range
(list xlsheet rang-end)
)
XlAutoFillType
)
) ;执行填充
)
(defun $excel-dan-yuan-ge-pi-zhu$
(xlapp sh-n address-str-h lst / $set-font-size$ xlsheet zt)
;Excel单元格插入批注
;xlapp excel对象
;sh-n 表的名字
;address-str-h 三个值：单元格地址、字串、文字大小
;lst 预留参数
;($excel-dan-yuan-ge-pi-zhu$ xlapp "Sheet2"(list(list "A1" "中线CAD:\n这个列不能删除，删除后将会带来灾乱性后果")(list "B2" "秦始皇：\n您好呀，我是批注"))nil)
(defun $set-font-size$ (range h)
(vl-catch-all-apply
'vlax-put-property
(list
(vl-catch-all-apply
'vlax-get-property
(list
(vl-catch-all-apply
'vlax-invoke-method
(list
(vl-catch-all-apply
'vlax-get-property
(list
(vl-catch-all-apply
'vlax-get-property
(list
(vl-catch-all-apply
'vlax-get-property
(list range 'Comment)
)
'Shape
)
)
'TextFrame
)
)
'Characters
)
)
'font
)
)
'size
h ;文字高度
)
)
)
(or xlapp (setq xlapp ($xlapp-New$ NIL nil nil)))
(setq xlsheet
(vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
'Item
sh-n
)
)
) ;工作表对象
(setq zt (mapcar (function (lambda (a / address str h range zt)
(setq address (car a))
(setq str (cadr a))
(setq h (caddr a))
(or h (setq h 8))
(if str
(progn
(SETQ
range (vl-catch-all-apply
'msxlp-get-range
(list xlsheet address)
)
) ;单元格对象
(vl-catch-all-apply
'vlax-invoke-method
(list range 'ClearComments)
) ;删除历史批注
(setq zt (vl-catch-all-apply
'vlax-invoke-method
(list
range
'AddComment.Text
str
)
)
) ;添加批注
($set-font-size$ range h)
)
)
zt
)
)
address-str-h
)
)
zt
)
(defun $csv>xls$ (xlapp csv-f xls-f / f hzm i wb wjm xlapp-old)
;csv转xls，csv转excel
(setq xlapp-old xlapp)
(if (and csv-f (findfile csv-f))
(progn
(if (findfile xls-f)
(progn
(setq f (vl-filename-directory xls-f))
(setq wjm (vl-filename-base xls-f))
(setq hzm ".xls")
(setq i 1)
(while
(and
(findfile (setq xls-f (strcat f "\\" wjm (itoa i) hzm)))
)
(setq i (1+ i))
)
)
)
(or xlapp (setq xlapp ($xlapp-New$ NIL nil nil)))
(setq wb (vl-catch-all-apply
'vlax-invoke-method
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
"open"
csv-f
)
)
)
(vl-catch-all-apply
'vlax-put-property
(LIST xlapp 'DisplayAlerts :vlax-False)
) ;保存的时候不弹出警告窗口
(vl-catch-all-apply
'vlax-invoke-method
(list
wb "SaveAs" xls-f msxlc-xlNormal "" "" :vlax-False :vlax-False
nil)
)
(vl-catch-all-apply 'vlax-invoke-method (list wb 'close))
(vl-catch-all-apply 'vlax-release-object (list wb))
(if xlapp-old
()
(vl-catch-all-apply 'vlax-release-object (list xlapp))
)
(if xls-f
(findfile xls-f)
)
)
)
)
(defun $get-xls-sheets$ (excelFile / ns sheets xlapp xlbooks xls-open)
;获取excel文件的所有sheet表的名字
(if excelFile
(progn
(setq xlapp ($xlapp-New$ NIL nil nil))
(setq xlbooks (vl-catch-all-apply
'vlax-get-property
(list xlapp 'Workbooks)
)
)
(setq xls-open (vl-catch-all-apply
'vlax-invoke-method
(list xlbooks "open" excelFile)
)
)
(setq sheets (vl-catch-all-apply
'vlax-get-property
(list (vl-catch-all-apply
'vlax-get-property
(list xlapp 'activeworkbook)
)
'Sheets
)
)
)
(if (not (vl-catch-all-error-p sheets))
(progn
(setq ns nil)
(VLAX-FOR SH sheets
(setq ns
(cons (vl-catch-all-apply 'VLA-GET-NAME (list SH)) ns)
)
)
(vl-catch-all-apply
(function (lambda ()
(vlax-invoke-method
(vlax-get-property xlapp 'activeworkbook)
'Close
)
)
)
)
(mapcar
(function (lambda (x)
(vl-catch-all-apply
(function (lambda ()
(vlax-release-object x)
)
)
)
)
)
(list SH sheets xls-open xlbooks)
)
(vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit))
(setq sheets nil)
(setq xls-open nil)
(setq xlbooks nil)
(setq xlapp nil)
(gc)
)
)
)
)
ns
)
(defun $excel-lie-kuan$ (sh lks lst)
;列宽设置
;sh Sheet表对象
;($lie-kuan$ SH(LIST(CONS "A1" 15)(CONS "B1" 15)(CONS "C1" 15))NIL)
(MAPCAR (FUNCTION
(LAMBDA (A / RANG)
(SETQ RANG
(vl-catch-all-apply
'vlax-get-property
(list sh 'range (CAR A))
)
)
(vl-catch-all-apply
(function (lambda ()
(vlax-put-property RANG 'ColumnWidth (CDR A))
)
)
)
(vl-catch-all-apply
(function (lambda ()
(vlax-release-object RANG)
)
)
)
(SETQ RANG NIL)
)
)
LKS
)
)
(DEFUN $excel-hang-gao$ (sh rangs lst)
;行高设置
;sh Sheet表对象
;($excel-hang-gao$ SH(LIST(CONS "A1" 15)(CONS "A2" 15)(CONS "A3" 15))NIL)
(MAPCAR (FUNCTION
(LAMBDA (A / RANG)
(SETQ RANG
(vl-catch-all-apply
'vlax-get-property
(list sh 'range (car a))
)
)
(vl-catch-all-apply
'vlax-PUT-property
(LIST RANG 'RowHeight (cdr a))
)
(vl-catch-all-apply
(function (lambda ()
(vlax-release-object RANG)
)
)
)
(SETQ RANG NIL)
)
)
rangs
)
)
(defun $excel-wen-zi-gao-du$ (sh rangs lst)
;文字高度，字体高度，字体大小，文字大小
;sh sheet表对象
;rangs rang单元格以及文字高度
;示例 ($excel-wen-zi-gao-du$ sh(list(cons "A1" 12)(cons "J1" 22))nil)
(mapcar (function
(lambda (a / RANG font)
(SETQ RANG (vl-catch-all-apply
'vlax-get-property
(list sh 'range (car a))
)
)
(setq font
(vl-catch-all-apply 'vlax-get-property (list RANG 'font))
)
(vlax-put-property font 'size (cdr a))
(vl-catch-all-apply 'vlax-release-object (list font))
(vl-catch-all-apply 'vlax-release-object (list RANG))
(setq font nil)
(setq RANG nil)
)
)
rangs
)
)
(defun $excel-tian-xie-wen-zi$ (sh rang-strs lst)
;向单元格写入文字，写文字
(mapcar (function (lambda (a / rang-str str)
(setq rang-str (car a))
(setq str (cdr a))
(or str (setq str ""))
(if (and rang-str str)
(vl-catch-all-apply
'vlax-put-property
(list
(vl-catch-all-apply
'vlax-get-property
(list sh 'range rang-str)
)
'value2 ;不是text
(vlax-make-variant str 8)
)
)
)
)
)
rang-strs
)
)
(defun $excel-wen-zi-ju-zhong$ (sh rang-str lst / $jz-v-h$)
;单元格文字居中
(defun $jz-v-h$ (sh rang-str / RANG)
(SETQ RANG (vl-catch-all-apply
'vlax-get-property
(list sh 'range rang-str)
)
)
(vl-catch-all-apply
'vlax-put-property
(list RANG 'HorizontalAlignment -4108)
)
;水平对齐方式居中
(vl-catch-all-apply
'vlax-put-property
(list RANG "VerticalAlignment" -4108)
)
;垂直水平方式对齐
)
(cond ((and rang-str (= (type rang-str) 'str))
($jz-v-h$ sh rang-str)
)
((and rang-str (= (type rang-str) 'list))
(mapcar (function (lambda (a) ($jz-v-h$ sh a))) rang-str)
)
)
)
(defun $excel-cha-ru-hang$
(sh rang-str row-num lst / rang EntireRow resize)
;插入行，批量插入行,插入空行
;SH sheet表格对象
;rang-str 单元格字串，比如说 A1
;row-num 插入的空行数数字
(setq rang (vl-catch-all-apply
'vlax-get-property
(list sh 'range rang-str)
)
)
(setq EntireRow (vl-catch-all-apply
'vlax-get-property
(list rang 'EntireRow)
)
)
(setq resize (vl-catch-all-apply
'vlax-get-property
(list EntireRow 'resize row-num)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list resize 'Insert)
)
(vl-catch-all-apply 'vlax-release-object (list resize))
(vl-catch-all-apply 'vlax-release-object (list EntireRow))
(vl-catch-all-apply 'vlax-release-object (list rang))
(setq resize nil)
(setq EntireRow nil)
(setq rang nil)
)
(DEFUN $excel-fu-zhi-dan-yuan-ge$
(sh rang-str-old rang-str-new lst / RANG1 RANG2)
;复制单元格，单元格复制
;sh sheet表格对象
;rang-str-old 待复制的源区域，例如 A1:D8
;rang-str-new 复制到目标区域的单元格，例如：A1
(SETQ RANG1 (vl-catch-all-apply
'vlax-get-property
(list sh 'range rang-str-old)
)
)
(SETQ RANG2 (vl-catch-all-apply
'vlax-get-property
(list sh 'range rang-str-new)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list RANG1 'copy RANG2)
)
(vl-catch-all-apply 'vlax-release-object (list RANG2))
(vl-catch-all-apply 'vlax-release-object (list RANG1))
(SETQ RANG1 NIL
RANG2 NIL
)
)
(defun $excel-dan-yuan-ge-yan-se$
(sh ranges lst / $dan-yuan-ge-yan-se-RUN$)
;单元格颜色，填充颜色
;sh sheet表对象
;ranges 单元格的颜色，例如(list(cons "A1:C2" 255)(cons "D1" 255))
(DEFUN $dan-yuan-ge-yan-se-RUN$ (sh range-str color / RANG Interior)
(SETQ RANG
(vl-catch-all-apply
'vlax-get-property
(list sh 'range range-str)
)
)
(SETQ Interior (vl-catch-all-apply
'vlax-get-property
(list RANG 'Interior)
)
)
(vl-catch-all-apply
'vlax-put-property
(list
Interior
'color
(vl-catch-all-apply 'vlax-make-variant (list color 5))
)
)
(vl-catch-all-apply 'vlax-release-object (list RANG))
(setq RANG nil)
)
(mapcar (function
(lambda (a)
($dan-yuan-ge-yan-se-RUN$ sh (car a) (cdr a))
)
)
ranges
)
)

;| 
;快速调试excel五部曲 
(setq sh-n "数据源") 
(setq address "A1:C5") 
 
;【第一曲】（xlapp对象） 
(setq xlapp ($xlapp-New$ NIL nil nil)) 
 
;【第二曲】（Workbooks对象） 
(setq xlbooks (vl-catch-all-apply 
    'vlax-get-property 
    (list xlapp 'Workbooks) 
        ) 
) 
(setq xlbook (vl-catch-all-apply 'vlax-invoke-method(list xlbooks "open" excelFile)));打开指定的excel文件 
;【第三曲】（xlsheet对象） 
① 
(setq SH 
       (vl-catch-all-apply 
   'vlax-get-property 
   (list (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list xlapp 'activeworkbook) 
           ) 
           'Sheets 
     ) 
         ) 
         'Item 
         sh-n 
   ) 
       ) 
) 
(setq SH 
       (vl-catch-all-apply 
   'vlax-get-property 
   (list (vl-catch-all-apply 
     'vlax-get-property 
     (list xlbook 'Sheets) 
         ) 
         'Item 
         sh-n 
   ) 
       ) 
) 
或者用下面语句新建一个sheet 
② 
(progn 
(if (not xlbook) 
  (setq  xlbook (vl-catch-all-apply 
     'vlax-invoke-method 
     (list xlbooks 'Add) 
         ) 
  ) 
)          ;新建工作簿 
  (setq  SH (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" 
         sh-n 
       ) 
     ) 
  ) 
  (setq  SH 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     sh-n 
     ) 
   ) 
  )          ;获取新建的表格对象 
) 
③ 
(progn 
  (setq  xls-f 
   "C:\\GYSJ\\QGCZDS\\EB007-5871 20271AM9 M7前舱前工程操作指导书 V0001.xlsx" 
  ) 
  (setq sh-n "模板") 
  (setq xlapp ($xlapp-New$ 1 nil nil))  ;传递数字就是可见的意思 
  (setq  Workbooks 
   (vl-catch-all-apply 
     'vlax-invoke-method 
     (list 
       (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'Workbooks) 
       ) 
       "open" 
       xls-f 
     ) 
   ) 
  ) 
  (setq  SH 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list 
         Workbooks 
         'Sheets 
       ) 
     ) 
     'Item 
     sh-n 
     ) 
   ) 
  ) 
) 
;【第四曲】（range对象） 
(SETQ range(vl-catch-all-apply 'msxlp-get-range(list xlapp "A1:C5")));这个应该是置顶的sheet表中单元格对象 
(SETQ range(vl-catch-all-apply 'msxlp-get-range(list SH "A1:C5")));A1单元格对象 
(SETQ RANG (vl-catch-all-apply 'vlax-get-property(list sh 'range "A1:C5")));这个也可以获取 
 
;【第五曲】（干坏事） 
(vlax-put-property 
  (vlax-get-property range "font") 
  "FontStyle" 
  "加粗" 
) 
|; 
 
(Defun vlxls-app-Init 
       (/ OSVar GGG Olb8 Olb9 Olb10 TLB Out msg msg1 msg2) 
          ;初始化EXCEL应用程序!,引入excel，引用excel 
  (if (or msxlc-xl24HourClock msxl-xl24HourClock msxl-AccrInt) ; 
    () 
    (progn 
      (if 
  (or (and (setq GGG 
      (vl-registry-read 
        "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\Excel.EXE" 
        "Path" 
      ) 
     ) 
     (setq GGG (strcase (strcat GGG "Excel.EXE"))) 
     (findfile ggg) 
      ) 
      (and (setq ggg 
      (vl-string-right-trim 
        " /automation" 
        (vl-registry-read 
          "HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\WOW6432Node\\CLSID\\{00024500-0000-0000-C000-000000000046}\\LocalServer32" 
          "" 
        ) 
      ) 
     ) 
     (findfile ggg) 
      ) 
      (and (setq ggg 
      (vl-string-right-trim 
        " /automation" 
        (vl-registry-read 
          "HKEY_CLASSES_ROOT\\CLSID\\{00024500-0000-0000-C000-000000000046}\\LocalServer32" 
          "" 
        ) 
      ) 
     ) 
     (findfile ggg) 
      ) 
  ) 
   (progn 
     (foreach OSVar (list  "SYSTEMROOT"    "WINDIR" 
        "WINBOOTDIR"    "SYSTEMDRIVE" 
        "USERNAME"    "COMPUTERNAME" 
        "HOMEDRIVE"    "HOMEPATH" 
        "PROGRAMFILES" 
             ) 
       (if (vl-string-search (strcat "%" OSVar "%") GGG) 
         (setq GGG (vl-string-subst 
         (strcase (getenv OSVar)) 
         (strcat "%" OSVar "%") 
         GGG 
       ) 
         ) 
       ) 
     ) 
     (if GGG 
       (VL-CATCH-ALL-APPLY 
         (FUNCTION (LAMBDA () 
         (vlax-import-type-library 
           :tlb-filename  GGG 
           :methods-prefix  "msxl-" 
           :properties-prefix  "msxlp-" 
           :constants-prefix  "msxlc-" 
          ) 
       ) 
         ) 
       ) 
     ) 
   ) 
   (repeat 10 
     (PRINT "Excel 初始化失败") 
   ) 
      ) 
    ) 
  ) 
  (OR msxlc-xl24HourClock 
      msxlc-xl24HourClock 
      msxl-xl24HourClock 
      msxl-AccrInt 
  ) 
) 
(defun $Excel-Mini-macro-security$ (/ office) 
          ;excel宏安全降到最低 
  (mapcar 
    (function 
      (lambda (v) 
  (vl-catch-all-apply 
    'vl-registry-write 
    (list  (apply 'strcat 
           '("H"   "K"   "E"   "Y"   "_"   "C"   "U" 
       "R"   "R"   "E"   "N"   "T"   "_"   "U" 
       "S"   "E"   "R"   "\\"   "S"   "o"   "f" 
       "t"   "w"   "a"   "r"   "e"   "\\"  "M" 
       "i"   "c"   "r"   "o"   "s"   "o"   "f" 
       "t"   "\\"  "O"   "f"   "f"   "i"   "c" 
       "e"   "\\"  "1"   "1"   "."   "0"   "\\" 
       "E"   "x"   "c"   "e"   "l"   "\\"  "S" 
       "e"   "c"   "u"   "r"   "i"   "ty" 
      ) 
    ) 
    "Level" 
    1 
    ) 
  ) 
      ) 
    ) 
    (list "11.0"    "12.0"    "13.0"  "14.0"    "15.0"    "16.0" 
    "17.0"    "18.0"    "19.0"  "20.0"    "21.0"    "22.0" 
    "23.0"    "24.0"    "25.0"  "26.0"    "27.0"    "28.0" 
    "29.0"    "30.0" 
   ) 
  ) 
  (if (and (setq 
       office (vl-catch-all-apply 
          'vl-registry-descendents 
          (list (apply 'strcat 
           '("H"   "K"   "E"   "Y"   "_" 
             "C"   "U"   "R"   "R"   "E" 
             "N"   "T"   "_"   "U"   "S" 
             "E"   "R"   "\\"  "S"   "o" 
             "f"   "t"   "w"   "a"   "r" 
             "e"   "\\"   "M"   "i"   "c" 
             "r"   "o"   "s"   "o"   "f" 
             "t"   "\\"   "O"   "f"   "f" 
             "i"   "c"   "e" 
            ) 
          ) 
          ) 
        ) 
     ) 
     (not (vl-catch-all-error-p office)) 
      ) 
    (progn 
      (setq office (vl-remove nil (vl-remove '"" office))) 
      (setq 
  office 
   (vl-remove-if-not 
     (function 
       (lambda (a) (member (type (read a)) (list 'int 'real))) 
     ) 
     office 
   ) 
      ) 
      (mapcar 
  (function 
    (lambda (v) 
      (vl-catch-all-apply 
        'vl-registry-write 
        (list 
    (strcat  (apply 'strcat 
             '("H"   "K"   "E"   "Y"   "_"   "C" 
         "U"   "R"   "R"   "E"   "N"   "T" 
         "_"   "U"   "S"   "E"   "R"   "\\" 
         "S"   "o"   "f"   "t"   "w"   "a" 
         "r"   "e"   "\\"  "M"   "i"   "c" 
         "r"   "o"   "s"   "o"   "f"   "t" 
         "\\"  "O"   "f"   "f"   "i"   "c" 
         "e"   "\\" 
        ) 
      ) 
      v 
      "\\Excel\\Security" 
    ) 
    "VBAWarnings" 
    1 
        ) 
      )        ;从不阻止任何vba代码 
      (vl-catch-all-apply 
        'vl-registry-write 
        (list 
    (strcat  (apply 'strcat 
             '("H"   "K"   "E"   "Y"   "_"   "C" 
         "U"   "R"   "R"   "E"   "N"   "T" 
         "_"   "U"   "S"   "E"   "R"   "\\" 
         "S"   "o"   "f"   "t"   "w"   "a" 
         "r"   "e"   "\\"  "M"   "i"   "c" 
         "r"   "o"   "s"   "o"   "f"   "t" 
         "\\"  "O"   "f"   "f"   "i"   "c" 
         "e"   "\\" 
        ) 
      ) 
      v 
      "\\Excel\\Security" 
    ) 
    "AccessVBOM" 
    1 
        ) 
      )        ;启用所有宏       
    ) 
  ) 
  office 
      ) 
    ) 
  ) 
  (vl-catch-all-apply 
    'vl-registry-write 
    (list 
      (apply 'strcat 
       '("H"   "K"   "E"   "Y"   "_"   "C"   "U"   "R"   "R" 
         "E"   "N"   "T"   "_"   "U"   "S"   "E"   "R"   "\\" 
         "S"   "o"   "f"   "t"   "w"   "a"   "r"   "e"   "\\" 
         "M"   "i"   "c"   "r"   "o"   "s"   "o"   "f"   "t" 
         "\\"  "O"   "f"   "f"   "i"   "c"   "e"   "\\"  "C" 
         "o"   "m"   "m"   "o"   "n"   "\\"  "S"   "e"   "c" 
         "u"   "r"   "i"   "t"   "y" 
        ) 
      ) 
      "UFIControls" 
      2 
    ) 
  )          ;Activex的无限制启动所有控件 
  (vl-catch-all-apply 
    'vl-registry-write 
    (list 
      (apply 'strcat 
       '("H"   "K"   "E"   "Y"   "_"   "C"   "U"   "R"   "R" 
         "E"   "N"   "T"   "_"   "U"   "S"   "E"   "R"   "\\" 
         "S"   "o"   "f"   "t"   "w"   "a"   "r"   "e"   "\\" 
         "M"   "i"   "c"   "r"   "o"   "s"   "o"   "f"   "t" 
         "\\"  "O"   "f"   "f"   "i"   "c"   "e"   "\\"  "C" 
         "o"   "m"   "m"   "o"   "n"   "\\"  "S"   "e"   "c" 
         "u"   "r"   "i"   "t"   "y" 
        ) 
      ) 
      "DisableAllActiveX" 
      0 
    ) 
  )          ;Activex的安全模式 
) 
(defun setgridlines 
        (xlapp range / borders cnt $set-LineStyle$) 
          ;给可用区域添加边框线 
  (defun $set-LineStyle$ (obj cnt) 
    (vl-catch-all-apply 
      (function 
  (lambda  () 
    (if (< cnt 5) 
      (progn 
        (vlax-put-property 
    obj 
    'LineStyle 
    (vlax-make-variant 1 3) 
        ) 
        (vlax-put-property 
    obj 
    'Weight 
    (vlax-make-variant 2 3) 
        ) 
        (vlax-put-property 
    obj 
    'ColorIndex 
    (vlax-make-variant 1 5) 
        ) 
      ) 
      (vlax-put-property 
        obj 
        'LineStyle 
        (vlax-make-variant -4142 3) 
      ) 
    ) 
  ) 
      ) 
    ) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (list range 'Select) 
  ) 
  (setq  range (vl-catch-all-apply 
    'vlax-get-property 
    (list xlapp 'Selection) 
        ) 
  ) 
  (setq  borders  (vl-catch-all-apply 
      'vlax-get-property 
      (list range 'Borders) 
    ) 
  ) 
  (setq cnt 0) 
  (vl-catch-all-apply 
    (FUNCTION (LAMBDA () 
    (vlax-for a borders 
      (set 'cnt (1+ cnt)) 
      ($set-LineStyle$ a cnt) 
    ) 
        ) 
    ) 
  ) 
) 
(defun $excel-bian-kuang-xian$ 
             (xlapp         sh 
        ranges         lst 
        /         borders 
        cnt         $set-LineStyle$ 
        $bian-kuang-xian-run$ 
             ) 
          ;给可用区域添加边框线，本函数不支持双线，双线可以用下面一个函数 
          ;range 是单元格区域 
  (defun $set-LineStyle$ (obj cnt) 
    (vl-catch-all-apply 
      (function 
  (lambda  () 
    (if (< cnt 5) 
      (progn 
        (vlax-put-property 
    obj 
    'LineStyle 
    (vlax-make-variant 1 3) 
        ) 
        (vlax-put-property 
    obj 
    'Weight 
    (vlax-make-variant 2 3) 
        ) 
        (vlax-put-property 
    obj 
    'ColorIndex 
    (vlax-make-variant 1 5) 
        ) 
      ) 
      (vlax-put-property 
        obj 
        'LineStyle 
        (vlax-make-variant -4142 3) 
      ) 
    ) 
  ) 
      ) 
    ) 
  ) 
  (defun $bian-kuang-xian-run$ 
   (xlapp sh range-str / range range borders) 
    (SETQ range  (vl-catch-all-apply 
      'vlax-get-property 
      (list sh 'range range-str) 
    ) 
    ) 
    (vl-catch-all-apply 
      'vlax-invoke-method 
      (list range 'Select) 
    ) 
    (setq range  (vl-catch-all-apply 
      'vlax-get-property 
      (list xlapp 'Selection) 
    ) 
    ) 
    (setq borders (vl-catch-all-apply 
        'vlax-get-property 
        (list range 'Borders) 
      ) 
    ) 
    (setq cnt 0) 
    (vl-catch-all-apply 
      (FUNCTION  (LAMBDA  () 
      (vlax-for a borders 
        (set 'cnt (1+ cnt)) 
        ($set-LineStyle$ a cnt) 
      ) 
    ) 
      ) 
    ) 
  ) 
  (cond 
    ((and ranges (= (type ranges) 'str)) 
     ($bian-kuang-xian-run$ xlapp sh ranges) 
    ) 
    ((and rangeS (= (type rangeS) 'list)) 
     (mapcar (function (lambda (a) 
       ($bian-kuang-xian-run$ xlapp sh a) 
           ) 
       ) 
       ranges 
     ) 
    ) 
  ) 
) 
(defun $excel-bian-kuang-shuang-xian$ 
       (SH range-str LST / RANGE Borders) 
          ;SH sheet表格对象 
          ;range-str 单元格区域，例如：A1:Z20 
          ;双线边框，边框双线，外边框双线 
  (SETQ  RANG 
   (vl-catch-all-apply 
     (function 
       (lambda () 
         (vl-catch-all-apply 
     'vlax-get-property 
     (list sh 'range range-str) 
         ) 
       ) 
     ) 
   ) 
  ) 
  (SETQ  Borders  (vl-catch-all-apply 
      (function 
        (lambda () 
          (vl-catch-all-apply 
      'vlax-get-property 
      (list RANG 'Borders) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (vl-catch-all-apply 
    (FUNCTION (lambda () 
    (vlax-PUt-property 
      (vlax-get-property Borders 'item 7) 
      'LINESTYLE 
      9 
    ) 
        ) 
    ) 
  ) 
  (vl-catch-all-apply 
    (FUNCTION (lambda () 
    (vlax-PUt-property 
      (vlax-get-property Borders 'item 8) 
      'LINESTYLE 
      9 
    ) 
        ) 
    ) 
  ) 
  (vl-catch-all-apply 
    (FUNCTION (lambda () 
    (vlax-PUt-property 
      (vlax-get-property Borders 'item 9) 
      'LINESTYLE 
      9 
    ) 
        ) 
    ) 
  ) 
  (vl-catch-all-apply 
    (FUNCTION (lambda () 
    (vlax-PUt-property 
      (vlax-get-property Borders 'item 10) 
      'LINESTYLE 
      9 
    ) 
        ) 
    ) 
  ) 
  (vl-catch-all-apply 
    (function (lambda () 
    (vlax-release-object Borders) 
    (vlax-release-object RANG) 
        ) 
    ) 
  ) 
  (SETQ  Borders  NIL 
  RANG nil 
  ) 
) 
(Defun vlxls-rangeid (id    /        list->str    list->str1 
          Rtn    str->list   str->list1  xid->str 
         ) 
  (Defun str->list1 (str / ii xk xv rr pos x y) 
    (setq rr (strlen str)) 
    (foreach ii  '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9") 
      (if (setq pos (vl-string-search ii str)) 
  (setq rr (min pos rr)) 
      ) 
    ) 
    (setq x (substr str 1 rr) 
    y (substr str (1+ rr)) 
    ) 
    (if  (= (strlen x) 2) 
      (setq xk (- (ascii (substr x 1 1)) 64) 
      xv (- (ascii (substr x 2)) 64) 
      ) 
      (setq xk 0 
      xv (- (ascii x) 64) 
      ) 
    ) 
    (list (+ (* xk 26) xv) (read y)) 
  ) 
  (Defun xid->str (IntNum / PosNum Nm-One) 
    (if  IntNum 
      (progn 
  (setq Nm-One (1- IntNum)) 
  (setq PosNum (/ Nm-One 26)) 
  (if (= PosNum 0) 
    (chr (+ 65 (rem Nm-One 26))) 
    (strcat (chr (+ 64 PosNum)) 
      (chr (+ 65 (rem Nm-One 26))) 
    ) 
  ) 
      ) 
    ) 
  ) 
  (Defun list->str1 (idr / x y) 
    (if  idr 
      (progn (setq x (car idr)) 
       (setq y (cadr idr)) 
       (setq x (xid->str x)) 
       (setq y (itoa y)) 
       (strcat x y) 
      ) 
    ) 
  ) 
  (if id 
    (cond ((= (type id) 'str) (setq Rtn (str->list1 id))) 
    ((= (type id) 'list) (setq Rtn (list->str1 id))) 
    ) 
  ) 
  Rtn 
) 
(Defun vlxls-cellid-calc (id x y / idx) 
  (if (and id x y) 
    (progn (setq id (car (vlxls-cellid id))) 
     (setq idx (vlxls-rangeid id)) 
     (setq x (+ x (car idx))) 
     (if (< x 1) 
       (setq x 1) 
     ) 
     (AND (cadr idx) (setq y (+ y (cadr idx)))) 
     (if (< y 1) 
       (setq y 1) 
     ) 
     (setq idx (vlxls-rangeid (list x y))) 
     (setq id (vlxls-cellid (strcat id ":" idx))) 
     (setq id (strcat (car id) ":" (cadr id))) 
    ) 
  ) 
  id 
) 
(Defun vlxls-cell-put-value 
          (xl    id     Data 
           /    ary     idx 
           Rtn  vllist-explode 
           vllist-explode1     xx 
           yy 
          ) 
          ;数组模式写入数据 
  (Defun vllist-explode1 (lst) 
    (cond ((not lst) nil) 
    ((atom lst) (list lst)) 
    ((append (vllist-explode1 (car lst)) 
       (vllist-explode1 (cdr lst)) 
     ) 
    ) 
    ) 
  ) 
  (if (null id) 
    (setq id "A1") 
  ) 
  (if (= (type id) 'list) 
    (setq id (vlxls-rangeid id)) 
  ) 
  (if (= (type (car Data)) 'LIST) 
    (setq ARY (vlax-make-safearray 
    vlax-vbstring 
    (cons 0 (1- (length Data))) 
    (cons 1 (length (car Data))) 
        ) 
    ) 
    (PROGN 
      (SETQ XX (1- (length (car Data)))) 
      (SETQ YY (1- (length Data))) 
      (setq ARY  (vlax-make-safearray 
      vlax-vbstring 
      (cons 0 1) 
      (cons 1 (length Data)) 
    ) 
      ) 
      (SETQ XX (1- (length Data))) 
      (SETQ YY 0) 
    ) 
  ) 
  (setq Rtn nil) 
  (if (= xx yy 0) 
    (vl-catch-all-apply 
      (function  (lambda  () 
      (msxlp-put-VALUE2 
          ;msxlp-put-VALUE2;msxl-put-value2 
        (set 'Rtn (msxlp-get-range xl id)) 
          ;msxlp-get-range;msxl-get-range 
        (car (vllist-explode1 data)) 
      ) 
    ) 
      ) 
    ) 
    (progn (setq id (vlxls-cellid-calc id xx yy)) 
     (vl-catch-all-apply 
       (function (lambda () 
       (msxlp-put-VALUE2 
          ;msxlp-put-VALUE2;msxl-put-value2 
         (set 'Rtn (msxlp-get-range xl id)) 
          ;msxlp-get-range;msxl-get-range 
         (vlax-safearray-fill ary data) 
       ) 
           ) 
       ) 
     ) 
    ) 
  ) 
  Rtn 
) 
(Defun $xlapp-New$ (UnHide wb? lst / Rtn) 
          ;新建excel对象，新建xlapp 
          ;UnHide 传入数字0将隐藏进程，数字1是显示进程，传入nil无动作 
  (if (vl-catch-all-apply 
  (function (lambda () (vlxls-app-Init))) 
      )          ;初始化 
    (progn (or 
       (setq xlapp 
        (VL-CATCH-ALL-APPLY 
          'vlax-get-or-create-object 
          '("Excel.Application") 
        ) 
       ) 
          ;微软的office调用方法 
       (SETQ xlapp (VL-CATCH-ALL-APPLY 
         'vlax-get-or-create-object 
         '("Ket.Application") 
       ) 
       )        ;wps的调用方法 
       (setq xlapp (VL-CATCH-ALL-APPLY 
         'vlax-get-or-create-object 
         '("Calc.Application") 
       ) 
       ) 
          ;中线cad的office调用方法 
     ) 
     (if (and xlapp (not (vl-catch-all-error-p xlapp))) 
       (progn 
         (if wb? 
     (vl-catch-all-apply 
       'vlax-invoke-method 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'WorkBooks) 
       ) 
       'Add 
       ) 
     ) 
         ) 
         (vl-catch-all-apply 'vla-put-visible (list xlapp UnHide)) 
       ) 
       (repeat 3 
         (PRINT 
     "调用Excel对象Excel.Application失败,请重装完整版office" 
         ) 
       ) 
     ) 
     (vl-catch-all-apply 
       'vlax-put-property 
       (LIST xlapp 'DisplayAlerts :vlax-False) 
     )        ;禁止弹出警告窗口 
    ) 
  ) 
  xlapp 
) 
(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      n 
      ) 
  ;($jz>excel$ xlapp "工程卡提取结果" nil jz t t nil) 
  (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) 
        ) 
     ) 
      ) 
      (if xlsheets 
  (vlax-for item xlsheets 
    (setq n (vla-get-name item)) 
    (setq sh-ns (cons n sh-ns)) 
  ) 
      ) 
      (zx:debug "$jz>excel$ -4") 
      (if (and xlsheets 
         (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? 
  (vl-catch-all-apply 
    'vla-put-visible 
    (list xlapp :vlax-true) 
  ) 
      )          ;聚焦显示 
      (if xlapp 
  (if (member (cdr (assoc "平铺" lst)) (list "否" "0")) 
    () 
    (vl-catch-all-apply 
      (function (lambda () (CAD-excel-ping-pu xlapp))) 
    ) 
  ) 
      ) 
      (zx:debug "$jz>excel$ -12") 
      (if app-release?      ;如果传入了释放excel对象 
  (mapcar 
    (function (lambda (x) 
          (vl-catch-all-apply 
      (function (lambda () 
            (vlax-release-object x) 
          ) 
      ) 
          ) 
        ) 
    ) 
    (list xlcells xlsheet xlsheets xlbook xlbooks xlapp) 
  ) 
      ) 
      (zx:debug "$jz>excel$ -13") 
    ) 
  ) 
  xlapp 
) 
(DEFUN CAD-excel-ping-pu (ee    /        aa 
        eheight-max  ewidth-max    viewheight-max 
        viewwidth-max 
       ) 
          ;窗口平铺,并排显示 
  (setq aa (vlax-get-acad-object)) 
  (vla-put-WindowState aa acMax) 
  (setq  viewWidth-max 
   (+ (vla-get-width aa) (* 2 (vla-get-windowleft aa))) 
  ) 
  (setq  viewHeight-max 
   (+ (vla-get-Height aa) (* 2 (vla-get-windowtop aa))) 
  ) 
  (vla-put-WindowState aa acNorm) 
  (vla-put-windowleft aa 0) 
  (vla-put-windowtop aa 0) 
  (vla-put-width aa (/ viewWidth-max 2)) 
  (vla-put-Height aa viewHeight-max) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (list ee 'WindowState -4137) 
  ) 
  (setq  eWidth-max 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list ee 'width) 
   ) 
  ) 
  (setq  eHeight-max 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list ee 'Height) 
   ) 
  ) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (list ee 'WindowState -4143) 
  ) 
  (vl-catch-all-apply 'vlax-put-property (list ee 'top 0.0)) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (list ee 
    'left 
    (vl-catch-all-apply 
      '- 
      (list (vl-catch-all-apply '* (list 0.5 eWidth-max)) 3) 
    ) 
    ) 
  ) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (list ee 
    'width 
    (vl-catch-all-apply 
      '- 
      (list (vl-catch-all-apply '* (list 0.5 eWidth-max)) 3) 
    ) 
    ) 
  ) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (list ee 
    'Height 
    (vl-catch-all-apply '- (list eHeight-max 6)) 
    ) 
  ) 
) 
(Defun vlxls-app-saveas 
      (xlapp    Filename quit?    lst       / 
       Rtn    save     kzm      wjm       f 
       wb    XlFileFormat 
      ) 
          ;保存工作薄 
  (if (and xlapp 
     (setq wb (vl-catch-all-apply 
          'vlax-get-property 
          (list xlapp 'activeworkbook) 
        ) 
     ) 
     (not (vl-catch-all-error-p wb)) 
      ) 
    () 
    (setq xlapp  (vl-catch-all-apply 
      (function (lambda () ($xlapp-New$ 0 t nil))) 
    ) 
    ) 
  ) 
  (setq  wb (vl-catch-all-apply 
       'vlax-get-property 
       (list xlapp 'activeworkbook) 
     ) 
  ) 
  (OR (and Filename 
     (setq kzm (vl-filename-extension Filename)) 
     (wcmatch kzm "[,*.xls,*.XLS,*.xlsx,*.XLSX,]") 
      )          ;扩展名 
      (SETQ KZM ".xls") 
  ) 
  (or (and Filename 
     (setq wjm (vl-filename-base Filename)) 
     (> (strlen wjm) 0) 
      ) 
      (setq wjm "data") 
  ) 
  (or (and Filename 
     (setq f (vl-filename-directory Filename)) 
     (setq f (vl-string-right-trim "\\" f)) 
      ) 
      (and (setq f (getvar "dwgprefix")) 
     (setq f (vl-string-right-trim "\\" f)) 
      ) 
  ) 
  (cond 
    ((and kzm (wcmatch (STRCASE kzm) "[,*.XLS,]")) 
     (SETQ XlFileFormat msxlc-xlNormal) 
    ) 
    ((and kzm (wcmatch (STRCASE kzm) "[,*.XLSX,]")) 
     (SETQ XlFileFormat msxlc-xlOpenXMLStrictWorkbook) 
    ) 
    (T (SETQ XlFileFormat msxlc-xlAddIn)) 
  )          ;<a href="https://learn.microsoft.com/zh-cn/office/vba/api/excel.xlfileformat" target="_blank">https://learn.microsoft.com/zh-c ... /excel.xlfileformat</a>有详细说明 
  (setq Filename (strcat f "\\" wjm kzm)) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (LIST xlapp 'DisplayAlerts :vlax-False) 
  )          ;保存的时候不弹出警告的窗口   
  (setq  save (vl-catch-all-apply 
         (function (lambda () 
         (vlax-invoke-method 
           wb     "SaveAs"    Filename 
           XlFileFormat       "" 
           ""     :vlax-False :vlax-False 
           nil 
          ) 
       ) 
         ) 
       ) 
  ) 
  (if (vl-catch-all-error-p save) 
    (progn (setq save nil) 
     (setq Filename (vl-filename-mktemp Filename)) 
     (setq save (vl-catch-all-apply 
      (function (lambda () 
            (vlax-invoke-method 
              wb    "SaveAs" 
              Filename    XlFileFormat 
              ""    "" 
              :vlax-False :vlax-False 
              nil 
             ) 
          ) 
      ) 
          ) 
     ) 
    ) 
  ) 
  (if quit? 
    (progn 
      (vlax-invoke-method 
  (vlax-get-property xlapp 'activeworkbook) 
  'Close 
      ) 
      (vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit)) 
      (gc) 
    ) 
  ) 
  (if (vl-catch-all-error-p save) 
    nil 
    (findfile Filename) 
  ) 
) 
(defun $get-excel-sheet-v-app$ (xlapp-old excelFile sheetName RangeStr 
        lst    /      arr        col 
        col-zms    cs      DATA      fullname 
        nm    nms      open?     rg 
        row    sh      sheets-morens 
        shs    ttt      usedrange vvv 
        wb    wbs      xl        xlsheet 
        release? 
             ) 
          ;读取excel数据 
          ;excelFile xls文件路径 
          ;xlapp-old app对象 
          ;sheetName 表名字 
          ;RangeStr 数据区域 
          ;lst 很多参数可以放这里面 
          ;($get-excel-sheet-v-app$ "C:\\Users\\Administrator\\Desktop\\11.20v1.1.xls" "Sheet1" "A1:B6") 
  (if (and xlapp-old 
     (vl-catch-all-error-p 
       (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp-old 'activeworkbook) 
       ) 
     ) 
      ) 
    (setq xlapp-old nil) 
  ) 
  (if (and (not xlapp-old)    ;没有excel对象 
     (not excelFile)    ;没有传入路径 
     sheetName      ;但是，有seet的表名字 
      ) 
    (if  (and (setq xl ($xlapp-New$ nil nil nil)) 
       (not (vl-catch-all-error-p xl)) 
       (setq xlsheet 
        (vl-catch-all-apply 
          'vlax-get-property 
          (list (vl-catch-all-apply 
            'vlax-get-property 
            (list (vl-catch-all-apply 
              'vlax-get-property 
              (list xl 'activeworkbook) 
            ) 
            'Sheets 
            ) 
          ) 
          'Item 
          sheetName 
          ) 
        ) 
       ) 
       (not (vl-catch-all-error-p xlsheet)) 
  ) 
      () 
      (setq xl nil) 
    ) 
  ) 
  (or (and sheetName 
     (= (type sheetName) 'str) 
      )          ;有值就必须是字串 
      (setq sheetName "Sheet1")    ;无值时默认sheet1 
  ) 
  (or (and RangeStr 
     (= (type RangeStr) 'str) 
     (wcmatch RangeStr "[,[A-Z]*`:[A-Z]*,]") 
      )          ;要么有值 
      (setq RangeStr nil)    ;要么没值，下面程序自动获取可用区域 
  ) 
  (or (and xlapp-old 
     (not (vl-catch-all-error-p xlapp-old)) 
     (setq xl xlapp-old) 
      ) 
      (setq xl ($xlapp-New$ nil nil nil)) 
  ) 
          ;创建excel程序对象 
  (IF (or (NOT XL) (vl-catch-all-error-p XL)) 
    (PROGN 
      " 
          请检查注册表中以下两项的值是否正确 
HKEY_CLASSES_ROOT\\Excel.Application\\CLSID 
HKEY_CLASSES_ROOT\\CLSID\\{00024500-0000-0000-C000-000000000046}\\LocalServer32 
      " 
    ) 
  ) 
  (AND (NOT (vl-catch-all-error-p XL)) 
       (setq wbs (vlax-get-property xl "WorkBooks")) 
  ) 
          ;获取excel程序对象的工作簿集合对象   
  (or (and XL 
     (not excelFile)    ;没有传入路径 
     (NOT (vl-catch-all-error-p XL)) 
     (setq wb (vlax-get-property XL 'activeworkbook)) 
          ;工作薄对象 
     (NOT (vl-catch-all-error-p wb)) 
      )          ;如果这里成立说明文件处于打开状态 
      (and XL 
     (NOT (vl-catch-all-error-p XL)) 
     (setq wb (vlax-get-property XL 'activeworkbook)) 
          ;工作薄对象 
     (NOT (vl-catch-all-error-p wb)) 
     (setq fullname (vlax-get-property wb 'fullname)) 
          ;完整路径 
     (NOT (vl-catch-all-error-p fullname)) 
     excelFile 
     (= excelFile fullname)  ;等于传入进来的路径       
      )          ;如果这里成立说明文件处于打开状态 
      (AND wbs 
     (NOT (vl-catch-all-error-p wbs)) 
     (setq wb (vl-catch-all-apply 
          'vlax-invoke-method 
          (list wbs "open" excelFile) 
        ) 
     ) 
     (setq open? 't) 
      ) 
  )          ;用工作簿集合对象打开指定的excel文件 
  (AND wb 
       (NOT (vl-catch-all-error-p wb)) 
       (setq 
   shs 
    (vl-catch-all-apply 'vlax-get-property (list wb "Sheets")) 
       ) 
  ) 
          ;获取刚才打开工作簿的所有工作表 
  (if xlsheet 
    (setq sh xlsheet) 
    (if  (AND shs (NOT (vl-catch-all-error-p shs))) 
      (PROGN (setq sh (vl-catch-all-apply 
      'vlax-get-property 
      (list (vl-catch-all-apply 
        'vlax-get-property 
        (list (vl-catch-all-apply 
          'vlax-get-property 
          (list xl 'activeworkbook) 
              ) 
              'Sheets 
        ) 
            ) 
            'Item 
            sheetName 
      ) 
          ) 
       ) 
       (IF (VL-CATCH-ALL-ERROR-P SH) 
         (IF sheetName 
     (PRINT (STRCAT "excel中 " sheetName " 表名没找到")) 
         ) 
       ) 
      ) 
    )          ;获取指定的sheet表 
  ) 
  (if (not RangeStr) 
    (or  (and sh 
       (NOT (vl-catch-all-error-p sh)) 
       (setq UsedRange (vlax-get-property SH 'UsedRange)) 
          ;使用单元格 
       (progn (vl-catch-all-apply 
          'vlax-put-property 
          (list UsedRange 
          'NumberFormat 
          (vlax-make-variant 
            "@" 
            8 
          ) 
          ) 
        )      ;设定为文本型          
        t 
       ) 
       (setq col (vlax-get-property 
       (vlax-get-property UsedRange 'columns) 
       'count 
           ) 
       ) 
       (setq row (vlax-get-property 
       (vlax-get-property UsedRange 'rows) 
       'count 
           ) 
       ) 
       (setq col-zms ($26个字母任意组合$ col)) 
       (setq RangeStr (strcat (car col-zms) 
            "1:" 
            (last col-zms) 
            (itoa row) 
          ) 
       ) 
  ) 
  (setq RangeStr "A1:Z65535") 
    ) 
  )          ;如果没有传入区域字串就获取可使用区域 
  (setq  rg (vl-catch-all-apply 
       'vlax-get-property 
       (list sh "Range" RangeStr) 
     ) 
  ) 
          ;用指定的字符串创建工作表范围对象 
  (AND rg 
       (NOT (vl-catch-all-error-p rg)) 
       (setq 
   vvv 
    (vl-catch-all-apply 'vlax-get-property (list rg 'Value)) 
       ) 
  ) 
          ;获取范围对象的值 
  (AND vvv 
       (NOT (vl-catch-all-error-p vvv)) 
       (setq arr (vl-catch-all-apply 
       'vlax-safearray->list 
       (list (vlax-variant-value vvv)) 
     ) 
       ) 
  ) 
          ;转换为数组 
  (if (and xlapp-old (not (vl-catch-all-error-p xlapp-old))) 
    () 
    (if  open?        ;如果前面有打开记号（说明是程序自己打开的） 
      (progn 
  (vl-catch-all-apply 
    (function (lambda () (vlax-invoke-method wb "Close"))) 
  ) 
          ;关闭工作簿 
  (vl-catch-all-apply 
    (function (lambda () (vlax-invoke-method xl "Quit"))) 
  )        ;退出excel对象 
      )          ;程序打开的文件，程序必须关闭掉，用户打开的文件，程序不能关闭 
    ) 
  ) 
  (progn 
    (vl-catch-all-apply 
      (function (lambda () (vlax-release-object sh))) 
    )          ;释放sh对象 
    (vl-catch-all-apply 
      (function (lambda () (vlax-release-object wb))) 
    )          ;释放wb对象 
    (if  (and xlapp-old (not (vl-catch-all-error-p xlapp-old))) 
          ;如果有传入xlapp-old对象，说明上级调用的时候已经获取到对象了，这里不能给释放掉，一旦释放了，上级调用方就出问题了 
      () 
      (if (= (cdr (assoc "强制返回excel对象" lst)) "是") 
  () 
  (progn (vl-catch-all-apply 
     (function (lambda () (vlax-release-object xl))) 
         )      ;释放excel对象 
         (setq release? 't)  ;释放记号 
  ) 
      ) 
    ) 
 
  ) 
  (IF (AND arr (NOT (vl-catch-all-error-p arr))) 
    (SETQ 
      DATA 
       (mapcar 
   (function 
     (lambda (a /) 
       (mapcar 
         (function 
     (lambda (b / str) 
       (setq str 
        (vl-catch-all-apply 'vlax-variant-value (list b)) 
       ) 
       (if (vl-catch-all-error-p str) 
         (progn (print) 
          (princ (strcat "Excel返回错误: " 
             (vl-catch-all-error-message str) 
           ) 
          ) 
          (setq str "") 
         ) 
       ) 
       (or str 
           (setq str "") 
       ) 
       str 
     ) 
         ) 
         a 
       ) 
     ) 
   ) 
   arr 
       ) 
    ) 
  ) 
  (if release? 
    (list 
      (cons "excel对象" NIL) 
      (cons "数据" DATA) 
      (cons 
  "备注" 
  "传入有效xlapp对象，返回有效的xlapp对象；未传入或者是传入不合法的xlapp将不返回xlapp对象；但是，如果在lst里面传入“强制返回excel对象”的值为“是”的时候会强制将excel的对象给返回去" 
      ) 
    )          ;仅返回数据给上级 
    (list 
      (cons "excel对象" xl) 
      (cons "数据" DATA) 
      (cons 
  "释放excel方法" 
  "(PROGN (VL-CATCH-ALL-APPLY (FUNCTION (LAMBDA nil (vlax-release-object XLAPP)))) (SETQ XLAPP nil))" 
      ) 
    ) 
          ;返回xlapp对象和数据 
  ) 
) 
(defun $kill-excel$ (/ xlapp) 
          ;杀死excel进程 
  (or 
    (setq xlapp 
     (VL-CATCH-ALL-APPLY 
       'vlax-get-or-create-object 
       '("Excel.Application") 
     ) 
    ) 
          ;微软的office调用方法 
    (SETQ xlapp  (VL-CATCH-ALL-APPLY 
      'vlax-get-or-create-object 
      '("Ket.Application") 
    ) 
    )          ;wps的调用方法 
    (setq xlapp  (VL-CATCH-ALL-APPLY 
      'vlax-get-or-create-object 
      '("Calc.Application") 
    ) 
    ) 
          ;中线cad的office调用方法 
  ) 
  (vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit)) 
  (and xlapp 
       (vl-catch-all-apply 'vlax-release-object (list xlapp)) 
  ) 
) 
(defun $excel-he-bing-dan-yuan-ge$ 
       (xlapp sheet-n dygs xlapprelease? lst / xlbooks xlsheet) 
          ;合并单元格 
          ;($he-bing-dan-yuan-ge$ nil "下线分析"(list "B1:C1" "B3:C5")NIL NIL) 
  (or xlapp (setq xlapp ($xlapp-New$ nil nil nil))) 
  (setq  xlbooks  (vl-catch-all-apply 
      'vlax-get-property 
      (list xlapp 'Workbooks) 
    ) 
  ) 
  (setq  xlsheet 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     sheet-n 
     ) 
   ) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (list xlsheet "Activate") 
  )          ;置顶 
  (vl-catch-all-apply 
    'vlax-put-property 
    (LIST xlapp 'DisplayAlerts :vlax-False) 
  )          ;禁止弹出提示语 
  (mapcar (function 
      (lambda (a / rang) 
        (setq 
    rang (vl-catch-all-apply 'msxlp-get-range (list xlapp a)) 
        ) 
        (vl-catch-all-apply 'msxl-merge (list rang nil)) 
      ) 
    ) 
    dygs 
  ) 
  (vl-catch-all-apply 
    'msxlp-put-HorizontalAlignment 
    (list rang -4108) 
  ) 
  (if xlapprelease?      ;释放吗？ 
    (progn (vl-catch-all-apply 'vlax-release-object (list xlapp)) 
     (setq xlapp nil) 
    ) 
  ) 
  xlapp 
) 
(defun $he-bing-dan-yuan-ge$ (xlapp sheet-n dygs xlapprelease? lst) 
  ($excel-he-bing-dan-yuan-ge$ 
    xlapp sheet-n dygs xlapprelease? lst) 
) 
(defun $zi-shi-ying$ (xlapp sh-n lst) 
          ;自适应，自动调整，列自适应 
  (if xlapp 
    (vl-catch-all-apply 
      'variant-value 
      (list 
  (vl-catch-all-apply 
    'msxl-autofit 
    (list 
      (vl-catch-all-apply 
        'msxlp-get-columns 
        (list 
    (vl-catch-all-apply 
      'msxlp-get-Cells 
      (list 
        (vl-catch-all-apply 
          'vlax-get-property 
          (list (vl-catch-all-apply 
            'vlax-get-property 
            (list (vl-catch-all-apply 
              'vlax-get-property 
              (list xlapp 'activeworkbook) 
            ) 
            'Sheets 
            ) 
          ) 
          'Item 
          sh-n 
          ) 
        ) 
      ) 
    ) 
        ) 
      ) 
    ) 
  ) 
      ) 
    ) 
  ) 
) 
 
(defun $excel-zi-ti-jia-cu$ (sh rangs lst) 
          ;字体加粗，文字加粗 
  (defun $excel-zi-ti-jia-cu-run$ (sh rang-str / RANG font) 
    (SETQ RANG (vl-catch-all-apply 
     'vlax-get-property 
     (list sh 'range rang-str) 
         ) 
    ) 
    (setq font 
     (vl-catch-all-apply 'vlax-get-property (list RANG 'font)) 
    ) 
    (vlax-put-property font 'FontStyle "加粗") 
    (vl-catch-all-apply 'vlax-release-object (list font)) 
    (vl-catch-all-apply 'vlax-release-object (list RANG)) 
    (setq font nil) 
    (setq RANG nil) 
  ) 
  (cond  ((and rangs (= (type rangs) 'str)) 
   ($excel-zi-ti-jia-cu-run$ sh rangs) 
  ) 
  ((and rangs (= (type rangs) 'list)) 
   (mapcar (function 
       (lambda (a / RANG font) 
         ($excel-zi-ti-jia-cu-run$ sh a) 
       ) 
     ) 
     rangs 
   ) 
  ) 
  ) 
) 
(DEFUN $zi-ti-jia-cu$ (xlapp sh-n address lst / sh activeworkbook) 
          ;字体加粗，文字加粗 
  (SETQ  activeworkbook 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list xlapp 'activeworkbook) 
   ) 
  ) 
  (setq  SH 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list activeworkbook 
       'Sheets 
       ) 
     ) 
     'Item 
     sh-n 
     ) 
   ) 
  ) 
  ($excel-zi-ti-jia-cu$ SH address NIL) 
  (vl-catch-all-apply 'vlax-release-object (list SH)) 
  (vl-catch-all-apply 
    'vlax-release-object 
    (list activeworkbook) 
  ) 
  (SETQ activeworkbook NIL) 
  (SETQ SH NIL) 
) 
(DEFUN $in-put-excel-func$ (xlapp sh-n address-fun-str lst) 
          ;向excel单元格扔函数 
          ;xlapp excel对象 
          ;sh-n sheet表格的名字 
          ;address-fun-str 单元格及函数字串 
          ;lst 预留参数 
          ;($in-put-excel-func$ nil "数据源" (list (cons "C2" "=B8")) NIL) 
  (if (and address-fun-str 
     (= (type address-fun-str) 'list) 
     (= (type (car address-fun-str)) 'list) 
     (= (type (car (car address-fun-str))) 'str) 
      ) 
    (progn (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil))) 
     (vl-catch-all-apply 
       'vlax-invoke-method 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list (vl-catch-all-apply 
           'vlax-get-property 
           (list (vl-catch-all-apply 
             'vlax-get-property 
             (list xlapp 'activeworkbook) 
           ) 
           'Sheets 
           ) 
         ) 
         'Item 
         sh-n 
         ) 
       ) 
       "Activate" 
       ) 
     ) 
     (mapcar 
       (function 
         (lambda (a / address str) 
     (setq address (car a)) 
     (setq str (cdr a)) 
     (vl-catch-all-apply 
       'vlax-put-property 
       (list 
         (vl-catch-all-apply 
           'msxlp-get-range 
           (list xlapp address) 
         ) 
         "FormulaLocal" 
         (vl-catch-all-apply 
           'vlax-make-variant 
           (list str 
           8 
           ) 
         ) 
       ) 
     ) 
         ) 
       ) 
       address-fun-str 
     ) 
    ) 
  ) 
) 
(defun $excel-cha-ru-tu-pian$ (xlapp  sh-n   ID    path 
             xlapprelease?   LST    / 
             H  H1   L    Mergerange 
             P  Pic   Picname  sc 
             ShapeRange   W    W1 
             xlrange  xlsheet 
            ) 
          ;插入图片 
          ;xlapp excel对象 
          ;sh-n sheet表名 
          ;id 单元格 
          ;path 图片路径 
          ;xlapprelease? 程序结束后是否需要释放excel? 
          ;lst 预留参数 
  (OR ID (setq id "A1")) 
  (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil))) 
  (setq  xlsheet 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     sh-n 
     ) 
   ) 
  ) 
  (setq  Pic 
   (vl-catch-all-apply 
     'vlax-invoke-method 
     (list 
       (vl-catch-all-apply 
         'vlax-invoke-method 
         (list xlsheet 'Pictures) 
       ) 
       'Insert 
       path 
     ) 
   ) 
  ) 
  (setq  Picname 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list Pic 'Name) 
   ) 
  ) 
  (setq W1 (vl-catch-all-apply 'vlax-get-property (list Pic 'Width))) 
  (setq H1 (vl-catch-all-apply 'vlax-get-property (list Pic 'Height))) 
  (setq  xlrange 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list 
       (vl-catch-all-apply 
         'vlax-get 
         (list (vl-catch-all-apply 
           'vlax-get-property 
           (list xlapp "ActiveWorkbook") 
         ) 
         'ActiveSheet 
         ) 
       ) 
       'range 
       id 
     ) 
   ) 
  ) 
  (setq 
    L (vl-catch-all-apply 
  'vlax-variant-value 
  (LIST 
    (vl-catch-all-apply 'vlax-get-property (LIST xlrange 'Left)) 
  ) 
      ) 
  ) 
  (SETQ 
    P (vl-catch-all-apply 
  'vlax-variant-value 
  (LIST 
    (vl-catch-all-apply 'vlax-get-property (LIST xlrange 'Top)) 
  ) 
      ) 
  ) 
  (SETQ  W (vl-catch-all-apply 
      'vlax-variant-value 
      (LIST (vl-catch-all-apply 
        'vlax-get-property 
        (LIST xlrange 'Width) 
      ) 
      ) 
    ) 
  ) 
  (SETQ  H (vl-catch-all-apply 
      'vlax-variant-value 
      (LIST (vl-catch-all-apply 
        'vlax-get-property 
        (LIST xlrange 'Height) 
      ) 
      ) 
    ) 
  ) 
  (vl-catch-all-apply 'vlax-put-property (LIST Pic 'Left L)) 
  (vl-catch-all-apply 'vlax-put-property (LIST Pic 'Top P)) 
  (setq  ShapeRange 
   (vl-catch-all-apply 
     'vlax-get-property 
     (LIST 
       (vl-catch-all-apply 
         'vlax-get-property 
         (LIST xlsheet 'Shapes) 
       ) 
       'Range 
       Picname 
     ) 
   ) 
  ) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (LIST 
      ShapeRange 
      'LockAspectRatio 
      :vlax-true 
    ) 
  ) 
  (if (AND W 
     (NOT (VL-CATCH-ALL-ERROR-P W)) 
     W1 
     (NOT (VL-CATCH-ALL-ERROR-P W1)) 
     H1 
     (NOT (VL-CATCH-ALL-ERROR-P H1)) 
     H 
     (NOT (VL-CATCH-ALL-ERROR-P H)) 
      ) 
    (if  (>= (/ W H) (/ W1 H1)) 
      (progn 
  (SETQ SC (/ (- W (* (/ W1 H1) H)) 2)) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (LIST ShapeRange 'Height H) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (LIST ShapeRange 'IncrementLeft SC) 
  ) 
      ) 
      (progn 
  (SETQ SC (/ (- H (* (/ H1 W1) W)) 2)) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (LIST ShapeRange 'Width W) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (list ShapeRange 'IncrementTop SC) 
  ) 
      ) 
    ) 
  ) 
  (vl-catch-all-apply 
    'vlax-put-property 
    (LIST Pic 
    'Placement 
    (vl-catch-all-apply 'vlax-make-variant (LIST 1 2)) 
    ) 
  ) 
  (if xlapprelease?      ;释放吗？ 
    (progn (vl-catch-all-apply 'vlax-release-object (list xlapp)) 
     (setq xlapp nil) 
    ) 
  ) 
  (princ) 
) 
(defun $excel-cha-ru-tu-pian2$ 
             (xlapp  excelFile  sh-n  bmp-f 
        lef  top  w  h  lst 
        /  sh  shapes  xlbook  xlbooks 
             ) 
  (or (and lef (= (type lef) 'int)) (setq lef 0)) 
  (or (and top (= (type top) 'int)) (setq top 0)) 
  (or (and w (= (type w) 'int)) (setq w 100)) 
  (or (and h (= (type h) 'int)) (setq h 100)) 
  (if (and excelFile 
     (findfile excelFile) 
     bmp-f 
     (findfile bmp-f) 
      ) 
    (progn 
      (or xlapp (setq xlapp ($xlapp-New$ 1 nil nil))) 
      (setq xlbooks (vl-catch-all-apply 
          'vlax-get-property 
          (list xlapp 'Workbooks) 
        ) 
      ) 
      (setq xlbook (vl-catch-all-apply 
         'vlax-invoke-method 
         (list xlbooks "open" excelFile) 
       ) 
      )          ;打开指定的excel文件 
      (setq SH 
       (vl-catch-all-apply 
         'vlax-get-property 
         (list (vl-catch-all-apply 
           'vlax-get-property 
           (list xlbook 'Sheets) 
         ) 
         'Item 
         sh-n 
         ) 
       ) 
      ) 
      (setq Shapes 
       (vl-catch-all-apply 'vlax-get-property (list sh 'Shapes)) 
      ) 
      (vl-catch-all-apply 
  'vlax-invoke-method 
  (list 
    Shapes 'AddPicture bmp-f 0 1 0 0 w h) 
      ) 
      (vl-catch-all-apply 'vlax-release-object (list Shapes)) 
      (vl-catch-all-apply 'vlax-release-object (list SH)) 
      (vl-catch-all-apply 'vlax-release-object (list xlbook)) 
    ) 
  ) 
  xlapp 
) 
(defun $excel-add-vba$ 
       (xlapp sh-n VBA-STR run-str lst / item vbproject xlsheet) 
          ;向excel里面写vba代码，注入vba代码 
;;;  ($excel-add-vba$ 
;;;  xlapp 
;;;  "Sub Lisp_vba()\nMsgBox \"Hello world!\", vbOKOnly, \"Lisp调用Excel\"\nEnd Sub" 
;;;  "(vlax-invoke-method XLAPP (QUOTE RUN) \"Sheet1.Lisp_vba\")" 
;;;  "Sheet1" 
;;;  nil 
;;; ) 
  (or xlapp (setq xlapp ($xlapp-New$ nil nil nil))) 
  (setq  xlsheet 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     sh-n 
     ) 
   ) 
  ) 
  (setq  VBProject 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list 
       (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 
         "ActiveWorkbook" 
         ) 
       ) 
       'VBProject 
     ) 
   ) 
  ) 
  (setq  Item (vl-catch-all-apply 
         'vlax-invoke-method 
         (LIST 
     (vl-catch-all-apply 
       'vlax-get-property 
       (LIST 
         VBProject 
         'VBComponents 
       ) 
     ) 
     'Item 
     sh-n 
         ) 
       ) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (LIST 
      (vl-catch-all-apply 
  'vlax-get-property 
  (LIST 
    Item 
    'CodeModule 
  ) 
      ) 
      'DeleteLines 
      1 
      (vl-catch-all-apply 
  'vlax-get-property 
  (LIST 
    (vl-catch-all-apply 
      'vlax-get-property 
      (LIST 
        Item 
        'CodeModule 
      ) 
    ) 
    'CountOfLines 
  ) 
      ) 
    ) 
  )          ;删除历史的vba代码 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (LIST 
      (vl-catch-all-apply 
  'vlax-get-property 
  (LIST 
    Item 
    'CodeModule 
  ) 
      ) 
      'AddFromString 
      VBA-STR 
    ) 
  ) 
  (vl-catch-all-apply 
    'EVAL 
    (list (vl-catch-all-apply 'READ (list run-str))) 
  ) 
  (vl-catch-all-apply 
    'vlax-get-property 
    (LIST 
      (vl-catch-all-apply 
  'vlax-get-property 
  (LIST 
    Item 
    'CodeModule 
  ) 
      ) 
      'CountOfLines 
    ) 
  )          ;返回写入成功的行数 
) 
(defun $excel-vba-run$ (XLAPP vba-str lst) 
          ;执行vba代码 
          ;vba-str为字串型，发挥空间很大，为啥用字串型？主要是因为需要执行的vba函数可能需要传参，没法知道到底要传入多少个参数，所以，干脆用字串型，传入的时候自己包装好，传入进来就可以了 ，例如："(vlax-invoke-method XLAPP (QUOTE RUN) \"Sheet1.Lisp_vba\")" 
  (vl-catch-all-apply 
    'EVAL 
    (list (vl-catch-all-apply 'READ (list vba-str))) 
  ) 
) 
(defun $excel-rang-copy$ 
       (xlapp       SH-N-O  SH-N-new   address-o 
        address-n  lst  /     xlsheet1 
        xlsheet2 
       ) 
          ;单元格复制 
          ;SH-N-O原sheet表名 
          ;SH-N-new 新的目标sheet表名 
          ;address-o原复制单元格地址 
          ;address-n 新的单元格地址 
  (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil))) 
  (or SH-N-new (setq SH-N-new SH-N-O)) 
  (setq  xlsheet1 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     SH-N-O 
     ) 
   ) 
  ) 
  (setq  xlsheet2 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     SH-N-new 
     ) 
   ) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (list (vl-catch-all-apply 
      'msxlp-get-range 
      (list xlsheet1 address-o) 
    ) 
    'copy 
    (vl-catch-all-apply 
      'msxlp-get-range 
      (list xlsheet2 address-n) 
    ) 
    ) 
  ) 
) 
(defun $excel-zi-dong-tian-chong$ (xlapp     sh-n      rang-start 
           rows       c-cz      XlAutoFillType 
           lst       /         co 
           nums       rang-end  row 
           strs       xlsheet 
          ) 
          ;自动填充 
          ;xlapp             excel的对象 
          ;sh-n              sheet的表名字 
          ;rang-start        起始单元格，字串格式 
          ;rows               函数，如果传入了这个，就不用传入c-cz的值了，这个变量优先 
          ;c-cz              参照列，用来计算最大行的行号 
          ;XlAutoFillType    填充模式 
          ;lst               预留参数 
          ;($excel-zi-dong-tian-chong$  nil "Sheet1" "C1" "A65536" 6 NIL) 
  (or XlAutoFillType (setq XlAutoFillType 6)) 
  (or c-cz (setq c-cz "A65536"))  ;参照列，用来计算最下面哪一行的行号 
  (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil))) ;EXCEL对象 
  (setq  xlsheet 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     sh-n 
     ) 
   ) 
  )          ;根据传入进来的表名字获取表对象 
  (cond  ((and rows (= (type rows) 'str) (= (type (read rows)) 'int)) 
          ;传入进来是字串格式，同时read后是int格式 
   t 
  ) 
  ((and rows (= (type rows) 'str) (= (type (read rows)) 'int)) 
          ;传入进来的就是int格式 
   t 
  ) 
  ((and rows (= (type rows) 'int)) ;传入进来的就是int格式 
   (setq rows (vl-princ-to-string rows)) ;转换为字串格式 
  ) 
  (t 
   (setq rows (vl-princ-to-string 
          (vlax-get-property 
      (vlax-get-property 
        (msxlp-get-range xlsheet c-cz) 
        'End 
        3 
      ) 
      'Row 
          ) 
        ) 
   )        ;自动根据参照列计算最大行的行号 
  ) 
  )          ;填充的最大行数 
  (setq nums nil) 
  (setq  strs (MAPCAR 'vl-list->string 
         (mapcar 'list (vl-string->list rang-start)) 
       ) 
  )          ;转为字串表 
  (setq strs (reverse strs))    ;倒置 
  (while (and strs (= (type (read (car strs))) 'int)) 
    (setq nums (cons (car strs) nums))  ;找到数字，其实就是起始行号 
    (setq strs (cdr strs)) 
  ) 
  (setq co (apply 'strcat (reverse strs))) ;得到起始列号 
  (setq row (apply 'strcat (reverse nums))) ;得到起始行号 
  (and rang-start 
       co 
       rows 
       (setq rang-end (strcat rang-start ":" co rows)) 
  )          ;计算填充的最大行号 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (LIST (vl-catch-all-apply 
      'msxlp-get-range 
      (list xlsheet rang-start) 
    ) 
    'AutoFill 
    (vl-catch-all-apply 
      'msxlp-get-range 
      (list xlsheet rang-end) 
    ) 
    XlAutoFillType 
    ) 
  )          ;执行填充 
) 
(defun $excel-dan-yuan-ge-pi-zhu$ 
       (xlapp sh-n address-str-h lst / $set-font-size$ xlsheet zt) 
          ;Excel单元格插入批注 
          ;xlapp excel对象 
          ;sh-n 表的名字 
          ;address-str-h  三个值：单元格地址、字串、文字大小 
          ;lst 预留参数 
          ;($excel-dan-yuan-ge-pi-zhu$  xlapp  "Sheet2"(list(list "A1" "中线CAD:\n这个列不能删除，删除后将会带来灾乱性后果")(list "B2" "秦始皇：\n您好呀，我是批注"))nil) 
  (defun $set-font-size$ (range h) 
    (vl-catch-all-apply 
      'vlax-put-property 
      (list 
  (vl-catch-all-apply 
    'vlax-get-property 
    (list 
      (vl-catch-all-apply 
        'vlax-invoke-method 
        (list 
    (vl-catch-all-apply 
      'vlax-get-property 
      (list 
        (vl-catch-all-apply 
          'vlax-get-property 
          (list 
      (vl-catch-all-apply 
        'vlax-get-property 
        (list range 'Comment) 
      ) 
      'Shape 
          ) 
        ) 
        'TextFrame 
      ) 
    ) 
    'Characters 
        ) 
      ) 
      'font 
    ) 
  ) 
  'size 
  h        ;文字高度 
      ) 
    ) 
  ) 
  (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil))) 
  (setq  xlsheet 
   (vl-catch-all-apply 
     'vlax-get-property 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list (vl-catch-all-apply 
         'vlax-get-property 
         (list xlapp 'activeworkbook) 
       ) 
       'Sheets 
       ) 
     ) 
     'Item 
     sh-n 
     ) 
   ) 
  )          ;工作表对象 
  (setq  zt (mapcar (function (lambda (a / address str h range zt) 
             (setq address (car a)) 
             (setq str (cadr a)) 
             (setq h (caddr a)) 
             (or h (setq h 8)) 
             (if str 
         (progn 
           (SETQ 
             range (vl-catch-all-apply 
               'msxlp-get-range 
               (list xlsheet address) 
             ) 
           )  ;单元格对象 
           (vl-catch-all-apply 
             'vlax-invoke-method 
             (list range 'ClearComments) 
           )  ;删除历史批注   
           (setq zt (vl-catch-all-apply 
                'vlax-invoke-method 
                (list 
            range 
            'AddComment.Text 
            str 
                ) 
              ) 
           )  ;添加批注 
           ($set-font-size$ range h) 
         ) 
             ) 
             zt 
           ) 
       ) 
       address-str-h 
     ) 
  ) 
  zt 
) 
(defun $csv>xls$ (xlapp csv-f xls-f / f hzm i wb wjm xlapp-old) 
          ;csv转xls，csv转excel 
  (setq xlapp-old xlapp) 
  (if (and csv-f (findfile csv-f)) 
    (progn 
      (if (findfile xls-f) 
  (progn 
    (setq f (vl-filename-directory xls-f)) 
    (setq wjm (vl-filename-base xls-f)) 
    (setq hzm ".xls") 
    (setq i 1) 
    (while 
      (and 
        (findfile (setq xls-f (strcat f "\\" wjm (itoa i) hzm))) 
      ) 
       (setq i (1+ i)) 
    ) 
  ) 
      ) 
      (or xlapp (setq xlapp ($xlapp-New$ NIL nil nil))) 
      (setq wb (vl-catch-all-apply 
     'vlax-invoke-method 
     (list (vl-catch-all-apply 
       'vlax-get-property 
       (list xlapp 'Workbooks) 
           ) 
           "open" 
           csv-f 
     ) 
         ) 
      ) 
      (vl-catch-all-apply 
  'vlax-put-property 
  (LIST xlapp 'DisplayAlerts :vlax-False) 
      )          ;保存的时候不弹出警告窗口 
      (vl-catch-all-apply 
  'vlax-invoke-method 
  (list 
    wb "SaveAs" xls-f msxlc-xlNormal "" "" :vlax-False :vlax-False 
    nil) 
      ) 
      (vl-catch-all-apply 'vlax-invoke-method (list wb 'close)) 
      (vl-catch-all-apply 'vlax-release-object (list wb)) 
      (if xlapp-old 
  () 
  (vl-catch-all-apply 'vlax-release-object (list xlapp)) 
      ) 
      (if xls-f 
  (findfile xls-f) 
      ) 
    ) 
  ) 
) 
(defun $get-xls-sheets$  (excelFile / ns sheets xlapp xlbooks xls-open) 
          ;获取excel文件的所有sheet表的名字 
  (if excelFile 
    (progn 
      (setq xlapp ($xlapp-New$ NIL nil nil)) 
      (setq xlbooks (vl-catch-all-apply 
          'vlax-get-property 
          (list xlapp 'Workbooks) 
        ) 
      ) 
      (setq xls-open (vl-catch-all-apply 
           'vlax-invoke-method 
           (list xlbooks "open" excelFile) 
         ) 
      ) 
      (setq sheets (vl-catch-all-apply 
         'vlax-get-property 
         (list (vl-catch-all-apply 
           'vlax-get-property 
           (list xlapp 'activeworkbook) 
         ) 
         'Sheets 
         ) 
       ) 
      ) 
      (if (not (vl-catch-all-error-p sheets)) 
  (progn 
    (setq ns nil) 
    (VLAX-FOR SH sheets 
      (setq ns 
       (cons (vl-catch-all-apply 'VLA-GET-NAME (list SH)) ns) 
      ) 
    ) 
    (vl-catch-all-apply 
      (function (lambda () 
      (vlax-invoke-method 
        (vlax-get-property xlapp 'activeworkbook) 
        'Close 
      ) 
          ) 
      ) 
    ) 
    (mapcar 
      (function (lambda (x) 
      (vl-catch-all-apply 
        (function (lambda () 
              (vlax-release-object x) 
            ) 
        ) 
      ) 
          ) 
      ) 
      (list SH sheets xls-open xlbooks) 
    ) 
    (vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit)) 
    (setq sheets nil) 
    (setq xls-open nil) 
    (setq xlbooks nil) 
    (setq xlapp nil) 
    (gc) 
  ) 
      ) 
    ) 
  ) 
  ns 
) 
(defun $excel-lie-kuan$  (sh lks lst) 
          ;列宽设置 
          ;sh Sheet表对象 
          ;($lie-kuan$ SH(LIST(CONS "A1" 15)(CONS "B1" 15)(CONS "C1" 15))NIL)       
  (MAPCAR (FUNCTION 
      (LAMBDA (A / RANG) 
        (SETQ RANG 
         (vl-catch-all-apply 
           'vlax-get-property 
           (list sh 'range (CAR A)) 
         ) 
        ) 
        (vl-catch-all-apply 
    (function (lambda () 
          (vlax-put-property RANG 'ColumnWidth (CDR A)) 
        ) 
    ) 
        ) 
        (vl-catch-all-apply 
    (function (lambda () 
          (vlax-release-object RANG) 
        ) 
    ) 
        ) 
        (SETQ RANG NIL) 
      ) 
    ) 
    LKS 
  ) 
) 
(DEFUN $excel-hang-gao$  (sh rangs lst) 
          ;行高设置 
          ;sh Sheet表对象 
          ;($excel-hang-gao$ SH(LIST(CONS "A1" 15)(CONS "A2" 15)(CONS "A3" 15))NIL) 
  (MAPCAR (FUNCTION 
      (LAMBDA (A / RANG) 
        (SETQ RANG 
         (vl-catch-all-apply 
           'vlax-get-property 
           (list sh 'range (car a)) 
         ) 
        ) 
        (vl-catch-all-apply 
    'vlax-PUT-property 
    (LIST RANG 'RowHeight (cdr a)) 
        ) 
        (vl-catch-all-apply 
    (function (lambda () 
          (vlax-release-object RANG) 
        ) 
    ) 
        ) 
        (SETQ RANG NIL) 
      ) 
    ) 
    rangs 
  ) 
) 
(defun $excel-wen-zi-gao-du$ (sh rangs lst) 
          ;文字高度，字体高度，字体大小，文字大小 
          ;sh  sheet表对象 
          ;rangs  rang单元格以及文字高度 
          ;示例 ($excel-wen-zi-gao-du$ sh(list(cons "A1" 12)(cons "J1" 22))nil) 
  (mapcar (function 
      (lambda (a / RANG font) 
        (SETQ RANG (vl-catch-all-apply 
         'vlax-get-property 
         (list sh 'range (car a)) 
       ) 
        ) 
        (setq font 
         (vl-catch-all-apply 'vlax-get-property (list RANG 'font)) 
        ) 
        (vlax-put-property font 'size (cdr a)) 
        (vl-catch-all-apply 'vlax-release-object (list font)) 
        (vl-catch-all-apply 'vlax-release-object (list RANG)) 
        (setq font nil) 
        (setq RANG nil) 
      ) 
    ) 
    rangs 
  ) 
) 
(defun $excel-tian-xie-wen-zi$ (sh rang-strs lst) 
          ;向单元格写入文字，写文字 
  (mapcar (function (lambda (a / rang-str str) 
          (setq rang-str (car a)) 
          (setq str (cdr a)) 
          (or str (setq str "")) 
          (if (and rang-str str) 
      (vl-catch-all-apply 
        'vlax-put-property 
        (list 
          (vl-catch-all-apply 
            'vlax-get-property 
            (list sh 'range rang-str) 
          ) 
          'value2  ;不是text 
          (vlax-make-variant str 8) 
        ) 
      ) 
          ) 
        ) 
    ) 
    rang-strs 
  ) 
) 
(defun $excel-wen-zi-ju-zhong$ (sh rang-str lst / $jz-v-h$) 
          ;单元格文字居中 
  (defun $jz-v-h$ (sh rang-str / RANG) 
    (SETQ RANG (vl-catch-all-apply 
     'vlax-get-property 
     (list sh 'range rang-str) 
         ) 
    ) 
    (vl-catch-all-apply 
      'vlax-put-property 
      (list RANG 'HorizontalAlignment -4108) 
    ) 
          ;水平对齐方式居中 
    (vl-catch-all-apply 
      'vlax-put-property 
      (list RANG "VerticalAlignment" -4108) 
    ) 
          ;垂直水平方式对齐 
  ) 
  (cond  ((and rang-str (= (type rang-str) 'str)) 
   ($jz-v-h$ sh rang-str) 
  ) 
  ((and rang-str (= (type rang-str) 'list)) 
   (mapcar (function (lambda (a) ($jz-v-h$ sh a))) rang-str) 
  ) 
  ) 
) 
(defun $excel-cha-ru-hang$ 
       (sh rang-str row-num lst / rang EntireRow resize) 
          ;插入行，批量插入行,插入空行 
          ;SH  sheet表格对象 
          ;rang-str 单元格字串，比如说 A1 
          ;row-num  插入的空行数数字 
  (setq  rang (vl-catch-all-apply 
         'vlax-get-property 
         (list sh 'range rang-str) 
       ) 
  ) 
  (setq  EntireRow (vl-catch-all-apply 
        'vlax-get-property 
        (list rang 'EntireRow) 
      ) 
  ) 
  (setq  resize (vl-catch-all-apply 
     'vlax-get-property 
     (list EntireRow 'resize row-num) 
         ) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (list resize 'Insert) 
  ) 
  (vl-catch-all-apply 'vlax-release-object (list resize)) 
  (vl-catch-all-apply 'vlax-release-object (list EntireRow)) 
  (vl-catch-all-apply 'vlax-release-object (list rang)) 
  (setq resize nil) 
  (setq EntireRow nil) 
  (setq rang nil) 
) 
(DEFUN $excel-fu-zhi-dan-yuan-ge$ 
       (sh rang-str-old rang-str-new lst / RANG1 RANG2) 
          ;复制单元格，单元格复制 
          ;sh sheet表格对象 
          ;rang-str-old  待复制的源区域，例如 A1:D8 
          ;rang-str-new  复制到目标区域的单元格，例如 ：A1 
  (SETQ  RANG1 (vl-catch-all-apply 
    'vlax-get-property 
    (list sh 'range rang-str-old) 
        ) 
  ) 
  (SETQ  RANG2 (vl-catch-all-apply 
    'vlax-get-property 
    (list sh 'range rang-str-new) 
        ) 
  ) 
  (vl-catch-all-apply 
    'vlax-invoke-method 
    (list RANG1 'copy RANG2) 
  ) 
  (vl-catch-all-apply 'vlax-release-object (list RANG2)) 
  (vl-catch-all-apply 'vlax-release-object (list RANG1)) 
  (SETQ  RANG1 NIL 
  RANG2 NIL 
  ) 
) 
(defun $excel-dan-yuan-ge-yan-se$ 
       (sh ranges lst / $dan-yuan-ge-yan-se-RUN$) 
          ;单元格颜色，填充颜色 
          ;sh sheet表对象 
          ;ranges  单元格的颜色，例如(list(cons "A1:C2" 255)(cons "D1" 255)) 
  (DEFUN $dan-yuan-ge-yan-se-RUN$ (sh range-str color / RANG Interior) 
    (SETQ RANG 
     (vl-catch-all-apply 
       'vlax-get-property 
       (list sh 'range range-str) 
     ) 
    ) 
    (SETQ Interior (vl-catch-all-apply 
         'vlax-get-property 
         (list RANG 'Interior) 
       ) 
    ) 
    (vl-catch-all-apply 
      'vlax-put-property 
      (list 
  Interior 
  'color 
  (vl-catch-all-apply 'vlax-make-variant (list color 5)) 
      ) 
    ) 
    (vl-catch-all-apply 'vlax-release-object (list RANG)) 
    (setq RANG nil) 
  ) 
  (mapcar (function 
      (lambda (a) 
        ($dan-yuan-ge-yan-se-RUN$ sh (car a) (cdr a)) 
      ) 
    ) 
    ranges 
  ) 
)

yimiyangguang55 · 发表于 2024-4-20 08:27:48

感谢大佬的无私分享谢谢

479274135 · 发表于 2024-5-12 15:21:25

吃瓜群众也留个神国坐标

帝都划水王 · 发表于 2024-4-18 09:25:37

吃瓜群众也留个神国坐标

伊江痕 · 发表于 2024-4-16 16:26:16

这回我看懂了。

fan_zh · 发表于 2024-4-16 17:00:17

前排占座招租

锋十七 · 发表于 2024-4-16 17:19:14

先收藏再学习！！

lxl217114 · 发表于 2024-4-16 18:39:03

吃瓜群众也占座

guosheyang · 发表于 2024-4-16 19:13:49

感谢杜总的分享！

ptime · 发表于 2024-4-16 19:30:06

多谢分享！！！

magicheno · 发表于 2024-4-17 00:15:13

感谢大佬分享

hubeiwdlue · 发表于 2024-4-17 11:31:53

感谢杜总分享。

cghdy · 发表于 2024-4-17 13:52:47

感谢分享，十分好贴！

账号		自动登录	找回密码
密码			注册

[源码] Lisp与Excel通信的相关函数

评分