求一个单纯的洞口线插件

yefei812678

就这样的一个单纯洞口线插件

liuhe

2. (PROMPT "\n作者:流河  QQ：859779429")
   
3. (PROMPT "\n 快捷键 TT")
   
4. (DEFUN C:TT (/ THISDRAWING PT1 PT2 PLST E)
   
5.   (setq        thisdrawing
   
6.          (vla-get-activedocument
   
7.            (vlax-get-acad-object)
   
8.          )
   
9.   )
   
10.   (VLA-STARTUNDOMARK THISDRAWING)
    
11.   (setq
    
12.     pt1        (getpoint (STRCAT "\n窗交对象:指定角点1"))
    
13.   )
    
14.   (if (not pt1)
    
15.     (vl-exit-with-value 0)
    
16.   )
    
17.   (setq pt2 (getcorner pt1 (STRCAT "\n窗交对象:指定角点2:")))
    
18.   (IF (NOT PT2)
    
19.     (VL-EXIT-WITH-VALUE 0)
    
20.   )
    
21.   (SETQ        PLST (LIST PT1 PT2)
    
22.         PLST (VL-SORT PLST
    
23.                       (FUNCTION (LAMBDA (E1 E2) (> (CAR E1) (CAR E2))))
    
24.              )
    
25.         PLST (LIST (CAR PLST)
    
26.                    (LIST (CAR (CAR PLST)) (CADR (CADR PLST)))
    
27.                    (CADR PLST)
    
28.              )
    
29.         PLST (LIST (CAR PLST)
    
30.                    (POLAR (CADR PLST)
    
31.                           (ANGLE (CADR PLST) (LH:MID PT1 PT2))
    
32.                           (* 0.3 (DISTANCE (CADR PLST) (LH:MID PT1 PT2)))
    
33.                    )
    
34.                    (CADDR PLST)
    
35.              )
    
36.         E    (LH:MakeLWPOLYLINE PLST)
    
37.   )
    
38.   (IF (NOT (tblsearch "LTYPE" "ACAD_ISO02W100"))
    
39.     (vl-catch-all-apply
    
40.       'vla-Load
    
41.       (list (vla-get-Linetypes
    
42.               (vla-get-ActiveDocument (vlax-get-acad-object))
    
43.             )
    
44.             "ACAD_ISO02W100"
    
45.             "acad.lin"
    
46.       )
    
47.     )
    
48.   )
    
49.   (vla-put-Linetype (vlax-ename->vla-object E) "ACAD_ISO02W100")
    
50.   (vla-put-LinetypeScale
    
51.     (vlax-ename->vla-object E)
    
52.     (ABS (* (DISTANCE (CAR PLST) (CADDR PLST)) 0.01))
    
53.   )
    
54.   (vla-endundomark thisdrawing)
    
55.   (princ)
    
56. )
    
