Message 1 of 2
Lisp CountV1-5 for MacBook
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hi. I used this lisp on Autocad for Windows (the function is called CountV1.5 found on Lee Mac Programming)
. I would like to use it on Autocad for MacBook. is it possible or not?
(vl-load-com)
(defun C:MS (/ *error* acdoc ss p i e a d l s h dz sc
c0w c1w c2w c3w)
(vl-load-com)
(setq c0w 0)
(setq c1w 0)
(setq c2w 0)
(setq c3w 0)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
dz (getvar 'dimzin)
)
(vla-startundomark acdoc)
(setvar 'dimzin 1)
(defun *error* (msg)
(and
msg
(not
(wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*")
)
(princ (strcat "\nError: " msg))
)
(setvar 'dimzin dz)
(if
(= 8 (logand (getvar 'undoctl) 8))
(vla-endundomark acdoc)
)
(princ)
)
(if
(and
(setq ss
(ssget
":L"
'((0
.
"LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE,HATCH"
)
)
)
)
(setq sc (getScale)) ;get scale
(setq p
(getpoint
"\nTable scale depend on annotation scale.\nSpecify table insert point: "
)
)
)
(progn
(repeat
(setq i (sslength ss))
(setq e (vlax-ename->vla-object
(ssname ss (setq i (1- i)))
)
a (vla-get-layer e)
)
(if
(setq h (eq (vla-get-objectname e) "AcDbHatch"))
(setq s (vla-get-area e))
(setq
d (vlax-curve-getdistatparam
e
(vlax-curve-getendparam e)
)
)
)
(if
(setq o (assoc a l))
(if h
(setq
l (subst (list a (cadr o) (+ (caddr o) s))
o
l
)
)
(setq
l (subst (list a (+ (cadr o) d) (caddr o))
o
l
)
)
)
(if h
(setq l (cons (list a 0.0 s) l))
(setq l (cons (list a d 0.0) l))
)
)
)
(setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
(insert_table l p sc)
)
)
(*error* nil)
(princ)
)
(defun insert_table
(lst pct scaleValue / cl layname tab row col ht i n space tmpCol)
(setq space (vlax-get acDoc
(if (= 1 (getvar 'cvport))
'PaperSpace
'ModelSpace
)
)
ht (/ 2.5
(cond ((getvar 'cannoscalevalue))
(1.0)
)
)
pct (trans pct 1 0)
n (trans '(1 0 0) 1 0 T)
tab (setq tab (vla-addtable
space
(vlax-3d-point pct)
(+ 2 (length lst))
(1+ (length (car lst)))
(* 2.5 ht)
ht
)
)
)
(vlax-put tab 'direction n)
(mapcar
(function
(lambda (rowType)
(vla-SetTextStyle tab rowType (getvar 'textstyle))
(vla-SetTextHeight tab rowType ht)
)
)
'(2 4 1)
)
(vla-put-HorzCellMargin tab (* 0.14 ht))
(vla-put-VertCellMargin tab (* 0.14 ht))
(setq lst (cons '("Layer" "Length") lst))
(setq i 0)
;(foreach col (apply 'mapcar (cons 'list lst))
; (setTableColumnWidth tab i col ht 0)
; (setq i (1+ i))
:winking_face:
(setTableColumnWidth tab 0 (list "0") ht 0) ;set first colour column
(setq lst (cons '("FLOOR XX") lst))
(setq row 0)
(foreach r lst
(setq col 0)
(foreach c r
(if
(not (eq c 0))
(progn
;viene esclusa la prima colonna che non viene mai scritta
(if (> row 0)
(setq tmpCol (1+ col))
(setq tmpCol col)
)
;imposta il colore della prima cella della linea, esclusa la prima righa
(if (and (> row 1) (= col 0))
(progn
(setBGCell tab row col c)
)
)
(if (> scaleValue 0)
(progn
; (if (and (> row 1) (= tmpCol 1)) ; nome layer
; (progn
; (setq c1w (setTableColumnWidth tab tmpCol (list c) ht c1w))
; )
; )
(if (and (> row 1) (= tmpCol 2)) ; length
(progn
(setq c (* scaleValue c))
;(setq c2w (setTableColumnWidth tab tmpCol (list c) ht c2w))
;(print "lunghezza")
;(print c)
)
)
(if (and (> row 1) (= tmpCol 3)) ; area
(progn
;(print "area")
(setq c (* (* scaleValue scaleValue) c))
;(setq c3w (setTableColumnWidth tab tmpCol (list c) ht c3w))
;(print c)
)
)
)
)
;set column width
(if (= tmpCol 1) ; nome layer
(progn
(setq c1w (setTableColumnWidth tab tmpCol (list c) ht c1w))
)
)
(if (= tmpCol 2) ; length
(progn
(setq c2w (setTableColumnWidth tab tmpCol (list c) ht c2w))
)
)
(if (= tmpCol 3) ; area
(progn
(setq c3w (setTableColumnWidth tab tmpCol (list c) ht c3w))
)
)
(vla-SetText tab row tmpCol c)
(vla-SetCellDataType
tab
row
tmpCol
(cdr (assoc (type c)
'((STR . 4) (REAL . 2) (INT . 1))
)
)
acUnitless
)
(vla-setCellAlignment tab row tmpCol acMiddleCenter)
)
)
(setq col (1+ col))
)
(vla-SetRowHeight tab row (* 1.6 ht))
(setq row (1+ row))
)
)
(defun getScale ( / result sc)
(setq result 0)
(if (not G_globalScale)
(setq G_globalScale 0.0)
)
(initget )
(setq sc (getreal (strcat "\nScale (Return for " (rtos G_globalScale) "): ")))
(if sc
(progn
(setq G_globalScale sc)
(setq result sc)
)
(setq result G_globalScale)
)
result
)
;set cell background color as layer color
(defun setBGCell (tbl row col layname / acCol acLay enLay adoc)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(setq enLay (vla-item (vla-get-layers adoc) layname))
(setq acCol (vla-get-truecolor enLay))
(vla-setcellbackgroundcolornone tbl row col :vlax-false);allow to background cell
(vla-setcellbackgroundcolor tbl row col acCol);set background using AcCmColor object settings
nil
)
;imposta la larghezza della colonna con incide cl nella tabella tbl
; contenente il testo txt e con un margine specificato da ht
(defun setTableColumnWidth (tbl cl txt ht previousW / x txb width result)
(setq result previousW)
(setq width (apply
'max
(mapcar
'(lambda (x)
((lambda (txb)
(+ (abs (- (caadr txb) (caar txb)))
(* 2.0 ht)
)
)
(textbox
(list
(cons 1
(cond
((eq (type x) 'STR) x)
((eq (type x) 'INT)
(itoa x)
)
((eq (type x) 'REAL)
(rtos x)
)
)
)
(cons 7 (getvar 'textstyle))
(cons 40 ht)
)
)
)
)
txt
)
)
)
(if (< previousW width)
(progn
;(print width)
(vla-SetColumnWidth tbl cl width)
(setq result width)
)
)
result
)