[求助]一個特殊的倒角程序

alan_cmh

[求助]一個特殊的倒角程序


如圖有一個特殊的倒角程序，可以對兩條直角邊做1.5*1.5的反凹內直角倒角，


請高手指教!謝謝!

ZZXXQQ

试一下下面的LISP程序 (DEFUN C:CORNER (/ GETLINE VLINE1 VLINE2 DL1 DL2 PT1 PT2 PT3 PT4 PT5 PT6 PT7 ANG1 ANG2) (DEFUN GETLINE (MSG / A1)
(INITGET 1)
(SETQ A1 (CAR (ENTSEL MSG)))
(WHILE (/= (CDR (ASSOC 0 (ENTGET A1))) "LINE")
(PRINC "\n您选的不是线图元,请再选一次...")
(INITGET 1)
(SETQ A1 (CAR (ENTSEL MSG)))
)
A1
) (SETQ VLINE1 (GETLINE "\n请选取第一条线: "))
(WHILE (OR (= VLINE2 nil) (EQUAL VLINE1 VLINE2))
(IF (EQUAL VLINE1 VLINE2) (PRINC "\n线重复,请再选一次..."))
(SETQ VLINE2 (GETLINE "\n请选取第二条线: "))
)
(SETQ D (GETDIST "\n倒角距离 <1.5> : ")
D (IF (= D nil) 1.5 D))
(SETQ DL1 (ENTGET VLINE1) DL2 (ENTGET VLINE2)
PT1 (CDR (ASSOC 10 DL1)) PT2 (CDR (ASSOC 11 DL1))
PT3 (CDR (ASSOC 10 DL2)) PT4 (CDR (ASSOC 11 DL2))
PT5 (INTERS PT1 PT2 PT3 PT4 nil))
(IF (/= PT5 nil) (PROGN
(SETQ PT2 (IF (< (DISTANCE PT5 PT1) (DISTANCE PT5 PT2)) PT2 PT1)
PT4 (IF (< (DISTANCE PT5 PT3) (DISTANCE PT5 PT4)) PT4 PT3)
ANG1 (ANGLE PT5 PT2) ANG2 (ANGLE PT5 PT4)
PT1 (POLAR PT5 ANG1 D) PT3 (POLAR PT5 ANG2 D)
PT5 (POLAR PT3 ANG1 D))
(ENTDEL VLINE1) (ENTDEL VLINE2)
(COMMAND "LINE" PT2 PT1 PT5 PT3 PT4 "")
)
(T (PRINC "\n两直线无交点!"))
)
(PRINC)
)
(PRINC "\nType CORNER to start.")
(PRINC)

haoboy-lgh

有这样的命令吗

无痕

都是直角么?

ljcgq

直角，还有园的四分之一，

subtlation

这个我也经常用到，最好两个1.5可以不相同，比如一个1，一个1.5等。

alan_cmh

我的意思是誰能編寫一個這樣的特殊的倒角lisp程序，只要選擇兩條邊


即可實現該倒角，默認倒角大小為1.5*1.5，但可以進行設定不同或


相同的倒角距離!因我工作中經常要做此類似的繪圖，覺得畫起來很麻煩，


所以要求助大家編制這樣一個lisp程序!謝謝!

subtlation

我只会vba，用vba写了一个以下是主程序的代码，

2. Sub GBChamfer()
3.        On Error Resume Next
4.        Dim dist1 As Double, dist2 As Double
5.        dist1 = 0.5: dist2 = 0.8
6.       
7.        Dim lineObj1 As AcadLine, lineObj2 As AcadLine
8.        Dim pt1, pt2
9.       
10.        gwGetEntity lineObj1, pt1, "请选择第一条直线：", "AcDbLine"
11.        If lineObj1 Is Nothing Then Exit Sub
12.       
13.        gwGetEntity lineObj2, pt2, "请选择第二条直线：", "AcDbLine"
14.        If lineObj2 Is Nothing Then Exit Sub       Dim jointPnt, startPnt1, startPnt2, endPnt1, endPnt2, startPnt3
15.        jointPnt = lineObj1.IntersectWith(lineObj2, acExtendBoth)
16.        If UBound(jointPnt) = -1 Then Exit Sub
17.       
18.        If (Abs(GetAngleFromX(jointPnt, pt1) - GetAngleFromX(jointPnt, lineObj1.StartPoint)) < 0.1 Or _
19.                Abs(Abs(GetAngleFromX(jointPnt, pt1) - GetAngleFromX(jointPnt, lineObj1.StartPoint)) - 2 * PI) < 0.1) And _
20.              GetDistance(jointPnt, pt1) < GetDistance(jointPnt, lineObj1.StartPoint) Then
21.                startPnt1 = lineObj1.StartPoint
22.        Else
23.                startPnt1 = lineObj1.EndPoint
24.        End If
25.       
26.        If (Abs(GetAngleFromX(jointPnt, pt2) - GetAngleFromX(jointPnt, lineObj2.StartPoint)) < 0.1 Or _
27.                Abs(Abs(GetAngleFromX(jointPnt, pt2) - GetAngleFromX(jointPnt, lineObj2.StartPoint)) - 2 * PI) < 0.1) And _
28.              GetDistance(jointPnt, pt2) < GetDistance(jointPnt, lineObj2.StartPoint) Then
29.                startPnt2 = lineObj2.StartPoint
30.        Else
31.                startPnt2 = lineObj2.EndPoint
32.        End If
33.       
34.        'If GetDistance(jointPnt, startPnt1) < dist1 Or GetDistance(jointPnt, startPnt2) < dist2 Then
35.        '       ThisDrawing.Utility.Prompt "倒角的间距过大，退出命令。"
36.        '       Exit Sub
37.        'End If
38.       
39.        endPnt1 = GetPointAR(jointPnt, GetAngleFromX(jointPnt, startPnt1), dist1)
40.        endPnt2 = GetPointAR(jointPnt, GetAngleFromX(jointPnt, startPnt2), dist2)
41.        startPnt3 = GetPointAR(endPnt2, GetAngleFromX(jointPnt, startPnt1), dist1)
42.       
43.        Dim newObj1 As AcadLine, newObj2 As AcadLine, newObj3 As AcadLine, newObj4 As AcadLine
44.        Set newObj1 = ThisDrawing.ModelSpace.AddLine(startPnt1, endPnt1)
45.        Set newObj2 = ThisDrawing.ModelSpace.AddLine(startPnt2, endPnt2)
46.        Set newObj3 = ThisDrawing.ModelSpace.AddLine(startPnt3, endPnt1)
47.        Set newObj4 = ThisDrawing.ModelSpace.AddLine(startPnt3, endPnt2)
48.       
49.        newObj1.Layer = lineObj1.Layer: newObj1.Linetype = lineObj1.Linetype
50.        newObj2.Layer = lineObj2.Layer: newObj2.Linetype = lineObj2.Linetype
51.        newObj3.Layer = lineObj1.Layer: newObj3.Linetype = lineObj1.Linetype
52.        newObj4.Layer = lineObj1.Layer: newObj4.Linetype = lineObj1.Linetype
53.       
54.        lineObj1.Delete: lineObj2.Delete
55.       
56. End Sub

