lisp自动生成中垂线_晓东CAD家园-论坛-外挂实用工具-[LISP程序]：生成序号球时自动连带生成明细表-功能：可依点击诸零件自动生成所点击数目的序号球；自动左右对齐和决定明细表表头上下位置；可选...

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要 登录 才可以下载或查看，没有帐号？立即注册

x

功能：可依点击诸零件自动生成所点击数目的序号球；

自动左右对齐和决定明细表表头上下位置；

可选序号球排列所在直线(水平或垂直)；

即时输入零件名称及材料数量等；

可选明细表栏目宽度，行高，字高；

可选序号球引线端部结构。

请试用，并提出意见。

[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]

广告位，后台可以设置，支持js

您好，您暂时不能浏览帖子的全部内容，请 登录

| 没有账号？ 请 注册