57. (defun LH:MID (po1 po2)
    
58.   (MAPCAR '(lambda (X Y) (* (+ X Y) 0.5)) po1 po2)
    
59. )
    
60. ;;167.3 [功能] Entmake点表生成多段线
    
61. (defun LH:MakeLWPOLYLINE (lst / PT)
    
62.   (entmakeX
    
63.     (append
    
64.       (list '(0 . "LWPOLYLINE")
    
65.             '(100 . "AcDbEntity")
    
66.             '(100 . "AcDbPolyline")
    
67.             (cons 90 (length lst))
    
68.       )
    
69.       (mapcar '(lambda (pt) (cons 10 pt)) lst)
    
70.     )
    
71.   )
    
72. )

(PROMPT "\n作者:流河  QQ：859779429")<br /> (PROMPT "\n 快捷键 TT")<br /> (DEFUN C:TT (/ THISDRAWING PT1 PT2 PLST E)<br />   (setq        thisdrawing<br />          (vla-get-activedocument<br />            (vlax-get-acad-object)<br />          )<br />   )<br />   (VLA-STARTUNDOMARK THISDRAWING)<br />   (setq<br />     pt1        (getpoint (STRCAT "\n窗交对象:指定角点1"))<br />   )<br />   (if (not pt1)<br />     (vl-exit-with-value 0)<br />   )<br />   (setq pt2 (getcorner pt1 (STRCAT "\n窗交对象:指定角点2:")))<br />   (IF (NOT PT2)<br />     (VL-EXIT-WITH-VALUE 0)<br />   )<br />   (SETQ        PLST (LIST PT1 PT2)<br />         PLST (VL-SORT PLST<br />                       (FUNCTION (LAMBDA (E1 E2) (> (CAR E1) (CAR E2))))<br />              )<br />         PLST (LIST (CAR PLST)<br />                    (LIST (CAR (CAR PLST)) (CADR (CADR PLST)))<br />                    (CADR PLST)<br />              )<br />         PLST (LIST (CAR PLST)<br />                    (POLAR (CADR PLST)<br />                           (ANGLE (CADR PLST) (LH:MID PT1 PT2))<br />                           (* 0.3 (DISTANCE (CADR PLST) (LH:MID PT1 PT2)))<br />                    )<br />                    (CADDR PLST)<br />              )<br />         E    (LH:MakeLWPOLYLINE PLST)<br />   )<br />   (IF (NOT (tblsearch "LTYPE" "ACAD_ISO02W100"))<br />     (vl-catch-all-apply<br />       'vla-Load<br />       (list (vla-get-Linetypes<br />               (vla-get-ActiveDocument (vlax-get-acad-object))<br />             )<br />             "ACAD_ISO02W100"<br />             "acad.lin"<br />       )<br />     )<br />   )<br />   (vla-put-Linetype (vlax-ename->vla-object E) "ACAD_ISO02W100")<br />   (vla-put-LinetypeScale<br />     (vlax-ename->vla-object E)<br />     (ABS (* (DISTANCE (CAR PLST) (CADDR PLST)) 0.01))<br />   )<br />   (vla-endundomark thisdrawing)<br />   (princ)<br /> )<br /> (defun LH:MID (po1 po2)<br />   (MAPCAR '(lambda (X Y) (* (+ X Y) 0.5)) po1 po2)<br /> )<br /> ;;167.3 [功能] Entmake点表生成多段线<br /> (defun LH:MakeLWPOLYLINE (lst / PT)<br />   (entmakeX<br />     (append<br />       (list '(0 . "LWPOLYLINE")<br />             '(100 . "AcDbEntity")<br />             '(100 . "AcDbPolyline")<br />             (cons 90 (length lst))<br />       )<br />       (mapcar '(lambda (pt) (cons 10 pt)) lst)<br />     )<br />   )<br /> )

newmooooon

2. (defun c:dk( / mydefunction dk_bili dk_min dk_layer)
   
3.         (setq dk_bili 0.2 ;引线比例
   
4.                         dk_min 50 ;折线最小距离
   
5.                         dk_layer "SE_HOLE"
   
6.         );;变量设置
   
7.         (if (not (tblsearch "LAYER" "SE_HOLE"))
   
8.                 (progn
   
9.                         (entmake (list '(0 . "LAYER")
   
10.                                                                 '(100 . "AcDbSymbolTableRecord")
    
11.                                                                 '(100 . "AcDbLayerTableRecord")
    
12.                                        '(70 . 0)
    
13.                                        '(62 . 201)
    
14.                                        '(6 . "Continuous")
    
15.                                        '(2 . "SE_HOLE")))
    
16.                 )
    
17.         )
    
18.         (defun dk::draw_dk(/ dis dx x y pt2 pt3 dk_distance);(hcl_make_rec p1 p2 "0" 1 40)
    
19. ;                (setq dk_distance (* (distance pt1 pt0) (- 0.5 dk_bili))
    
20. ;                                pt2 (point_mid pt0 pt1)
    
21. ;                                pt2 (polar pt2 (- pi (angle pt0 pt1)) dk_distance)
    
22. ;                )
    
23.                 (setq dis (* (min (abs (- (car pt1) (car pt0))) (abs (- (cadr pt1) (cadr pt0)))) dk_bili)
    
24.                                 dis (max dis dk_min)
    
25.                 )
    
26.                 (if (< (car pt0) (car pt1))
    
27.                         (setq dx dis)
    
28.                         (setq dx (- dis))
    
29.                 )
    
30.                 (setq x (+ (car pt0) dx))
    
31. 
    
32.                 (if (< (cadr pt0) (cadr pt1))
    
33.                         (setq dx dis)
    
34.                         (setq dx (- dis))
    
35.                 )
    
36.                 (setq y (- (cadr pt1) dx)
    
37.                                 pt2 (list x y)
    
38.                 )
    
39. 
    
40. 
    
41.                 (entmake (list
    
42.                                         '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 dk_layer)
    
43.                                         '(90 . 3) '(43 . 0)
    
44.                                         (cons 10 pt0) (cons 10 pt2) (cons 10 pt1)
    
45.                                         )
    
46.                 )
    
47.                 (if dk_has_rec
    
48.                         (dk::make_rec)
    
49.                 )
    
50.         )
    
51.         (defun dk::make_rec();(hcl_make_rec p1 p2 "0" 1 40)
    
52.                 (entmake (list
    
53.                                         '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 dk_layer)
    
54.                                         '(90 . 4) '(70 . 1) '(43 . 0)
    
55.                                         (list 10 (car pt0) (cadr pt0)) (list 10 (car pt0) (cadr pt1))
    
56.                                         (list 10 (car pt1) (cadr pt1)) (list 10 (car pt1) (cadr pt0))
    
57.                         )
    
58.                 )
    
59.         )
    
60.         (defun dk_print_parm( / tip_rec)
    
61.                 (initget 0 "F")
    
62.                 (if dk_has_rec
    
63.                         (setq tip_rec "有轮廓")
    
64.                         (setq tip_rec "无轮廓")
    
65.                 )
    
66.                 (princ (strcat "\n【标注洞口】\n  当前模式：" tip_rec
    
67.                         ))
    
68.         )
    
69.         (defun mydefunction(/ pt0 pt1)
    
70.                 ;;begin mydefunction
    
71.                 (dk_print_parm)
    
72.                 (while (setq pt0 (getpoint "\n  第一点[F切换模式]："))
    
73.                         (cond
    
74.                                 ((= "F" pt0)
    
75.                                         (setq dk_has_rec (not dk_has_rec))
    
76.                                 )
    
77.                                 (t
    
78.                                         (if (setq pt1 (getpoint pt0 "\n  第二点："))
    
79.                                                 (progn
    
80.                                                         (dk::draw_dk)
    
81.                                                 )
    
82.                                         )
    
83.                                 )
    
84.                         )
    
85.                         (dk_print_parm)
    
86.                 )
    
87.         )
    
88.         (setvar 'cmdecho 0)
    
89.         (mydefunction)
    
90.         (setvar 'cmdecho 1)
    
91.         (prin1)
    
92. )

(defun c:dk( / mydefunction dk_bili dk_min dk_layer)<br />         (setq dk_bili 0.2 ;引线比例<br />                         dk_min 50 ;折线最小距离<br />                         dk_layer "SE_HOLE"<br />         );;变量设置<br />         (if (not (tblsearch "LAYER" "SE_HOLE"))<br />                 (progn<br />                         (entmake (list '(0 . "LAYER")<br />                                                                 '(100 . "AcDbSymbolTableRecord")<br />                                                                 '(100 . "AcDbLayerTableRecord")<br />                                        '(70 . 0)<br />                                        '(62 . 201)<br />                                        '(6 . "Continuous")<br />                                        '(2 . "SE_HOLE")))<br />                 )<br />         )<br />         (defun dk::draw_dk(/ dis dx x y pt2 pt3 dk_distance);(hcl_make_rec p1 p2 "0" 1 40)<br /> ;                (setq dk_distance (* (distance pt1 pt0) (- 0.5 dk_bili))<br /> ;                                pt2 (point_mid pt0 pt1)<br /> ;                                pt2 (polar pt2 (- pi (angle pt0 pt1)) dk_distance)<br /> ;                )<br />                 (setq dis (* (min (abs (- (car pt1) (car pt0))) (abs (- (cadr pt1) (cadr pt0)))) dk_bili)<br />                                 dis (max dis dk_min)<br />                 )<br />                 (if (< (car pt0) (car pt1))<br />                         (setq dx dis)<br />                         (setq dx (- dis))<br />                 )<br />                 (setq x (+ (car pt0) dx))<br /> <br />                 (if (< (cadr pt0) (cadr pt1))<br />                         (setq dx dis)<br />                         (setq dx (- dis))<br />                 )<br />                 (setq y (- (cadr pt1) dx)<br />                                 pt2 (list x y)<br />                 )<br /> <br /> <br />                 (entmake (list<br />                                         '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 dk_layer)<br />                                         '(90 . 3) '(43 . 0)<br />                                         (cons 10 pt0) (cons 10 pt2) (cons 10 pt1)<br />                                         )<br />                 )<br />                 (if dk_has_rec<br />                         (dk::make_rec)<br />                 )<br />         )<br />         (defun dk::make_rec();(hcl_make_rec p1 p2 "0" 1 40)<br />                 (entmake (list<br />                                         '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 dk_layer)<br />                                         '(90 . 4) '(70 . 1) '(43 . 0)<br />                                         (list 10 (car pt0) (cadr pt0)) (list 10 (car pt0) (cadr pt1))<br />                                         (list 10 (car pt1) (cadr pt1)) (list 10 (car pt1) (cadr pt0))<br />                         )<br />                 )<br />         )<br />         (defun dk_print_parm( / tip_rec)<br />                 (initget 0 "F")<br />                 (if dk_has_rec<br />                         (setq tip_rec "有轮廓")<br />                         (setq tip_rec "无轮廓")<br />                 )<br />                 (princ (strcat "\n【标注洞口】\n  当前模式：" tip_rec<br />                         ))<br />         )<br />         (defun mydefunction(/ pt0 pt1)<br />                 ;;begin mydefunction<br />                 (dk_print_parm)<br />                 (while (setq pt0 (getpoint "\n  第一点[F切换模式]："))<br />                         (cond<br />                                 ((= "F" pt0)<br />                                         (setq dk_has_rec (not dk_has_rec))<br />                                 )<br />                                 (t<br />                                         (if (setq pt1 (getpoint pt0 "\n  第二点："))<br />                                                 (progn<br />                                                         (dk::draw_dk)<br />                                                 )<br />                                         )<br />                                 )<br />                         )<br />                         (dk_print_parm)<br />                 )<br />         )<br />         (setvar 'cmdecho 0)<br />         (mydefunction)<br />         (setvar 'cmdecho 1)<br />         (prin1)<br /> )

xiao1984

liuhe 发表于 2024-1-3 09:36

创建洞口线后，将线颜色改成其它色就更好了。

lxl217114

搜索一下，论坛里面应该会有成品的代码。

怕怕吓一跳

xiao1984 发表于 2024-1-3 12:52
创建洞口线后，将线颜色改成其它色就更好了。

加几个字符就好了，位置如下：

yefei812678

liuhe 发表于 2024-1-3 09:36

这是两点 弄得 我就想直接在里面点下就好的哪种

yefei812678

能不能直接点些矩形框里面就画出来那种？不用设置图层  可以把线型设置下

yefei812678

liuhe 发表于 2024-1-3 09:36

能不能直接点些矩形框里面就画出来那种？不用设置图层  可以把线型设置下

xiao1984

怕怕吓一跳 发表于 2024-1-3 14:39
加几个字符就好了，位置如下：

十分感谢！可以修改想要的颜色了。

zmzk

2. (DEFUN C:tt()
   
3.    
   
4.    
   
5.    (setq P1 (GETPOINT "\n输入矩形的一个角点" ))
   
6.    (setq P3 (GETCORNER P1 "\n输入矩形的另一个角点" ))
   
7.    (setq P2 (LIST (CAR P3 ) (CADR P1 ) ))
   
8.    (setq P4 (LIST (CAR P1 ) (CADR P3 ) ))
   
9.    (setq P5 (LIST (/ (+ (CAR P1 ) (CAR P3 ) ) 2 ) (/ (+ (CADR P1 ) (CADR P3 ) ) 2 ) ))
   
10.    (setq P6 (LIST (+ (CAR P1 ) (/ (- (CAR P3 ) (CAR P1 ) ) 6 ) ) (+ (CADR P1 ) (/ (- (CADR P3 ) (CADR P1 ) ) 6 ) ) ))
    
11.         
    
12.    (command "pline" ) (command P2 ) (command P6 ) (command P4 ) (command "" )
    
13.         
    
14. 
    
15. (PRINC )  )

(DEFUN C:tt() <br />     <br />    <br />    (setq P1 (GETPOINT "\n输入矩形的一个角点" )) <br />    (setq P3 (GETCORNER P1 "\n输入矩形的另一个角点" )) <br />    (setq P2 (LIST (CAR P3 ) (CADR P1 ) )) <br />    (setq P4 (LIST (CAR P1 ) (CADR P3 ) )) <br />    (setq P5 (LIST (/ (+ (CAR P1 ) (CAR P3 ) ) 2 ) (/ (+ (CADR P1 ) (CADR P3 ) ) 2 ) )) <br />    (setq P6 (LIST (+ (CAR P1 ) (/ (- (CAR P3 ) (CAR P1 ) ) 6 ) ) (+ (CADR P1 ) (/ (- (CADR P3 ) (CADR P1 ) ) 6 ) ) )) <br />         <br />    (command "pline" ) (command P2 ) (command P6 ) (command P4 ) (command "" ) <br />         <br /> <br /> (PRINC )  )