马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
本帖最后由 牢固 于 2015-1-20 14:10 编辑
以下程序需加载XDRX_API使用!2013.07.07更新
主程序代码:
 - ;;CAD转Table
- (defun c:c2t (/ ANG COL COLWIDTHS FUZZ H
- I INSPT MAXCOL MAXROW MINCOL MINROW
- N ROW ROWHEIGHTS SS TB
- TBLST TXTCOLOR TXTH TXTLST TXTSS TXTSTR
- TXTSTYLE W X *STARTTIME* SCALEFACTOR
- )
- (xdrx_begin '("cmdecho" 0 "osmode" 0))
- (setq ss (ssget '((0 . "line,*polyline"))))
- (setq Inspt (trans (getpoint "\n位置点:") 1 0)
- fuzz (getreal "\n设置容差值<0.01>")
- )
- (if (null Fuzz) (setq Fuzz 0.01))
- (if ss
- (progn
- (setq *StartTime* (car (_VL-TIMES)))
- (setq tblst (GETTABLELST ss Fuzz))
- (setq ;InsPt (car (cadaar tblst))
- ang (angle (car (cadaar tblst)) (cadr (cadaar tblst)))
- Row (nth 4 tblst)
- Col (nth 2 tblst)
- ColWidths (nth 5 Tblst)
- RowHeights (nth 6 Tblst)
- )
- (setq tb (xdrx_table_make InsPt (1+ row) 10. col 12.))
- (XD::Table:Begin tb)
- (vla-SetAlignment (vlax-ename->vla-object tb) 1 acMiddleCenter)
- (vla-SetAlignment (vlax-ename->vla-object tb) 2 acMiddleCenter)
- (vla-SetAlignment (vlax-ename->vla-object tb) 4 acMiddleCenter)
- (XDRX_TABLE_DELETEROWS tb 0 1) ;_ 删除表头
- (XDRX_TABLE_SETHORZCELLMARGIN tb 0.0)
- (XDRX_TABLE_SETVERTCELLMARGIN tb 0.0)
- ;|(setq r -1)
- (repeat row
- (setq r (1+ r) c -1)
- (repeat col
- (setq c (1+ c))
- (xdrx_table_SetAutoScale tb r c nil)
- )
- )|;
- (setq i -1)
- (mapcar '(lambda (w)(setq i (1+ i)) (XDRX_TABLE_SETCOLUMNWIDTH tb i w)) ColWidths)
- (setq i -1)
- (mapcar '(lambda (h)(setq i (1+ i)) (xdrx_table_SetRowHeight tb i h)) RowHeights)
- (foreach cell (car tblst)
- (mapcar 'set
- '(minCol minRow maxCol maxRow)
- (mapcar '1-
- (apply 'append
- (mapcar 'VLXLS-RANGEID (VLXLS-CELLID (car cell)))
- )
- )
- )
- (if (or (/= minRow maxRow)
- (/= minCol maxCol)
- ) ;_ 合并单元格
- (XDRX_TABLE_MERGECELLS tb minRow maxRow minCol maxCol)
- )
- (setq txtss (ssget "cp" (mapcar '(lambda (x) (trans x 0 1)) (cadr cell)) '((0 . "*text"))))
- (if txtss
- (progn
- (setq txtlst nil)
- (repeat (setq n (sslength txtss))
- (setq txtlst (cons (ssname txtss (setq n (1- n))) txtlst))
- )
- (setq txtlst (vl-sort txtlst '(lambda (a b) (> (cadr (gxl-dxf a 10)) (cadr (gxl-dxf b 10))))))
- (setq txtstr (gxl-dxf (car txtlst) 1)
- txth (gxl-dxf (car txtlst) 40)
- txtstyle (tblobjname "style" (gxl-dxf (car txtlst) 7))
- txtcolor (gxl-dxf (car txtlst) 62)
- )
- (if (and
- (= "TEXT" (gxl-dxf (car txtlst) 0))
- (equal 1.0 (setq Scalefactor (gxl-dxf (car txtlst) 41)) 1e-3)
- )
- (setq Scalefactor nil)
- )
- (setq txtlst (cdr txtlst))
- (foreach e txtlst
- (setq txtstr (strcat txtstr "\\P" (gxl-dxf e 1)))
- )
- (if Scalefactor (setq txtstr (strcat "{\\W" (rtos Scalefactor 2 2)";" txtstr "}")))
- (xdrx_table_SetTextString tb minRow minCol txtstr)
- (XDRX_TABLE_SETTEXTHEIGHT tb minRow minCol txth )
- (XDRX_TABLE_SETTEXTstyle tb minRow minCol txtstyle)
- (XDRX_TABLE_SETCONTENTCOLOR tb minRow minCol txtcolor)
- )
- )
-
- )
- (XDRX_ENTITY_TRANSFORM tb (Gxl-MAT:Rotation3D Inspt '(0 0 1) ang))
- (XD::Table:End tb)
- (princ (strcat "\n 用时 " (rtos (* 0.001 (- (car (_VL-TIMES)) *StartTime*)) 2 4) " 秒 "))
- )
- )
- (xdrx_end)
- (princ)
- )
完整源码下载:
游客,本帖隐藏的内容需要积分高于 50 才可浏览,您当前积分为 0
免费编译Fas文件:
|