Lisp CountV1-5 for MacBook

Lisp CountV1-5 for MacBook

infoNHT7P
Observer Observer
879 Views
1 Reply
Message 1 of 2

Lisp CountV1-5 for MacBook

infoNHT7P
Observer
Observer

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
)

0 Likes
880 Views
1 Reply
Reply (1)
Message 2 of 2

maxim_k
Consultant
Consultant

Hi @infoNHT7P 

 

Unfortunately it is not possible, because this AutoLISP routine uses Visual LISP functions which are not supported on Mac.


Do you find the posts helpful? "LIKE" these posts!
Have your question been answered successfully? Click 'ACCEPT SOLUTION' button.


Maxim Kanaev
Architect
MARSS

MacACAD | Linkedin

Etiquette and Ground Rules of Autodesk Community
0 Likes