数量LISP
大家好，我很喜欢这里的内容，我想我的问题可能是针对那些更高级的LISP人员的（我还是个新手，一直在努力让它工作）。
我一直在尝试把一个LISP放在一起，通过一个图形创建一个数量表，我附上了一个示例图形，我一直在使用它来工作，以及一个将作为输出的表格的示例。
基本上，目标是插入LISP，选择需要的线/层/块，并用总长度生成表格。
我希望有人在那里帮助我，或者至少为我指明正确的方向，
谢谢！
罗泰克
示例_数量LISP。图纸 欢迎
可能不是你所期望的，而是一些可以被大量使用的东西。
需要调整和一些额外的错误捕捉。
这应该适用于所有版本的AutoCAd，可能也适用于Briscad
;;;1.1
(defun c:cnt-q (/ ss i en ed et bn la ll bl bf lf un bc bn tn bs
mxb mxl rx lx sp s z xp yp ls lt)
(setvar "DIMZIN" 0)
(while (not ss)
(princ "\nSelect Entities To Count: ")
(setq ss (ssget (list (cons 0 "*LINE,INSERT,ARC,")))))
(setq i 0)
(while (setq en (ssname ss i))
(setq ed (entget en)
et (cdr (assoc 0 ed))
bn (cdr (assoc 2 ed))
la (cdr (assoc 8 ed)))
(and (not (member la ll))
(setq ll (cons la ll)))
(and bn
(not (member bn bl))
(setq bl (cons bn bl)))
(setq i (1+ i)))
(and bl (setq bl (acad_strlsort bl)))
(foreach b bl
(setq bs (ssget "X" (list (cons 0 "INSERT")(cons 2 b))))
(setq i 0)
(while (setq en (ssname bs i))
(setq ed (entget en))
(cond ((not (ssmemb en ss)))
((assoc b bf)
(setq bf (subst (cons b (1+ (cdr (assoc b bf))))
(assoc b bf) bf)))
(T
(setq bf (cons (cons b 1) bf))))
(setq i (1+ i))))
(and ll (setq ll (acad_strlsort ll)))
(foreach l ll
(setq lt 0)
(and (setq ls (ssget "X" (list (cons 0 "*LINE,ARC")
(cons 8 l))))
(setq i 0)
(while (setq en (ssname ls i))
(if (ssmemb en ss)
(progn
(command "_.AREA" "_E" en)
(setq lt (+ lt (getvar "PERIMETER")))))
(setq i (1+ i))))
(setq lf (cons (cons l (rtos lt 2 0)) lf)))
(setq un (rtos (* (getvar "TDCREATE") 1e+6) 2 0)
bc 1
bn (strcat un "-T" (itoa bc)))
(while (tblsearch "BLOCK" bn)
(setq bc (1+ bc)
bn (strcat un "-T" (itoa bc))))
(if bn
(setq mxb (apply 'max (mapcar 'strlen bl)))
(setq mxb 0))
(if ll
(setq mxl (apply 'max (mapcar 'strlen ll)))
(setq mxl 0))
(setq lx (- (+ (max mxl mxb) 6)))
(setq rx (+ 16))
(if (and (not (tblsearch "STYLE" "MROMANS"))
(findfile "MROMANS.SHX"))
(progn
(command "_.STYLE" "MROMANS" "MROMANS")
(while (> (getvar "CMDACTIVE") 0)
(command ""))))
(entmake (list (cons 0 "BLOCK")(cons 2 bn)(cons 8 "0")(list 10 0 0 0)(cons 70 2)))
(entmake (list (cons 0 "LINE")
(cons 8 "0")
(cons 62 7)
(list 10 0 0 0)
(list 11 0 2 0)))
(entmake (list (cons 0 "LINE")
(cons 8 "0")
(cons 62 7)
(list 10 lx 0 0)
(list 11 rx 0 0)))
(entmake (list (cons 0 "LINE")
(cons 8 "0")
(cons 62 7)
(list 10 lx 2 0)
(list 11 rx 2 0)))
(entmake (list (cons 0 "LINE")
(cons 8 "0")
(cons 62 7)
(list 10 lx 0 0)
(list 11 lx 2 0)))
(entmake (list (cons 0 "LINE")
(cons 8 "0")
(cons 62 7)
(list 10 rx 0 0)
(list 11 rx 2 0)))
(entmake (list (cons 0 "ATTDEF")
(cons 1 "")
(cons 2 "DVAL")
(cons 3 "VALUE DESCRIPTION")
(cons 7 "MROMANS")
(cons 8 "0")
(list 10 -3 1 1)
(list 11 -3 1 1)
(cons 40 1.0)
(cons 62 2)
(cons 70 0)
(cons 72 2)
(cons 74 2)))
(entmake (list (cons 0 "ATTDEF")
(cons 1 "")
(cons 2 "TVAL")
(cons 3 "TOTAL VALUE")
(cons 7 "MROMANS")
(cons 8 "0")
(list 10 3 1 1)
(list 11 3 1 1)
(cons 40 1.0)
(cons 62 2)
(cons 70 0)
(cons 72 0)
(cons 74 2)))
(setq tn (entmake (list (cons 0 "ENDBLK")(cons 8 "0"))))
(initget 1)
(setq sp (getpoint "\nTable Starting Point: "))
(initget 6)
(setq s (getdist (strcat "\nText size <" (rtos (getvar "TEXTSIZE") 2 2) ">: ")))
(or s (setq s (getvar "TEXTSIZE")))
(setq s (* s 0.5)
z (* s 2)
xp (car sp)
yp (cadr sp))
(setvar "ATTREQ" 1)
;;;BLOCKS
(command "_.INSERT" tn (list xp yp 0) z z 0 "BLOCKS" "QTY")
(setq yp (- yp z z))
(foreach v (reverse bf)
(command "_.INSERT" tn (list xp yp 0) z z 0 (car v) (cdr v))
(setq yp (- yp z z)))
(command "_.INSERT" tn (list xp yp 0) z z 0 "" "")
(setq yp (- yp z z))
;;;LAYERS
(command "_.INSERT" tn (list xp yp 0) z z 0 "LAYERS" "LENGTH")
(setq yp (- yp z z))
(foreach v (reverse lf)
(command "_.INSERT" tn (list xp yp 0) z z 0 (car v) (cdr v))
(setq yp (- yp z z)))
(command "_.INSERT" tn (list xp yp 0) z z 0 "" "")
(setq yp (- yp z z))
(prin1))
-大卫 这对于表格创建示例可能也很有用，而不是直线等。如果你回顾几篇文章，我会将行添加到现有表格中，这样你就可以执行拾取层添加行并继续拾取层，以弧、块、线等作为列。
一天有25个小时，不是吗？
; start in model space
; example of creating a table
; By Alan H
(defun c:sct (/ colwidth numcolumns numrows objtable rowheight sp mspace )
(vl-load-com)
(setq sp (vlax-3d-point '(0 0 0)))
(setq doc(vla-get-activedocument (vlax-get-acad-object) ))
(setq mspace (vla-get-modelspace doc))
(setq numrows 5)
(setq numcolumns 5)
(setq rowheight 0.5)
(setq colwidth 30)
(setq objtable (vla-addtable mspace sp numrows numcolumns rowheight colwidth))
; RetVal = object.AddTable(InsertionPoint, NumRows, NumColumns, RowHeight, ColWidth)
(vla-settext objtable 0 0 "TABLE title")
(vla-settext objtable 1 0 "ITEM")
(vla-settext objtable 1 1 "Straights")
(vla-settext objtable 1 2 "Arcs")
(vla-settext objtable 1 3 "Laterals")
(vla-settext objtable 1 4 "Connections")
(vla-settext objtable 2 0 "1")
(vla-settext objtable 3 0 "2")
(vla-settext objtable 4 0 "3")
(vla-setcolumnwidth objtable 0 15) ; 0 is first column
(vla-setcolumnwidth objtable 1 30)
(vla-setcolumnwidth objtable 2 60)
(command "_zoom" "e")
(princ)
)
(C:sct) 首先请注意，水阀块位于第0层，因此没有帮助
; make a table here if required else pick existing
; defun add row totable here
(defun c:qty ( / lay totline bcount)
(while
(Setq lay (cdr (assoc 8 (entget (car (entsel "Pick object for layer <Cr> to exit "))))))
(setq totline 0.0
bcount 0
ss nil)
(princ "\nPick objects")
(setq ss (ssget (list (cons 0 "*LINE,INSERT,ARC,")(cons 8 lay))))
(repeat (setq x (sslength ss))
(setq obj(vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
(setq objname (vla-get-ObjectName obj))
(cond
((or (= objname "AcDbPolyline" )(= objname "AcDbLine" )) (setq totline (+ (vla-get-length obj) totline)))
((= objname "AcDbBlockReference") (setq bcount (+ 1 bcount))) ; need a split blocks here
)
)
(alert (strcat "length" (rtos totline 2 0) " or \nCount = " (rtos bcount 2 0)))
;do the add rows to table here note can seperate the valves from lengths and put in seperate column
(if (> totline 0)(setq coll 1)) ; this is column number for lines
(if (> bcount 0)(setq colb 2)) ; this column number for blocks
)
)
(C:qty)
页:
[1]