Lisp与Excel通信的相关函数

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

本帖最后由 dcl1214 于 2024-4-18 08:39 编辑

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

;|
;快速调试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
"K:\\中线CAD-code\\公司版本\\70\\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$ "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-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 
         "K:\\中线CAD-code\\公司版本\\70\\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$ "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-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

感谢大佬的无私分享谢谢

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

吃瓜群众也留个神国坐标

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

感谢分享，十分好贴！

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

这回我看懂了。

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

前排占座招租

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

先收藏再学习！！

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

吃瓜群众也占座

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

感谢杜总的分享！

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

多谢分享！！！

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

感谢大佬分享

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

感谢杜总分享。

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

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

评分