经常画圆孔和长圆孔的可以试试这个
之前圆孔和长圆孔的插件都单独做过 但是没完全用VLISP试过，这次想着把两个命令合并一起 名称为KK（开孔），以来自己方便，二来分享给大家，喜欢的拿走，以下是源代码：(defun c:kk (/ AcadObject AcadDocument
mSpace Utility currLinetype sc LinetypeSel
found layerSel layerObjkwordlist returnstring
pt d l circle pt1
pt2 pt3 pt4 pta ptb
ptc ptd pte ptf ptg
pth line1 line2 line3 line4
pth PolyLine
)
(VL-LOAD-COM)
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument AcadObject)
mSpace (vla-get-ModelSpace AcadDocument)
Utility (vla-get-Utility AcadDocument)
)
(setq layerSel (vla-get-Layers AcadDocument))
(setq layerObj (vla-add layerSel "Hole"))
(vla-put-Color layerObj "4")
(setq currLinetype (vla-get-ActiveLinetype AcadDocument))
(setq found :vlax-false)
(setq LinetypeSel (vla-get-Linetypes AcadDocument))
(VLAX-FOR entry LinetypeSel
(if (= (vla-get-Name entry) "CENTER2")
(setq found :vlax-true)
)
)
(if (= found :vlax-false)
(vla-load LinetypeSel "CENTER2" "acad.lin")
)
(vla-put-ActiveLinetype AcadDocument currLinetype)
(setq sc 0.4)
(setq kwordlist "LongCircle Circle")
(vla-InitializeUserInput Utility 0 kwordlist)
(setq returnstring
(vla-getKeyword Utility " 长圆孔 圆孔 <圆孔>")
)
(if (/= returnstring "LongCircle")
(progn
(if (= record nil)
(setq record 4.5)
)
(princ (strcat "\n孔径大小<" (rtos record 2 2) ">: "))
(setq d (getreal))
(if (= d nil)
(setq d record)
)
(setq record d)
(setq pt (getpoint "\n请输入插入点："))
(setq circle (vla-AddCircle mSpace (vlax-3D-point pt) (/ d 2)))
(vla-put-layer circle "Hole")
(setq pt1 (list (- (car pt) d) (cadr pt) 0))
(setq pt2 (list (+ (car pt) d) (cadr pt) 0))
(setq pt3 (list (car pt) (+ (cadr pt) d) 0))
(setq pt4 (list (car pt) (- (cadr pt) d) 0))
(setq line1
(vla-addline mSpace (vlax-3D-point pt1) (vlax-3D-point pt2))
line2
(vla-addline mSpace (vlax-3D-point pt3) (vlax-3D-point pt4))
)
(vla-put-layer line1 "Hole")
(vla-put-color line1 "1")
(vla-put-Linetype line1 "CENTER2")
(vla-put-LinetypeScale line1 (* sc d))
(vla-put-layer line2 "Hole")
(vla-put-color line2 "1")
(vla-put-Linetype line2 "CENTER2")
(vla-put-LinetypeScale line2 (* sc d))
)
(progn
(if (= record2 nil)
(setq record2 13)
)
(princ (strcat "\n孔径大小<" (rtos record2 2 2) ">: "))
(setq d (getreal))
(if (= d nil)
(setq d record2)
)
(setq record2 d)
(if (= record3 nil)
(setq record3 45)
)
(princ (strcat "\n长圆孔的长度<" (rtos record3 2 2) ">: "))
(setq l (getreal))
(if (= l nil)
(setq l record3)
)
(setq record3 l)
(setq pt (getpoint "\n请输入插入点："))
(setq
pta (list (- (car pt) (/ (- l d) 2)) (+ (cadr pt) (/ d 2)) 0)
)
(setq
ptb (list (+ (car pt) (/ (- l d) 2)) (+ (cadr pt) (/ d 2)) 0)
)
(setq
ptc (list (+ (car pt) (/ (- l d) 2)) (- (cadr pt) (/ d 2)) 0)
)
(setq
ptd (list (- (car pt) (/ (- l d) 2)) (- (cadr pt) (/ d 2)) 0)
)
(setq pte (list (- (car pt) (/ l 2) (/ d 2)) (cadr pt) 0))
(setq ptf (list (+ (car pt) (/ l 2) (/ d 2)) (cadr pt) 0))
(setq ptg (list (car pt) (+ (cadr pt) d) 0))
(setq pth (list (car pt) (- (cadr pt) d) 0))
(setq line3
(vla-addline mSpace (vlax-3D-point pte) (vlax-3D-point ptf))
line4
(vla-addline mSpace (vlax-3D-point ptg) (vlax-3D-point pth))
)
(vla-put-layer line3 "Hole")
(vla-put-color line3 "1")
(vla-put-Linetype line3 "CENTER2")
(vla-put-LinetypeScale line3 (* sc d))
(vla-put-layer line4 "Hole")
(vla-put-color line4 "1")
(vla-put-Linetype line4 "CENTER2")
(vla-put-LinetypeScale line4 (* sc d))
(setq ptns nil)
(setq ptns (vlax-make-safearray vlax-vbDouble '(0 . 14)))
(vlax-safearray-fill ptns (append pta ptb ptc ptd pta))
(setq PolyLine (vla-AddPolyline mSpace ptns))
(vla-put-layer PolyLine "Hole")
(vla-SetBulge PolyLine 1 -1)
(vla-SetBulge PolyLine 3 -1)
)
)
(princ)
)
WWYYBB1015 发表于 2021-7-13 00:00
动态块多了图纸会卡，还要移动视图复制过来，不太方便，我编写的这个，缺点是生成的线都是散的，只是都在 ...
其实就差PE那一下就成整体了,小问题,有需要的自己改改就成了 e2002 发表于 2021-7-12 16:29
动态块应该是个更好的方法
动态块多了图纸会卡，还要移动视图复制过来，不太方便，我编写的这个，缺点是生成的线都是散的，只是都在一个图层里，没有块的整体性好。 非常实用，感谢楼主的热心分享！ 谢谢楼主分享。 已下载，多谢 动态块应该是个更好的方法 本帖最后由 jdws213 于 2021-7-12 16:50 编辑
谢谢楼主的好资源！ 谢谢分享，存起来备用，谢过啦 谢谢分享源码 谢谢分享好程序
页:
[1]
2