[LISP程序]：生成序号球时自动连带生成明细表

lsjjm

功能：可依点击诸零件自动生成所点击数目的序号球；
自动左右对齐和决定明细表表头上下位置；
可选序号球排列所在直线（水平或垂直）；
即时输入零件名称及材料数量等；
可选明细表栏目宽度，行高，字高；
可选序号球引线端部结构。
请试用，并提出意见。
[PHP]
(defun c:test (/ ee pl)
  (setvar "osmode" 0)
  (setq index (load_dialog (findfile "dial.dcl")))
  (if (not (new_dialog "dbom" index))(exit))
  ;(imagep)
  (setq tlist (list "Arrow" "Dot" "Blank" ""))
  (start_list "ttype")
  (mapcar 'add_list tlist)   
  (end_list)
  (action_tile "pick" "(setq  h (atof (get_tile \"h\"))
                             th (atof (get_tile \"th\"))
                             c1 (atof (get_tile \"c1\"))
                             c2 (atof (get_tile \"c2\"))
                             c3 (atof (get_tile \"c3\"))
                             c4 (atof (get_tile \"c4\")))                        
    (done_dialog 2)")
  (action_tile "cancel" "(setq lp 1)(exit)")
  (setq do_what (start_dialog))
  (if (= do_what 2)
    (while (setq p (getpoint "\nPick Point in Part: "))(setq pl (cons p pl)))
  )
  (unload_dialog index)
  (setq sn 1)
  (setq  r (* 1.2 th))
  (setvar "orthomode" 1)
  (setq ps (getpoint "\nPick the First Point: "))
  (setq pe (getpoint ps "\nPick the First Point: "))
  (if (equal (cadr ps)(cadr pe) 0.0001)
    (setq pl (vl-sort pl '(lambda (p1 p2)(< (car p1)(car p2)))))
    (setq pl (vl-sort pl '(lambda (p1 p2)(< (cadr p1)(cadr p2)))))
  )   
  (if (or (> (car ps)(car pe))(> (cadr ps)(cadr pe)))
    (setq pl (reverse pl))
  )      
  (setq l (/ (distance ps pe)(1- (length pl))))
  ;(mlayer "dim" 4 "continous")
  (setq n 0)
  (while (< n (length pl))
    (vl-cmdf "circle" ps r)
    (vl-cmdf "text" "j" "m" ps th 0 (itoa (1+ n)) "")
    (setq pte (polar ps (angle ps (nth n pl)) r))
    (command "leader" (nth n pl) pte "" "" "n")
    (setq ps (polar ps (angle ps pe) l))
    (setq n (1+ n))
  )
  (setq row (length pl))
  (setvar "osmode" 37)
  (setq p0 (getpoint "\nPick Insert Point of BOM: "))
  (setq cl (list c1 c2 c3 c4))
  (bom p0 row h th cl)
  (setvar "osmode" 37)
)
;
(defun bom (p0 row h th cdlst)
  (setvar "osmode" 0)      
  (vl-load-com)
  (setq vps (vla-get-Viewports (vla-get-activedocument (vlax-get-acad-object))))
  (setq ss 0)
  (setq tdlst (mapcar '(lambda(x)(setq s (+ ss (/ x 2.0)) ss (+ ss x)) s) cdlst))
  (setq w (apply '+ cdlst))
  (setq txt (list "ITEM" "PART NUMBER" "DWG.No" "QTY."))
  (setq pvc (vlax-get (vla-item vps 0) "center"))
  (setq ee (ssget "f" (list (polar p0 (/ pi 4) 0.001)(polar p0 (* 1.25 pi) 0.001))))
  (if (and ee (> (car p0)(car pvc)))(setq p0 (polar p0 pi w)))
  (if (and ee (< (cadr p0)(cadr pvc)))(setq h (- h)))
  (setq ss0 (ssget "x" '((0 . "*LINE,TEXT,ATTDEF"))))
  (setq n 0)
  (while (< n (length tdlst))
    (setq pt (list (+ (car p0)(nth n tdlst))(- (cadr p0)(/ h 2))))      
    (vl-cmdf "text" "j" "mc" pt th 0 (nth n txt) "")
    (setq n (1+ n))
  )
  (vl-cmdf "line" p0 (polar p0 0 w) "")
  (vl-cmdf "array" (entlast) "" "r" (+ row 2) 1 (- h) "")
  (vl-cmdf "line" p0 (polar p0 (* 1.5 pi)(* (1+ row) h)) "")
  (foreach i cdlst (vl-cmdf "offset" i (entlast)(polar p0 0 w) ""))
  (setq ss (ssget "x" '((0 . "*LINE,TEXT,ATTDEF"))))
  (vl-cmdf "select" ss "r" ss0 "")
  (setq ss3 (ssget "p"))
  (setq A (rtos (* (getvar "CDATE") 1E8)))
  (vl-cmdf "block" A p0 ss3 "")
  (vl-cmdf "insert" A p0 "" "" "")
  (setq aa (entlast))      
  (setq i 1 n 1)
  (vl-cmdf "-color" "6" "")
  (while (<= i row)
    (setq j 0)
    (while (< j 4)
      (setq ipt (list (+ (car p0)(nth j tdlst))(- (cadr p0)(* i h)(/ h 2))))
      (if (= j 0)     
        (addatttoblock aa th "" ipt (strcat "T" (itoa n))(itoa i))
        (addatttoblock aa th "" ipt (strcat "T" (itoa n))
                                (strcase (getstring (strcat "\n" (nth j txt) ": "))))
      )
      (setq aa (entlast))
      (setq n (1+ n))
      (setq j (1+ j))
    )
    (setq i (1+ i))
  )
  (setvar "cecolor" "BYLAYER")
)
;
(defun addatttoblock (blk h prom ptatt tag v)       ;25/08/03
  (setq doc (vla-get-activedocument (vlax-get-acad-object))
        obj (vlax-ename->vla-object blk)
      ptblk (vlax-safearray->list
            (vlax-variant-value (vla-get-insertionpoint obj)))
     blkdef (vla-item (vla-get-blocks doc)(vla-get-name obj)))
  (setq ptatt (vlax-3d-point (mapcar '- ptatt ptblk))
       attdef (vla-addattribute blkdef h acAttributeModeverify prom ptatt tag v))
  (vla-put-alignment attdef 10)
  (vla-put-textalignmentpoint attdef ptatt)
  (setq blkref (vla-insertblock
             (vla-get-paperspace doc)
             (vlax-3d-point ptblk)
             (vla-get-name blkdef)
             (vla-get-xscalefactor obj)
             (vla-get-yscalefactor obj)
                 (vla-get-zscalefactor obj)
                 (vla-get-rotation obj)
           )
  )
  (vla-delete obj)
  (princ)
)
;
dbom : dialog { label = "Smart Bom Generator:";        
  : row {
    : boxed_column {label="Arrow Type:";
      : popup_list {key="ttype"; edit_width =11;}
    }
    : column {
      : edit_box {label = "DisofRow:"; key = "h"; value="0.197"; edit_width = 4;}
      : edit_box {label = "TextHeight:"; key = "th"; value="0.08"; edit_width = 4;}
    }
  }
  spacer;
  : text_part {label="Width of Columns:";}
  :row {
    : boxed_column  {label = "Col1";      
      : edit_box { key = "c1"; value="0.394"; edit_width = 4;}
    }
    : boxed_column  {label = "Col2";      
      : edit_box { key = "c2"; value="1.26"; edit_width = 4;}
    }
    : boxed_column  {label = "Col3";   
      : edit_box { key = "c3"; value="0.952"; edit_width = 4;}
    }
    : boxed_column  {label = "Col4";   
      : edit_box { key = "c4"; value="0.394"; edit_width = 4;}
    }
  }
  spacer;
  : row {
    : button {label="Pick Points for Parts"; key="pick"; }
    cancel_button;
  }
  : row {
    : image { key = "im" ; width = 4; fixed_width= true;}
    : paragraph {
      : text_part { label = "Designed and Created"; alignment=right;}
      : text_part { label = "by Richard Liang"; alignment=right;}
    }
  }
}
[/PHP]

LUCAS

(bom p0 row h th cl) ----->CL ??

coolyxw

楼主程序用不了,加载后运行test没有任何反映

lsjjm

谢谢斑竹指正，丢了一行：
(setq cl (list c1 c2 c3 c4))

LUCAS

2. 
   
3. ;;這樣模型空間&圖紙空間都能用!
   
4. (setq        BLKREF (vla-insertblock
   
5.                  (if (or (= (getvar "TILEMODE") 1)
   
6.                          (> (getvar "CVPORT") 1)
   
7.                      )
   
8.                    (vla-get-modelspace DOC)
   
9.                    (vla-get-paperspace DOC)
   
10.                  )
    
11.                  (vlax-3d-point PTBLK)
    
12.                  (vla-get-name BLKDEF)
    
13.                  (vla-get-xscalefactor OBJ)
    
14.                  (vla-get-yscalefactor OBJ)
    
15.                  (vla-get-zscalefactor OBJ)
    
16.                  (vla-get-rotation OBJ)
    
17.                )
    
18.   )
    

<br /> ;;這樣模型空間&圖紙空間都能用!<br /> (setq        BLKREF (vla-insertblock<br />                  (if (or (= (getvar "TILEMODE") 1)<br />                          (> (getvar "CVPORT") 1)<br />                      )<br />                    (vla-get-modelspace DOC)<br />                    (vla-get-paperspace DOC)<br />                  )<br />                  (vlax-3d-point PTBLK)<br />                  (vla-get-name BLKDEF)<br />                  (vla-get-xscalefactor OBJ)<br />                  (vla-get-yscalefactor OBJ)<br />                  (vla-get-zscalefactor OBJ)<br />                  (vla-get-rotation OBJ)<br />                )<br />   )<br />