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

admin · 发表于 2024-4-17 08:00:51

;|
;快速调试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
)
)

复制代码

		自动登录	找回密码
密码			立即注册