经常画圆孔和长圆孔的可以试试这个

WWYYBB1015

之前圆孔和长圆孔的插件都单独做过 但是没完全用VLISP试过，这次想着把两个命令合并一起 名称为KK（开孔），以来自己方便，二来分享给大家，喜欢的拿走，以下是源代码：


(defun c:kk (/           AcadObject       AcadDocument
         mSpace    Utility     currLinetype     sc    LinetypeSel
         found     layerSel     layerObj  kwordlist 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 " 长圆孔[L] 圆孔[C] <圆孔>")
  )
  (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)
)

ysq101

WWYYBB1015 发表于 2021-7-13 00:00
动态块多了图纸会卡，还要移动视图复制过来，不太方便，我编写的这个，缺点是生成的线都是散的，只是都在 ...

其实就差PE那一下就成整体了,小问题,有需要的自己改改就成了

WWYYBB1015

e2002 发表于 2021-7-12 16:29
动态块应该是个更好的方法

动态块多了图纸会卡，还要移动视图复制过来，不太方便，我编写的这个，缺点是生成的线都是散的，只是都在一个图层里，没有块的整体性好。

mokson

非常实用，感谢楼主的热心分享！

panliang9

谢谢楼主分享。

AndyWang

已下载，多谢

e2002

动态块应该是个更好的方法

jdws213

谢谢楼主的好资源！

xj6019

谢谢分享，存起来备用，谢过啦

tigcat

谢谢分享源码

sunny_8848

谢谢分享好程序