[求助]一個特殊的倒角程序
[求助]一個特殊的倒角程序如圖有一個特殊的倒角程序，可以對兩條直角邊做1.5*1.5的反凹內直角倒角，
請高手指教!謝謝! 试一下下面的LISP程序
(DEFUN C:CORNER (/ GETLINE VLINE1 VLINE2 DL1 DL2 PT1 PT2 PT3 PT4 PT5 PT6 PT7 ANG1 ANG2)
(DEFUN GETLINE (MSG / A1)<BR> (INITGET 1)<BR> (SETQ A1 (CAR (ENTSEL MSG)))<BR> (WHILE (/= (CDR (ASSOC 0 (ENTGET A1))) "LINE")<BR> (PRINC "\n您选的不是线图元,请再选一次...")<BR> (INITGET 1)<BR> (SETQ A1 (CAR (ENTSEL MSG)))<BR> )<BR> A1<BR>)
(SETQ VLINE1 (GETLINE "\n请选取第一条线: "))<BR> (WHILE (OR (= VLINE2 nil) (EQUAL VLINE1 VLINE2))<BR> (IF (EQUAL VLINE1 VLINE2) (PRINC "\n线重复,请再选一次..."))<BR> (SETQ VLINE2 (GETLINE "\n请选取第二条线: "))<BR> )<BR> (SETQ D (GETDIST "\n倒角距离 <1.5> : ")<BR> D (IF (= D nil) 1.5 D))<BR> (SETQ DL1 (ENTGET VLINE1) DL2 (ENTGET VLINE2)<BR> PT1 (CDR (ASSOC 10 DL1)) PT2 (CDR (ASSOC 11 DL1))<BR> PT3 (CDR (ASSOC 10 DL2)) PT4 (CDR (ASSOC 11 DL2))<BR> PT5 (INTERS PT1 PT2 PT3 PT4 nil))<BR> (IF (/= PT5 nil) (PROGN<BR> (SETQ PT2 (IF (< (DISTANCE PT5 PT1) (DISTANCE PT5 PT2)) PT2 PT1)<BR> PT4 (IF (< (DISTANCE PT5 PT3) (DISTANCE PT5 PT4)) PT4 PT3)<BR> ANG1 (ANGLE PT5 PT2) ANG2 (ANGLE PT5 PT4)<BR> PT1 (POLAR PT5 ANG1 D) PT3 (POLAR PT5 ANG2 D)<BR> PT5 (POLAR PT3 ANG1 D))<BR> (ENTDEL VLINE1) (ENTDEL VLINE2)<BR> (COMMAND "LINE" PT2 PT1 PT5 PT3 PT4 "")<BR> )<BR> (T (PRINC "\n两直线无交点!"))<BR> )<BR> (PRINC)<BR>)<BR>(PRINC "\nType CORNER to start.")<BR>(PRINC) 有这样的命令吗 都是直角么? 直角，还有园的四分之一， 这个我也经常用到，最好两个1.5可以不相同，比如一个1，一个1.5等。 我的意思是誰能編寫一個這樣的特殊的倒角lisp程序，只要選擇兩條邊
即可實現該倒角，默認倒角大小為1.5*1.5，但可以進行設定不同或
相同的倒角距離!因我工作中經常要做此類似的繪圖，覺得畫起來很麻煩，
所以要求助大家編制這樣一個lisp程序!謝謝! 本帖最后由 作者 于 2004-5-12 8:07:04 编辑
我只会vba，用vba写了一个以下是主程序的代码，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
vba我一点都不懂，麻烦告诉我怎么用好么？ 本帖最后由 作者 于 2004-5-12 8:36:51 编辑
把上面的dvb文件下载后，注意看文件名是否为GBChamfer.dvb，如果不是，改成这个名字。
在cad的命令行输入 vbaload ，跳出对话框后选择加载GBChamfer.dvb文件。
输入GB启动命令。
注意：本代码是在autocad2005中文版下调试的，对于别的版本没有调试过。估计在autocad2004，2005里应该没有问题。 谢谢，先试试看！