供回（排）水平面图断面绘制

smartstar · 发表于 2022-12-29 11:32:54

本帖最后由 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*))
(setq mSpace (if (= 1 (getvar 'cvport))
(vla-get-paperspace *acdoc*)
(vla-get-modelspace *acdoc*)
)
)
(setq meaold (getvar "MEASUREMENT"))
(setvar "MEASUREMENT" 1)
(setq c03 (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)
)
(setq gdlist (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"
)
)
(setq glist (list "AC-P-CHW-S" "AC-P-CONDW-S"
"AC-P-HW-S" "AC-P-KCONDW-S"
"AC-P-ST" "AC-P-DHW-S"
)
)
(setq hlist (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*))
(setq mSpace (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)
)

(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*)) 
  (setq  mSpace (if (= 1 (getvar 'cvport)) 
     (vla-get-paperspace *acdoc*) 
     (vla-get-modelspace *acdoc*) 
         ) 
  ) 
  (setq meaold (getvar "MEASUREMENT")) 
  (setvar "MEASUREMENT" 1) 
  (setq  c03  (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) 
  ) 
  (setq  gdlist (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" 
        ) 
  ) 
 
  (setq  glist (list "AC-P-CHW-S"       "AC-P-CONDW-S" 
        "AC-P-HW-S"         "AC-P-KCONDW-S" 
        "AC-P-ST"         "AC-P-DHW-S" 
       ) 
  ) 
  (setq  hlist (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*)) 
  (setq  mSpace (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 12:03:14

本帖最后由 lxl217114 于 2022-12-29 13:28 编辑

谢谢分享

--------------------------------------------------------------
为啥最近论坛回复，会变成奇怪的符号了？

中国梦 · 发表于 2022-12-29 20:07:48

谢谢楼主分享

杜阳 · 发表于 2023-1-8 21:12:00

yoyoho · 发表于 2023-1-8 23:31:25

谢谢楼主分享!!!!

xiahaibo1314 · 发表于 2023-1-9 08:53:14

-函数类;
3 支持括号自动输入;
4 中文状态下从第二备选词开始,不影响平时打字;
5 通过vbs简单语句切换编程模式和正常办公

myairen · 发表于 2023-1-28 04:08:45

什么东西啊？那么神秘，看一眼都要钱！

账号		自动登录	找回密码
密码			注册

[源码] 供回（排）水平面图断面绘制

本帖子中包含更多资源

评分