Sub GBChamfer()        On Error Resume Next        Dim dist1 As Double, dist2 As Double        dist1 = 0.5: dist2 = 0.8               Dim lineObj1 As AcadLine, lineObj2 As AcadLine        Dim pt1, pt2               gwGetEntity lineObj1, pt1, "请选择第一条直线：", "AcDbLine"        If lineObj1 Is Nothing Then Exit Sub               gwGetEntity lineObj2, pt2, "请选择第二条直线：", "AcDbLine"        If lineObj2 Is Nothing Then Exit Sub       Dim jointPnt, startPnt1, startPnt2, endPnt1, endPnt2, startPnt3        jointPnt = lineObj1.IntersectWith(lineObj2, acExtendBoth)        If UBound(jointPnt) = -1 Then Exit Sub               If (Abs(GetAngleFromX(jointPnt, pt1) - GetAngleFromX(jointPnt, lineObj1.StartPoint)) < 0.1 Or _                Abs(Abs(GetAngleFromX(jointPnt, pt1) - GetAngleFromX(jointPnt, lineObj1.StartPoint)) - 2 * PI) < 0.1) And _              GetDistance(jointPnt, pt1) < GetDistance(jointPnt, lineObj1.StartPoint) Then                startPnt1 = lineObj1.StartPoint        Else                startPnt1 = lineObj1.EndPoint        End If               If (Abs(GetAngleFromX(jointPnt, pt2) - GetAngleFromX(jointPnt, lineObj2.StartPoint)) < 0.1 Or _                Abs(Abs(GetAngleFromX(jointPnt, pt2) - GetAngleFromX(jointPnt, lineObj2.StartPoint)) - 2 * PI) < 0.1) And _              GetDistance(jointPnt, pt2) < GetDistance(jointPnt, lineObj2.StartPoint) Then                startPnt2 = lineObj2.StartPoint        Else                startPnt2 = lineObj2.EndPoint        End If               'If GetDistance(jointPnt, startPnt1) < dist1 Or GetDistance(jointPnt, startPnt2) < dist2 Then        '       ThisDrawing.Utility.Prompt "倒角的间距过大，退出命令。"        '       Exit Sub        'End If               endPnt1 = GetPointAR(jointPnt, GetAngleFromX(jointPnt, startPnt1), dist1)        endPnt2 = GetPointAR(jointPnt, GetAngleFromX(jointPnt, startPnt2), dist2)        startPnt3 = GetPointAR(endPnt2, GetAngleFromX(jointPnt, startPnt1), dist1)               Dim newObj1 As AcadLine, newObj2 As AcadLine, newObj3 As AcadLine, newObj4 As AcadLine        Set newObj1 = ThisDrawing.ModelSpace.AddLine(startPnt1, endPnt1)        Set newObj2 = ThisDrawing.ModelSpace.AddLine(startPnt2, endPnt2)        Set newObj3 = ThisDrawing.ModelSpace.AddLine(startPnt3, endPnt1)        Set newObj4 = ThisDrawing.ModelSpace.AddLine(startPnt3, endPnt2)               newObj1.Layer = lineObj1.Layer: newObj1.Linetype = lineObj1.Linetype        newObj2.Layer = lineObj2.Layer: newObj2.Linetype = lineObj2.Linetype        newObj3.Layer = lineObj1.Layer: newObj3.Linetype = lineObj1.Linetype        newObj4.Layer = lineObj1.Layer: newObj4.Linetype = lineObj1.Linetype               lineObj1.Delete: lineObj2.Delete        End Sub

ljcgq

vba我一点都不懂，麻烦告诉我怎么用好么？

subtlation

把上面的dvb文件下载后，注意看文件名是否为GBChamfer.dvb，如果不是，改成这个名字。


在cad的命令行输入 vbaload ，跳出对话框后选择加载GBChamfer.dvb文件。


输入GB启动命令。


注意：本代码是在autocad2005中文版下调试的，对于别的版本没有调试过。估计在autocad2004，2005里应该没有问题。

alan_cmh

谢谢，先试试看！