画长圆孔，需要改进
这是一个画长圆孔的LSP，非常好用，但需要改进一下，请大大师给优化一下。 要求：1、去掉中心线。2、中需要画长圆孔一个功能就可，把画圆孔的代码去掉。
(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)
)
本帖最后由 htlaser 于 2021-10-30 16:06 编辑
xiao88gang 发表于 2021-10-30 15:50
命令: (LOAD "C:/Users/Administrator/Desktop/kk.lsp") Application ERROR:
命令输入时发送的类型无效 ...
命令 KK5
本帖最后由 htlaser 于 2021-10-30 14:22 编辑
(defun c:kk5 (/ acaddocument acadobject currlinetype d found l layerobj layersel linetypesel mspace polyline pt pta ptb ptc ptd pte ptf ptg pth ptnssc utility)
(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)
(princ "\n绘制画长圆孔 ")
(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 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 发表于 2021-10-30 14:14
修改一下 有两个是全局变量
命令: (LOAD "C:/Users/Administrator/Desktop/kk.lsp") Application ERROR:
命令输入时发送的类型无效
Application ERROR: 命令输入时发送的类型无效
输入的字符串有缺陷 htlaser 发表于 2021-10-30 16:03
命令 KK5
完美。谢谢。 htlaser 发表于 2021-10-30 12:49
命令 KK5
怎么付币？
页:
[1]