画长圆孔，需要改进

xiao88gang

这是一个画长圆孔的LSP，非常好用，但需要改进一下，请大大师给优化一下。 要求：1、去掉中心线。
           2、中需要画长圆孔一个功能就可，把画圆孔的代码去掉。



(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)
)

htlaser

xiao88gang 发表于 2021-10-30 15:50
命令: (LOAD "C:/Users/Administrator/Desktop/kk.lsp") Application ERROR:
命令输入时发送的类型无效 ...

命令 KK5

htlaser

1. (defun c:kk5 (/ acaddocument acadobject currlinetype d found l layerobj layersel linetypesel mspace polyline pt pta ptb ptc ptd pte ptf ptg pth ptns  sc utility)
   
2.   (VL-LOAD-COM)
   
3.   (setq        AcadObject   (vlax-get-acad-object)
   
4.         AcadDocument (vla-get-ActiveDocument AcadObject)
   
5.         mSpace             (vla-get-ModelSpace AcadDocument)
   
6.         Utility             (vla-get-Utility AcadDocument)
   
7.   )
   
8. 
   
9.   (setq layerSel (vla-get-Layers AcadDocument))
   
10.   (setq layerObj (vla-add layerSel "Hole"))
    
11.   (vla-put-Color layerObj "4")
    
12. 
    
13.   (setq currLinetype (vla-get-ActiveLinetype AcadDocument))
    
14.   (setq found :vlax-false)
    
15.   (setq LinetypeSel (vla-get-Linetypes AcadDocument))
    
16.   (VLAX-FOR entry LinetypeSel
    
17.     (if        (= (vla-get-Name entry) "CENTER2")
    
18.       (setq found :vlax-true)
    
19.     )
    
20.   )
    
21.   (if (= found :vlax-false)
    
22.     (vla-load LinetypeSel "CENTER2" "acad.lin")
    
23.   )
    
24.   (vla-put-ActiveLinetype AcadDocument currLinetype)
    
25.   (setq sc 0.4)
    
26.   (princ "\n绘制画长圆孔 ")  
    
27.     (progn
    
28.       (if (= record2 nil)
    
29.         (setq record2 13)
    
30.       )
    
31.       (princ (strcat "\n孔径大小<" (rtos record2 2 2) ">: "))
    
32.       (setq d (getreal))
    
33.       (if (= d nil)
    
34.         (setq d record2)
    
35.       )
    
36.       (setq record2 d)
    
37.       (if (= record3 nil)
    
38.         (setq record3 45)
    
39.       )
    
40.       (princ (strcat "\n长圆孔的长度<" (rtos record3 2 2) ">: "))
    
41.       (setq l (getreal))
    
42.       (if (= l nil)
    
43.         (setq l record3)
    
44.       )
    
45.       (setq record3 l)
    
46.       (setq pt (getpoint "\n请输入插入点："))
    
47.       (setq
    
48.         pta (list (- (car pt) (/ (- l d) 2)) (+ (cadr pt) (/ d 2)) 0)
    
49.       )
    
50.       (setq
    
51.         ptb (list (+ (car pt) (/ (- l d) 2)) (+ (cadr pt) (/ d 2)) 0)
    
52.       )
    
53.       (setq
    
54.         ptc (list (+ (car pt) (/ (- l d) 2)) (- (cadr pt) (/ d 2)) 0)
    
55.       )
    
56.       (setq
    
57.         ptd (list (- (car pt) (/ (- l d) 2)) (- (cadr pt) (/ d 2)) 0)
    
58.       )
    
59. 
    
60.       (setq pte (list (- (car pt) (/ l 2) (/ d 2)) (cadr pt) 0))
    
61.       (setq ptf (list (+ (car pt) (/ l 2) (/ d 2)) (cadr pt) 0))
    
62.       (setq ptg (list (car pt) (+ (cadr pt) d) 0))
    
63.       (setq pth (list (car pt) (- (cadr pt) d) 0))
    
64.       
    
65.       (setq ptns nil)
    
66.       (setq ptns (vlax-make-safearray vlax-vbDouble '(0 . 14)))
    
67.       (vlax-safearray-fill ptns (append pta ptb ptc ptd pta))
    
68.       (setq PolyLine (vla-AddPolyline mSpace ptns))
    
69.       (vla-put-layer PolyLine "Hole")
    
70.       (vla-SetBulge PolyLine 1 -1)
    
71.       (vla-SetBulge PolyLine 3 -1)
    
72.     )
    
73.   
    
74.   (princ)
    
75. )

(defun c:kk5 (/ acaddocument acadobject currlinetype d found l layerobj layersel linetypesel mspace polyline pt pta ptb ptc ptd pte ptf ptg pth ptns  sc utility)<br />   (VL-LOAD-COM)<br />   (setq        AcadObject   (vlax-get-acad-object)<br />         AcadDocument (vla-get-ActiveDocument AcadObject)<br />         mSpace             (vla-get-ModelSpace AcadDocument)<br />         Utility             (vla-get-Utility AcadDocument)<br />   )<br /> <br />   (setq layerSel (vla-get-Layers AcadDocument))<br />   (setq layerObj (vla-add layerSel "Hole"))<br />   (vla-put-Color layerObj "4")<br /> <br />   (setq currLinetype (vla-get-ActiveLinetype AcadDocument))<br />   (setq found :vlax-false)<br />   (setq LinetypeSel (vla-get-Linetypes AcadDocument))<br />   (VLAX-FOR entry LinetypeSel<br />     (if        (= (vla-get-Name entry) "CENTER2")<br />       (setq found :vlax-true)<br />     )<br />   )<br />   (if (= found :vlax-false)<br />     (vla-load LinetypeSel "CENTER2" "acad.lin")<br />   )<br />   (vla-put-ActiveLinetype AcadDocument currLinetype)<br />   (setq sc 0.4)<br />   (princ "\n绘制画长圆孔 ")  <br />     (progn<br />       (if (= record2 nil)<br />         (setq record2 13)<br />       )<br />       (princ (strcat "\n孔径大小<" (rtos record2 2 2) ">: "))<br />       (setq d (getreal))<br />       (if (= d nil)<br />         (setq d record2)<br />       )<br />       (setq record2 d)<br />       (if (= record3 nil)<br />         (setq record3 45)<br />       )<br />       (princ (strcat "\n长圆孔的长度<" (rtos record3 2 2) ">: "))<br />       (setq l (getreal))<br />       (if (= l nil)<br />         (setq l record3)<br />       )<br />       (setq record3 l)<br />       (setq pt (getpoint "\n请输入插入点："))<br />       (setq<br />         pta (list (- (car pt) (/ (- l d) 2)) (+ (cadr pt) (/ d 2)) 0)<br />       )<br />       (setq<br />         ptb (list (+ (car pt) (/ (- l d) 2)) (+ (cadr pt) (/ d 2)) 0)<br />       )<br />       (setq<br />         ptc (list (+ (car pt) (/ (- l d) 2)) (- (cadr pt) (/ d 2)) 0)<br />       )<br />       (setq<br />         ptd (list (- (car pt) (/ (- l d) 2)) (- (cadr pt) (/ d 2)) 0)<br />       )<br /> <br />       (setq pte (list (- (car pt) (/ l 2) (/ d 2)) (cadr pt) 0))<br />       (setq ptf (list (+ (car pt) (/ l 2) (/ d 2)) (cadr pt) 0))<br />       (setq ptg (list (car pt) (+ (cadr pt) d) 0))<br />       (setq pth (list (car pt) (- (cadr pt) d) 0))<br />       <br />       (setq ptns nil)<br />       (setq ptns (vlax-make-safearray vlax-vbDouble '(0 . 14)))<br />       (vlax-safearray-fill ptns (append pta ptb ptc ptd pta))<br />       (setq PolyLine (vla-AddPolyline mSpace ptns))<br />       (vla-put-layer PolyLine "Hole")<br />       (vla-SetBulge PolyLine 1 -1)<br />       (vla-SetBulge PolyLine 3 -1)<br />     )<br />   <br />   (princ)<br /> )

修改一下    有两个是全局变量

xiao88gang

htlaser 发表于 2021-10-30 14:14
修改一下    有两个是全局变量

命令: (LOAD "C:/Users/Administrator/Desktop/kk.lsp") Application ERROR:
命令输入时发送的类型无效
Application ERROR: 命令输入时发送的类型无效
输入的字符串有缺陷

xiao88gang

htlaser 发表于 2021-10-30 16:03
命令 KK5

完美。谢谢。

xiao88gang

htlaser 发表于 2021-10-30 12:49
命令 KK5

怎么付币？