供回（排）水平面图断面绘制
本帖最后由 smartstar 于 2022-12-29 11:36 编辑现在不咋画图了，把自己认为可以拿的出手的程序和大家分享一下，程序注释少，见谅！
注：采用了前辈的函数和思路，在此表示感谢。
(defun c:GDV ()
(vl-load-com)
(or *acad* (setq *acad* (vlax-get-acad-object)))
(or *acdoc* (setq *acdoc* (vla-get-activedocument *acad*)))
(setq *linetypes* (vla-get-linetypes *acdoc*))
(setqmSpace (if (= 1 (getvar 'cvport))
(vla-get-paperspace *acdoc*)
(vla-get-modelspace *acdoc*)
)
)
(setq meaold (getvar "MEASUREMENT"))
(setvar "MEASUREMENT" 1)
(setqc03(getvar "viewctr")
c03(trans c03 1 2)
c08(getvar "viewsize")
c04(getvar "screensize")
c07(car c04)
c06(cadr c04)
c09(/ (* c08 c07) c06)
c010 (list (- (car c03) (* 0.5 c09))
(- (cadr c03) (* 0.5 c08))
)
c020 (list (+ (car c03) (* 0.5 c09))
(- (cadr c03) (* 0.5 c08))
)
c010 (trans c010 2 0)
c020 (trans c020 2 0)
)
(setqgdlist (list "AC-P-CHW-S" "AC-P-CHW-R"
"AC-P-CHW-EXP" "AC-P-CD"
"AC-P-CONDW-S" "AC-P-CONDW-R"
"AC-P-CONDW-EXP" "AC-P-HW-S"
"AC-P-HW-R" "AC-P-HW-EXP"
"AC-P-EXP" "AC-P-FH-EXP"
"AC-P-KCONDW-S" "AC-P-KCONDW-R"
"AC-P-KCONDW-EXP" "AC-P-ST"
"AC-P-SC" "AC-P-DHW-S"
"AC-P-DHW-R" "AC-P-DHW-EXP"
"AC-P-R" "AC-D-CHIMENEY"
"FS-P-S" "FS-P-FH"
"PD-P-HOT-PIPE" "PD-P-HOT-PIPE-R"
"PD-P-COLD-PIPE" "PD-P-FLUSH-PIPE"
"PD-D-SOIL-PIPE" "PD-D-WASTE-PIPE"
"PD-D-SOIL-Y-PIPE" "PD-D-WASTE-Y-PIPE"
"PD-D-SOIL-M-PIPE" "PD-D-WASTE-M-PIPE"
"PD-D-WASTE-K-PIPE" "PD-D-VENT-PIPE"
"PD-D-RAIN-PIPE" "PD-PIPE-SJ"
"PD-WASTE-Y-PIPE" "PD-HOT-PIPE"
)
)
(setqglist (list "AC-P-CHW-S" "AC-P-CONDW-S"
"AC-P-HW-S" "AC-P-KCONDW-S"
"AC-P-ST" "AC-P-DHW-S"
)
)
(setqhlist (list "AC-P-CHW-R" "AC-P-CONDW-R"
"AC-P-CD" "AC-P-HW-R"
"AC-P-KCONDW-R" "AC-P-SC"
"AC-P-DHW-R"
)
)
(setq view_ang (rem (angle c010 c020) (* 2 pi)))
(setq lt "center") ;线型
(setq sc1 0.2) ;(圆、椭圆、矩形……)的中心线的延长倍数
(setq sc3 0.8) ;(圆、椭圆、矩形……)的中心线的自动线型比例(0.8)
(setq sscir (ssget '((0 . "CIRCLE"))))
(setq lst nil)
(foreach en (ss-enlst sscir) ;((图元 圆心)……)
(setq cen_po (vlax-get (vlax-ename->vla-object en) 'center))
(setq lst (cons (list en cen_po) lst))
)
(while (> (length lst) 0) ;直到抽空表为止
(setq lst1 (vl-remove-if-not
'(lambda (x) (equal (cadar lst) (cadr x) 1e-8))
lst
)
) ;查找所有与第一个同心
(foreach en lst1 (setq lst (vl-remove en lst))) ;从总表移除
(setq lst1 (mapcar '(lambda (x) (car x)) lst1))
;得到同心圆表
(if(> (length lst1) 1) ;2个以上进行半径从大至小排序
(setq
lst1 (vl-sort
lst1
(function
(lambda (a b)
(> (vla-get-radius (vlax-ename->vla-object a))
(vla-get-radius (vlax-ename->vla-object b))
)
)
)
)
)
)
(setq en (car lst1))
(setq cen_po (vlax-get (vlax-ename->vla-object en) 'center))
(setq rr (vla-get-radius (vlax-ename->vla-object en)))
(setq lay (strcase (vlax-get (vlax-ename->vla-object en) 'layer)))
(setq col 8)
;;(setq col (vlax-get (vlax-ename->vla-object en) 'color))
(setq ll (* sc1 (* rr 2)))
(setq p1 (polar cen_po (+ view_ang 0) (+ rr ll)))
(setq p2 (polar cen_po (+ view_ang pi) (+ rr ll)))
(setq p3 (polar cen_po (+ view_ang (/ pi 2)) (+ rr ll)))
(setq p4 (polar cen_po (+ view_ang (* pi 1.5)) (+ rr ll)))
(applt lt) ;加载线型
;(applt "center")
(if(member lay gdlist)
(progn
;(LineFormat (make-line p1 p2) lay lt sc3 col)
(make-line lt lay p1 p2 sc3 col)
;(LineFormat (make-line p3 p4) lay lt sc3 col)
(make-line lt lay p3 p4 sc3 col)
)
)
(setq lst1 (reverse lst1))
(setq ent (car lst1))
(setq cpt (vlax-get (vlax-ename->vla-object ent) 'center))
(setq r (vla-get-radius (vlax-ename->vla-object ent)))
(setq pt1 (polar cpt (+ (/ pi 2) view_ang) r))
(setq pt2 (polar cpt (+ (+ pi (/ pi 2)) view_ang) r))
(setq pt3 (polar cpt (+ (/ pi 4) view_ang) r))
(setq pt4 (polar cpt (+ (+ pi (/ pi 4)) view_ang) r))
(setq lay (strcase (vlax-get (vlax-ename->vla-object ent) 'layer)))
(if(member lay gdlist)
(if (> (length lst1) 1)
(progn
(if (member lay hlist)
(make-dr pt3 pt4 lay)
)
(if (member lay glist)
(make-so pt1 pt2 cpt lay)
)
(setq ent1 (cadr lst1))
(setq r0 (vla-get-radius (vlax-ename->vla-object ent1)))
(setq en-vl (vlax-ename->vla-object ent))
(setq en-vl1 (vlax-ename->vla-object ent1))
(setq patternName "net")
;;;填充样式NET
(setq patternType 0)
(setq bAssociativity :vlax-true)
(setq
hatch (vla-AddHatch
mSpace
patternType
patternName
bAssociativity
)
)
;|
(if (< (setq sca (/ r0 30)) 8)
(setq sca 8)
(if(> sca 15)
(setq sca 15)
)
)
|;
(setq sca (/ r0 25))
(vlax-invoke hatch 'appendouterloop (list en-vl1))
(vlax-invoke hatch 'AppendInnerLoop (list en-vl))
(vlax-put-property hatch 'patternscale sca) ;比例
(vlax-put-property hatch 'color 8) ;颜色
(vlax-put-property hatch 'layer lay) ;图层
(vlax-put-property hatch 'PatternAngle 0.7854) ;角度
(vla-evaluate hatch)
(vla-put-color
(vlax-ename->vla-object ent1)
8
)
)
(progn
(if (member lay hlist)
(make-dr pt3 pt4 lay)
)
(if (member lay glist)
(make-so pt1 pt2 cpt lay)
)
)
)
)
)
(setvar "MEASUREMENT" meaold)
(princ)
)
;;;排水
(defun make-dr (pt1 pt2 lay)
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 70 0)
(cons 8 lay)
(cons 90 3)
(cons 10 pt1)
(cons 42 0)
(cons 10 pt2)
(cons 42 -1)
(cons 10 pt1)
(cons 42 1)
)
)
(setq en-vl (vlax-ename->vla-object (entlast)))
(setq patternName "line")
;;;填充样式LINE
(setq patternType 0)
(setq bAssociativity :vlax-true)
(setq hatch nil)
(setq
hatch (vla-AddHatch mSpace patternType patternName bAssociativity)
)
(vlax-invoke hatch 'appendouterloop (list en-vl))
(vlax-put-property hatch 'patternscale (/ r 25)) ;比例
(vlax-put-property hatch 'color 8);颜色
(vlax-put-property hatch 'layer lay);图层
(vlax-put-property hatch 'PatternAngle 1.571) ;角度
;;(vla-evaluate hatch)
)
;;;给水
(defun make-so (pt1 pt2 cpt lay)
;|
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 70 0)
(cons 8 lay)
(cons 90 4)
(cons 10 pt2)
(cons 42 1)
(cons 10 cpt)
(cons 42 -1)
(cons 10 pt1)
(cons 42 1)
(cons 10 pt2)
(cons 42 -1)
)
)
|;
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 70 0)
(cons 8 lay)
(cons 90 4)
(cons 10 pt1)
(cons 42 -1)
(cons 10 cpt)
(cons 42 1)
(cons 10 pt2)
(cons 42 -1)
(cons 10 pt1)
(cons 42 1)
)
)
(setq en-vl (vlax-ename->vla-object (entlast)))
(setq patternName "line")
;;;填充样式LINE
(setq patternType 0)
(setq bAssociativity :vlax-true)
(setq hatch nil)
(setq
hatch (vla-AddHatch mSpace patternType patternName bAssociativity)
)
(vlax-invoke hatch 'appendouterloop (list en-vl))
(vlax-put-property hatch 'patternscale (/ r 25)) ;比例
(vlax-put-property hatch 'color 8);颜色
(vlax-put-property hatch 'layer lay);图层
(vlax-put-property hatch 'PatternAngle 1.571) ;角度
(vla-evaluate hatch)
)
(defun LineFormat (obj lay lt sc col / qm40) ;线的格式
;;;参数
;;;obj图元名/obj对象
;;;lay图层
;;;lt 线型
;;;sc 比例，圆0.8/线0.4
;;;col颜色
(vl-load-com)
(if (= (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
(vla-put-layer obj lay)
(vla-put-Linetype obj lt)
(vla-put-Color obj col)
(setq qm40 (cdr (assoc 40 (tblsearch "ltype" lt))))
(if (and (/= qm40 0) (/= sc 0))
(vla-put-LinetypeScale
obj
(* (vla-get-Length obj) (/ sc qm40 (getvar "LTSCALE")))
)
)
(vla-update obj)
(princ)
)
(defun make-line (lt lay pt1 pt2 sc col) ;生成一条line
;;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z)
(setq qm40 (cdr (assoc 40 (tblsearch "ltype" lt))))
(setq sc (* (distance pt1 pt2) (/ sc qm40 (getvar "LTSCALE"))))
(entmakex
(list
'(0 . "line")
(cons 6 lt)
(cons 8 lay)
(cons 10 pt1)
(cons 11 pt2)
(cons 48 sc)
(cons 62 col)
)
)
)
;|
(defun make-line (pt1 pt2) ;生成一条line
;;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z)
(entmakex (list '(0 . "line") (cons 10 pt1) (cons 11 pt2)))
)
|;
(defun ss-enlst(ss / enlst) ;选择集与对象名表互转
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not
'(lambda (x) (= (type x) 'ENAME))
(mapcar 'cadr (ssnamex SS))
)
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
)
)
(defun applt (lt/)
(vl-load-com)
(or *acad* (setq *acad* (vlax-get-acad-object)))
(or *acdoc* (setq *acdoc* (vla-get-activedocument *acad*)))
(setq *linetypes* (vla-get-linetypes *acdoc*))
(setqmSpace (if (= 1 (getvar 'cvport))
(vla-get-paperspace *acdoc*)
(vla-get-modelspace *acdoc*)
)
)
(if (not (tblsearch "ltype" lt))
(progn
(if (or
(not (vl-catch-all-apply
'vla-load
(list *linetypes*
lt
"acadiso.lin"
)
)
)
(not (vl-catch-all-apply
'vla-load
(list *linetypes*
lt
"acad.lin"
)
)
)
)
(princ (strcat "\n线型" lt "成功加载"))
(princ (strcat "\n线型" lt "加载失败."))
)
)
)
(princ)
)
本帖最后由 lxl217114 于 2022-12-29 13:28 编辑
谢谢分享
--------------------------------------------------------------
为啥最近论坛回复，会变成奇怪的符号了？
谢谢楼主分享 谢谢楼主分享!!!! -函数类;
3 支持括号自动输入;
4 中文状态下从第二备选词开始,不影响平时打字;
5 通过vbs简单语句切换编程模式和正常办公 什么东西啊？那么神秘，看一眼都要钱！
页:
[1]