Hi,Atook
You understand that almost, but not entirely correct.
Here is my codes:
;| Output the center coordinates of Circle to EXCEL Project
Copyright(C) 2007-2010 by libin (小李子 MuziCAD 木子CAD). All rights reserved.
Permission to use, copy, modify, and distribute this software for any purpose and without fee is hereby granted, provided that the above copyright notice appears in all copies and that both that copyright notice and the limited warranty and restricted rights notice below appear in all supporting documentation.
|;
;; Start Sub-Functions ;;
(defun GetMyDocumentsDir ()
(vlax-invoke-method
(vlax-get-property
(vlax-create-object "wscript.shell")
'SpecialFolders
)
'Item
"MyDocuments"
)
)
(defun ZbOut_getfile (/ Rtn)
(setq Rtn (getfiled "Save the Coordinate file"
(strcat (GetMyDocumentsDir)
"\\"
(vl-filename-base (getvar "dwgname"))
"_ZB.xls"
)
"xls"
9
)
)
Rtn
)
;|
Following is the pre-define part of VLXLS project, VLXLS need a global variable named as *xls-color* to contain all color matching list. Syntax as (ECI ACI TrueColor), sorted as ECI number.
As VLXLS support two languages: English as international and Simplified Chinese as local. In Default, VLXLS will go to seek if global variable *Chinese* is true, if so, VLXLS will prompt Chinese, or VLXLS will display English as default.
|;
(if vl-load-com
(vl-load-com)
)
(if vl-arx-import
(foreach item '(ACAD_COLORDLG ACAD_truecolordlg
ACAD_STRLSORT INITDIA
ACAD-POP-DBMOD ACAD-PUSH-DBMOD
STARTAPP layoutlist
)
(vl-arx-import item)
)
)
(setq item nil
*Chinese* nil
)
;; Excel Application Session Progress Function
(Defun vlxls-app-Init (/ OSVar GGG Olb8 Olb9 Olb10 TLB Out msg msg1 msg2)
(if *Chinese*
(setq msg "\n 初始化微软Excel "
msg1 "\042初始化Excel错误\042"
msg2 (strcat
"\042 警告"
"\n ===="
"\n 无法在您的计算机上检测到微软Excel软件"
"\n 如果您确认已经安装Excel, 请发送电子邮"
"\n 件到GuXiaolin@hxch.com.cn获取更多的解决方案\042"
)
)
(setq msg "\n Initializing Microsoft Excel "
msg1 "\042Initialization Error\042"
msg2 (strcat
"\042 WARNING" "\n ======="
"\n Can NOT detect Excel97/200X/XP in your computer"
"\n If you already have Excel installed, please email"
"\n us to get more solution via GuXiaolin@hxch.com.cn\042")
)
)
(if (null msxl-xl24HourClock)
(progn
(if (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")))
)
(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
)
)
)
)
(setq Olb8 (findfile (vl-string-subst "EXCEL8.OLB" "EXCEL.EXE" GGG)
)
Olb9 (findfile (vl-string-subst "EXCEL9.OLB" "EXCEL.EXE" GGG)
)
Olb10 (findfile
(vl-string-subst "EXCEL10.OLB" "EXCEL.EXE" GGG)
)
)
(cond ((= (vl-filename-base (vl-filename-directory GGG))
"OFFICE11"
)
(setq TLB GGG
Out "2003"
)
)
((= (vl-filename-base (vl-filename-directory GGG))
"OFFICE10"
)
(setq TLB GGG
Out "XP"
)
)
(Olb9
(setq TLB Olb9
Out "2000"
)
)
(Olb8
(setq TLB Olb8
Out "97"
)
)
(t (setq Out "Version Unknown"))
)
(if TLB
(progn
(princ (strcat MSG Out "..."))
(vlax-import-type-library
:tlb-filename TLB :methods-prefix
"msxl-" :properties-prefix
"msxl-" :constants-prefix "msxl-"
)
)
)
)
(progn
(if vldcl-msgbox
(vldcl-msgbox "x" msg1 msg2)
(alert (read msg2))
)
(exit)
)
)
)
)
msxl-xl24HourClock
)
;;New Excel document T for display, nil for hide
(Defun vlxls-app-New (UnHide / Rtn)
(if (vlxls-app-init)
(progn
(if *Chinese*
(princ "\n 新建微软Excel工作表...")
(princ "\n Creating new Excel Spreadsheet file...")
)
(if (setq Rtn (vlax-get-or-create-object "Excel.Application"))
(progn
(vlax-invoke-method
(vlax-get-property Rtn 'WorkBooks)
'Add
)
(if UnHide
(vla-put-visible Rtn 1)
(vla-put-visible Rtn 0)
)
)
)
)
)
Rtn
)
;;; Import data ton the cells
(Defun vlxls-cell-put-value (xl id Data / vllist-explode idx xx yy ary Rtn)
(Defun vllist-explode (lst)
(cond
((not lst) nil)
((atom lst) (list lst))
((append (vllist-explode (car lst))
(vllist-explode (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)))
)
XX (1- (length (car Data)))
YY (1- (length Data))
)
(setq
ARY (vlax-make-safearray
vlax-vbstring
(cons 0 1)
(cons 1 (length Data))
)
XX (1- (length Data))
YY 0
)
)
(if (= xx yy 0)
(MSXL-PUT-VALUE2
(setq Rtn (msxl-get-range xl id))
(car (vllist-explode data))
)
(progn
(setq id (vlxls-cellid-calc id xx yy))
(MSXL-PUT-VALUE2
(setq Rtn (msxl-get-range xl id))
(vlax-safearray-fill ary data)
)
)
)
Rtn
)
(Defun vlxls-rangeid (id / str->list list->str xid->str Rtn)
(Defun str->list (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)
(setq Nm-One (1- IntNum)
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->str (idr / x y)
(setq x (car idr)
y (cadr idr)
x (xid->str x)
y (itoa y)
)
(strcat x y)
)
(cond ((= (type id) 'str) (setq Rtn (str->list id)))
((= (type id) 'list) (setq Rtn (list->str id)))
)
Rtn
)
(Defun vlxls-cellid-calc (id x y / idx)
(setq id (car (vlxls-cellid id))
idx (vlxls-rangeid id)
x (+ x (car idx))
x (if (< x 1)
1
x
)
y (+ y (cadr idx))
y (if (< y 1)
1
y
)
idx (vlxls-rangeid (list x y))
id (vlxls-cellid (strcat id ":" idx))
id (strcat (car id) ":" (cadr id))
)
id
)
(Defun vlxls-cellid (id / xx id1 id2 Rtn)
(if (= (type id) 'list)
(setq id (vlxls-rangeid id))
)
(setq id (strcase id))
(if (null (setq xx (vl-string-search ":" id)))
(setq Rtn (list id ""))
(setq id1 (substr id 1 xx)
id2 (substr id (+ xx 2))
id1 (vlxls-rangeid id1)
id2 (vlxls-rangeid id2)
Rtn (list (vlxls-rangeid
(list (min (car id1) (car id2))
(min (cadr id1) (cadr id2))
)
)
(vlxls-rangeid
(list (max (car id1) (car id2))
(max (cadr id1) (cadr id2))
)
)
)
)
)
Rtn
)
;; Merge Cells
;; Run cell merge in Excel. Only 1st un-empty value will be left in merged cell
(Defun vlxls-cell-merge (xl id / vllist-explode Val Rtn)
(Defun vllist-explode (lst)
(cond
((not lst) nil)
((atom lst) (list lst))
((append (vllist-explode (car lst))
(vllist-explode (cdr lst))
)
)
)
)
(setq val (vllist-explode (vlxls-cell-get-value xl id)))
(while (vl-position "" val)
(setq val (vl-remove "" val))
)
(setq val (car val)
Rtn (msxl-get-range xl id)
)
(msxl-clear Rtn)
(msxl-merge Rtn nil)
(msxl-put-value2 Rtn Val)
(msxl-put-HorizontalAlignment Rtn -4108)
Rtn
)
;; Get value of certain Cell ID
(Defun vlxls-cell-get-value (xl id)
(if (= (type id) 'list)
(setq id (vlxls-rangeid id))
)
(vlxls-variant->list
(msxl-get-value2 (msxl-get-range xl id))
)
)
;; Convert a variant into normal Visual LISP LIST data, nested Variant and safearray will also be converted.
(Defun vlxls-variant->list (VarX / Run Item Rtn)
(setq Run T)
(while
Run
(cond ((= (type VarX) 'SAFEARRAY)
(setq VarX (vlax-safearray->list VarX))
)
((= (type VarX) 'VARIANT)
(if (member (vlax-variant-type VarX) (list 5 4 3 2))
(setq VarX (vlax-variant-change-type Varx vlax-vbString))
)
(setq VarX (vlax-variant-value VarX))
)
(t (setq Run nil))
)
)
(cond ((= (type VarX) 'LIST)
(foreach Item VarX
(setq Item (vlxls-variant->list Item)
Rtn (append Rtn (list Item))
)
)
)
((= VarX nil) (setq Rtn ""))
(t (setq Rtn VarX))
)
Rtn
)
(defun vlxls-get-cell (obj row col / item cells)
(setq item (vlax-get-property
(setq cells (vlax-get-property obj "Cells"))
"Item"
(vlax-make-variant row)
(vlax-make-variant col)))
(vlax-release-object cells)
(vlax-variant-value item)
)
;; Set the font of text in the cell
(defun vlxls-Excel-cellfontname (xlapp row col name / sheet cell)
(setq sheet (vlax-get-property xlapp "ActiveSheet"))
(vlax-put-property (vlax-get-property (setq cell (vlxls-get-cell sheet row col)) "font") "name" name)
)
;; Change text size
(defun vlxls-Excel-textsize (xlapp row col size / sheet cell)
(setq sheet (vlax-get-property xlapp "ActiveSheet"))
(setq cell (vlxls-get-cell sheet row col))
(vlax-put-property
(vlax-get-property cell "font")
"Size"
size
)
)
;; Change Text color
(defun vlxls-Excel-textcolor (xlapp row col color / sheet cell)
(setq sheet (vlax-get-property xlapp "ActiveSheet"))
(setq cell (vlxls-get-cell sheet row col))
(vlax-put-property
(vlax-get-property cell "font")
"ColorIndex"
color
)
)
;; Adjust column widths
(defun vlxls-Excel-ColumnWidth (xlapp col width / sheet cell)
(setq sheet (vlax-get-property xlapp "ActiveSheet"))
(vlax-put-property (setq cell (vlxls-get-cell sheet 1 col)) "ColumnWidth" width)
)
;; Adjust row height
(defun vlxls-Excel-RowHeight (xlapp row height / sheet cell)
(setq sheet (vlax-get-property xlapp "ActiveSheet"))
(vlax-put-property (setq cell (vlxls-get-cell sheet row 1)) "RowHeight" height)
)
;; End Sub-Functions ;;
;; The beginning of the main program
(defun c:Getcen2Excel (/ Zbout_ss Zbout_N Zbout_ssNum
RepNo1 RepNo2 *No1* Coord_prec
ZBOutpath ExcelID OutPutDLst ent_name
ent_data Zbout_pt *xlapp* *Tmp*
)
(setvar "cmdecho" 0)
;;(vl-load-com)
;;(LOAD "vlxls.lsp") ;Call a function library file which is to operate excel
(princ
"\nplease select the circle so to output its center coordinates: "
) ;Please select the circle so to output the coordinates of its center
(if (setq Zbout_ss (ssget '((0 . "circle"))))
(progn
(setq Zbout_N 0
Zbout_ssNum
(sslength Zbout_ss)
RepNo1 0
RepNo2 1
*No1* 0
Coord_prec 3
)
(if (setq ZBOutpath (ZbOut_getfile))
(progn
(princ "正在输出到EXCEL，请不要进行其它操作......")
(setq ExcelID (strcat "A1:D" (itoa (+ Zbout_ssNum 2)))
OutPutDLst (list '("圆心坐标表（测量）" "" "" "")
'("序号" "X坐标" "Y坐标" "Z坐标")
)
)
(repeat Zbout_ssNum
(setq ent_name (ssname Zbout_ss Zbout_N)
ent_data (entget ent_name)
Zbout_pt (cdr (assoc 10 ent_data))
OutPutDLst (append
OutPutDlst
(list
(list (itoa (setq Zbout_N (1+ Zbout_N)))
(rtos (cadr ZbOut_pt) 2 Coord_prec)
(rtos (car ZbOut_pt) 2 Coord_prec)
(rtos (caddr ZbOut_pt) 2 Coord_prec)
)
)
)
)
)
(setq *xlapp* (vlxls-app-new t))
(vlxls-cell-put-value *xlapp* ExcelID OutPutDLst) ; Output to Excel spreadsheet
(vlxls-cell-merge *xlapp* "A1:D1") ; Merge Cells
(msxl-put-HorizontalAlignment
(msxl-get-range *xlapp* ExcelID)
-4108
) ; Set the level of the middle
(msxl-put-VerticalAlignment
(msxl-get-range *xlapp* ExcelID)
-4108
) ; Setting the vertical center
(vlxls-Excel-cellfontname *xlapp* 1 1 "黑体") ;Set the font of cell
(vlax-put-property
(vlax-get-property (msxl-get-range *xlapp* "A2:D2") "font")
"FontStyle"
"Bold"
) ; Change the text in bold
(vlxls-Excel-textsize *xlapp* 1 1 15) ; Change text size
(vlxls-Excel-textcolor *xlapp* 1 1 18) ; Change Text color
(repeat 4 ; Put the header row color settings 13
(setq *No1* (1+ *No1*))
(vlxls-Excel-textcolor *xlapp* 2 *No1* 10) ; Seting the color for "A2、B2、C2、D2" cells
;;(vlxls-Excel-fontstyle *xlapp* 2 *No1* "Bold") ; Change the text in bold
)
(repeat 4
(setq RepNo1 (1+ RepNo1))
(vlxls-Excel-ColumnWidth *xlapp* RepNo1 12) ; Adjust column widths
)
(vlxls-Excel-RowHeight *xlapp* 1 25) ;Setting hte height ot the first Row
(repeat (+ Zbout_ssNum 2)
(setq RepNo2 (1+ RepNo2)) ;Not the same as the first high-traffic, a separate set, so the initial value of RepNo2 begin 1
(vlxls-Excel-RowHeight *xlapp* RepNo2 20) ; Adjust row height
)
(if (setq *Tmp* (findfile Zboutpath)) (vl-file-delete *Tmp*))
(vlax-invoke-method
(vlax-get-property *Xlapp* "ActiveWorkbook")
"SaveAs"
ZBOutpath
msxl-xlNormal
""
""
:vlax-False
:vlax-False
nil
) ;Save the file
(vlax-release-object *xlapp*)
(setq *xlapp* nil)
(gc)
;;=============================================================
(princ "\n ****** Procedures are completed！ ******")
(princ
(strcat "\n ****** A total of " (itoa Zbout_N) " sets of data output ******")
)
(vlr-beep-reaction)
(alert (strcat "\nHave completed output the center coordinates of Circle, Please view!\n" ZBOutpath)
)
) ;end prog
) ;end if
) ;end progn
;;else, If there is no choice, forced exit
(vl-exit-with-error "\n*** no select any element ***")
) ;_ End if
(setvar "cmdecho" 1)
(princ)
)
(princ (strcat "\n Output the center coordinates of Circle to EXCEL Project."
"\n Copyright(C) 2007-"
(substr (rtos (getvar "cdate") 2 0) 1 4)
" by libin (小李子 MuziCAD 木子CAD). All rights reserved."
)
)
(princ)
