求一个单纯的洞口线插件
本帖最后由 yefei812678 于 2024-1-3 08:28 编辑就这样的一个单纯洞口线插件
(PROMPT "\n作者:流河QQ：859779429")
(PROMPT "\n 快捷键 TT")
(DEFUN C:TT (/ THISDRAWING PT1 PT2 PLST E)
(setq thisdrawing
(vla-get-activedocument
(vlax-get-acad-object)
)
)
(VLA-STARTUNDOMARK THISDRAWING)
(setq
pt1 (getpoint (STRCAT "\n窗交对象:指定角点1"))
)
(if (not pt1)
(vl-exit-with-value 0)
)
(setq pt2 (getcorner pt1 (STRCAT "\n窗交对象:指定角点2:")))
(IF (NOT PT2)
(VL-EXIT-WITH-VALUE 0)
)
(SETQ PLST (LIST PT1 PT2)
PLST (VL-SORT PLST
(FUNCTION (LAMBDA (E1 E2) (> (CAR E1) (CAR E2))))
)
PLST (LIST (CAR PLST)
(LIST (CAR (CAR PLST)) (CADR (CADR PLST)))
(CADR PLST)
)
PLST (LIST (CAR PLST)
(POLAR (CADR PLST)
(ANGLE (CADR PLST) (LH:MID PT1 PT2))
(* 0.3 (DISTANCE (CADR PLST) (LH:MID PT1 PT2)))
)
(CADDR PLST)
)
E (LH:MakeLWPOLYLINE PLST)
)
(IF (NOT (tblsearch "LTYPE" "ACAD_ISO02W100"))
(vl-catch-all-apply
'vla-Load
(list (vla-get-Linetypes
(vla-get-ActiveDocument (vlax-get-acad-object))
)
"ACAD_ISO02W100"
"acad.lin"
)
)
)
(vla-put-Linetype (vlax-ename->vla-object E) "ACAD_ISO02W100")
(vla-put-LinetypeScale
(vlax-ename->vla-object E)
(ABS (* (DISTANCE (CAR PLST) (CADDR PLST)) 0.01))
)
(vla-endundomark thisdrawing)
(princ)
)
(defun LH:MID (po1 po2)
(MAPCAR '(lambda (X Y) (* (+ X Y) 0.5)) po1 po2)
)
;;167.3 [功能] Entmake点表生成多段线
(defun LH:MakeLWPOLYLINE (lst / PT)
(entmakeX
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
)
(mapcar '(lambda (pt) (cons 10 pt)) lst)
)
)
) (defun c:dk( / mydefunction dk_bili dk_min dk_layer)
(setq dk_bili 0.2 ;引线比例
dk_min 50 ;折线最小距离
dk_layer "SE_HOLE"
);;变量设置
(if (not (tblsearch "LAYER" "SE_HOLE"))
(progn
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
'(62 . 201)
'(6 . "Continuous")
'(2 . "SE_HOLE")))
)
)
(defun dk::draw_dk(/ dis dx x y pt2 pt3 dk_distance);(hcl_make_rec p1 p2 "0" 1 40)
; (setq dk_distance (* (distance pt1 pt0) (- 0.5 dk_bili))
; pt2 (point_mid pt0 pt1)
; pt2 (polar pt2 (- pi (angle pt0 pt1)) dk_distance)
; )
(setq dis (* (min (abs (- (car pt1) (car pt0))) (abs (- (cadr pt1) (cadr pt0)))) dk_bili)
dis (max dis dk_min)
)
(if (< (car pt0) (car pt1))
(setq dx dis)
(setq dx (- dis))
)
(setq x (+ (car pt0) dx))
(if (< (cadr pt0) (cadr pt1))
(setq dx dis)
(setq dx (- dis))
)
(setq y (- (cadr pt1) dx)
pt2 (list x y)
)
(entmake (list
'(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 dk_layer)
'(90 . 3) '(43 . 0)
(cons 10 pt0) (cons 10 pt2) (cons 10 pt1)
)
)
(if dk_has_rec
(dk::make_rec)
)
)
(defun dk::make_rec();(hcl_make_rec p1 p2 "0" 1 40)
(entmake (list
'(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 dk_layer)
'(90 . 4) '(70 . 1) '(43 . 0)
(list 10 (car pt0) (cadr pt0)) (list 10 (car pt0) (cadr pt1))
(list 10 (car pt1) (cadr pt1)) (list 10 (car pt1) (cadr pt0))
)
)
)
(defun dk_print_parm( / tip_rec)
(initget 0 "F")
(if dk_has_rec
(setq tip_rec "有轮廓")
(setq tip_rec "无轮廓")
)
(princ (strcat "\n【标注洞口】\n当前模式：" tip_rec
))
)
(defun mydefunction(/ pt0 pt1)
;;begin mydefunction
(dk_print_parm)
(while (setq pt0 (getpoint "\n第一点："))
(cond
((= "F" pt0)
(setq dk_has_rec (not dk_has_rec))
)
(t
(if (setq pt1 (getpoint pt0 "\n第二点："))
(progn
(dk::draw_dk)
)
)
)
)
(dk_print_parm)
)
)
(setvar 'cmdecho 0)
(mydefunction)
(setvar 'cmdecho 1)
(prin1)
) liuhe 发表于 2024-1-3 09:36
创建洞口线后，将线颜色改成其它色就更好了。 搜索一下，论坛里面应该会有成品的代码。 xiao1984 发表于 2024-1-3 12:52
创建洞口线后，将线颜色改成其它色就更好了。
加几个字符就好了，位置如下： liuhe 发表于 2024-1-3 09:36
这是两点 弄得 我就想直接在里面点下就好的哪种 能不能直接点些矩形框里面就画出来那种？不用设置图层可以把线型设置下 liuhe 发表于 2024-1-3 09:36
能不能直接点些矩形框里面就画出来那种？不用设置图层可以把线型设置下 怕怕吓一跳 发表于 2024-1-3 14:39
加几个字符就好了，位置如下：
十分感谢！可以修改想要的颜色了。 (DEFUN C:tt()
(setq P1 (GETPOINT "\n输入矩形的一个角点" ))
(setq P3 (GETCORNER P1 "\n输入矩形的另一个角点" ))
(setq P2 (LIST (CAR P3 ) (CADR P1 ) ))
(setq P4 (LIST (CAR P1 ) (CADR P3 ) ))
(setq P5 (LIST (/ (+ (CAR P1 ) (CAR P3 ) ) 2 ) (/ (+ (CADR P1 ) (CADR P3 ) ) 2 ) ))
(setq P6 (LIST (+ (CAR P1 ) (/ (- (CAR P3 ) (CAR P1 ) ) 6 ) ) (+ (CADR P1 ) (/ (- (CADR P3 ) (CADR P1 ) ) 6 ) ) ))
(command "pline" ) (command P2 ) (command P6 ) (command P4 ) (command "" )
(PRINC ))
页:
[1]
2