逐点比较法三、四象限逆圆插补计算.doc

逐点比较法三、四象限逆圆插补计算

第三象限

第四象限

Private Sub Command1_Click()
Picture1.ForeColor = vbBlack
Picture1.DrawWidth = 2
Picture1.Line (500, 1000)-(8500, 1000) '画直线坐标轴
Picture1.Line (4500, 1000)-(4500, 5000)
Picture1.CurrentX = 230 '当前位置
Picture1.CurrentY = 900
Picture1.Print "-X" '坐标轴标注
Picture1.CurrentX = 4300
Picture1.CurrentY = 800
Picture1.Print "(0,0)"
Picture1.CurrentX = 8650
Picture1.CurrentY = 900
Picture1.Print "X"
Picture1.CurrentX = 4400
Picture1.CurrentY = 5100
Picture1.Print "-Y"
Picture1.Line (500, 1000)-(600, 950) '箭头
Picture1.Line (500, 1000)-(600, 1050)
Picture1.Line (8500, 1000)-(8400, 950)
Picture1.Line (8500, 1000)-(8400, 1050)
Picture1.Line (4500, 5000)-(4450, 4900)
Picture1.Line (4500, 5000)-(4550, 4900)
End Sub
Private Sub 坐标判别_Click()
If Not (Option1.Value = True Or Option2.Value = True) Then
ans = MsgBox("出错了，请选择象限", 48, "提示信息")
End If
Dim a, b, c, d, n, m As Integer
Dim r As Single
a = Val(Text1.Text)
b = Val(Text2.Text)
c = Val(Text3.Text)
d = Val(Text4.Text)
n = a * a + b * b
m = c * c + d * d
r = Sqr(n)
If Option1.Value = True Then
If Not (a <= 0 And b <= 0 And c <= 0 And d <= 0) Then
GoTo ww
ElseIf Not (a < c And b > d) Then
GoTo ww1
ElseIf n <> m Then
GoTo ww2
End If
End If
If Option2.Value = True Then
If Not (a > 0 And b <= 0 And c >= 0 And d <= 0) Then
GoTo ww
ElseIf Not (a < c And b < d) Then
GoTo ww1
ElseIf n <> m Then
GoTo ww2
End If
End If
GoTo ww4
ww: ans = MsgBox("出错了，逆圆弧起点、终点不在该象限，请重新输入", 48, "提示信息")
GoTo ww3
ww1: ans = MsgBox("出错了，逆圆弧起点、终点位置错误，请重新输入", 48, "提示信息")
GoTo ww3
ww2: ans = MsgBox("出错了，该象限所绘圆弧不以原点为圆心，请重新输入", 48, "提示信息")
ww3: Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text1.SetFocus
GoTo ww4
ww4:
End Sub

Private Sub Command4_Click()
If Not (Option1.Value = True Or Option2.Value = True) Then
ans = MsgBox("出错了，请选择象限", 48, "提示信息")
End If
Dim a, b, c, d, n, m As Integer
Dim r As Single
a = Val(Text1.Text)
b = Val(Text2.Text)
c = Val(Text3.Text)
d = Val(Text4.Text)
n = a * a + b * b
m = c * c + d * d
r = Sqr(n)
If Option1.Value = True Then
If Not (a <= 0 And b <= 0 And c <= 0 And d <= 0) Then
GoTo ww
ElseIf Not (a < c And b > d) Then
GoTo ww1
ElseIf n <> m Then
GoTo ww2
End If
End If
If Option2.Value = True Then
If Not (a >= 0 And b <= 0 And c >= 0 And d <= 0) Then
GoTo ww
ElseIf Not (a < c And b < d) Then
GoTo ww1
ElseIf n <> m Then
GoTo ww2
End If
End If
Picture1.ForeColor = vbBlue
Picture1.DrawWidth = 2
If Option1.Value = True Then
If b = 0 Then
If c = 0 Then
Picture1.Circle (4500, 1000), r * 300, , 3.14159, 3 * 3.14159 / 2
Else
Picture1.Circle (4500, 1000), r * 300, , 3.14159, Atn(d / c) + 3.14159
End If
ElseIf c = 0 Then
Picture1.Circle (4500, 1000), r * 300, , Atn(b / a) + 3.14159, 3 * 3.14159 / 2
Else
Picture1.Circle (4500, 1000), r * 300, , Atn(b / a) + 3.14159, Atn(d / c) + 3.14159

End If
End If
If Option2.Value = True Then
If a = 0 Then
If d = 0 Then
Picture1.Circle (4500, 1000), r * 300, , 3 * 3.14159 / 2, 2 * 3.14159
Else
Picture1.Circle (4500, 1000), r * 300, , 3 * 3.14159 / 2, Atn(d / c) + 3.14159 * 2
End If
ElseIf d 0 Then
Picture1.Circle (4500, 1000), r * 300, , Atn(b / a) + 3.14159 * 2, 2 * 3.14159
Else
Picture1.Circle (4500, 1000), r * 300, , Atn(b / a) + 3.14159 * 2, Atn(d / c) + 3.14159 * 2
End If
End If
GoTo ww4
ww: ans = MsgBox("出错了，逆圆弧起点、终点不在该象限，请重新输入", 48, "提示信息")
GoTo ww3
ww1: ans = MsgBox("出错了，逆圆弧起点、终点位置错误，请重新输入", 48, "提示信息")
GoTo ww3
ww2: ans = MsgBox("出错了，该象限所绘圆弧不以原点为圆心，请重新输入", 48, "提示信息")
ww3: Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text1.SetFocus
GoTo ww4
ww4:
End Sub

Private Sub Command2_Click()
Dim k, m, j, l, n, F(30), X(30), Y(30) As Integer, a As Integer, b As Integer, c As Integer, d As Integer
a = Int(Text1)
b = Int(Text2)
c = Int(Text3)
d = Int(Text4)
m = 0
l = 0
k = 0
F(m) = 0
X(m) = a
Y(m) = b

Picture1.ForeColor = vbGreen
Picture1.DrawWidth = 3
j = AbsAbs(a) - Abs(c)) + Abs(Abs(b) - Abs(d))
Form1.CurrentX = 200
Form1.CurrentY = 200
Print "初始", "进给方向 ", "F(0)=0", " X(0) =" & Int(Text1), " Y(0)=" & Int(Text2), " Xe = " & Int(Text4), " Ye = " & Int(Text3), " ∑ = " & j
If Option1.Value = True Then '第三象限插补

For n = 1 To j
If F(m) >= 0 And j > 0 Then
m = m + 1
l = l + 1
F(m) = F(m - 1) - 2 * Abs(X(m - 1)) + 1
X(m) = X(m - 1) + 1
Y(m) = Y(m - 1)
Picture1.Line (4500 + 300 * (a + l - 1), 1000 - 300 * (b - k))-(4500 + 300 * (a + l), 1000 - 300 * (b - k))
Form1.CurrentX = 200
Form1.CurrentY = 200 + m * 300
Print "第" & m & "步", " -△X ", "F(" & m & ")=" & F(m), " X(" & m & ")=" & X(m), " Y(" & m & ")=" & Y(m), " Xe = " & Int(Text4), " Ye = " & Int(Text3), " ∑ = " & j - n
Else
k = k + 1
m = m + 1
F(m) = F(m - 1) + 2 * Abs(Y(m - 1)) + 1
Y(m) = Y(m - 1) - 1
X(m) = X(m - 1)
Picture1.Line (4500 + 300 * (a + l), 1000 - 300 * (b - k + 1))-(4500 + 300 * (a + l), 1000 - 300 * (b - k))
Form1.CurrentX = 200
Form1.CurrentY = 200 + m * 300
Print "第" & m & "步", " +△Y ", "F(" & m & ")=" & F(m), " X(" & m & ")=" & X(m), " Y(" & m & ")=" & Y(m), " Xe = " & Int(Text4), " Ye = " & Int(Text3), " ∑ = " & j - n; ""
End If
Next n
ElseIf Option2.Value = True Then '第四象限插补
For n = 1 To j
If F(m) >= 0 And j > 0 Then
m = m + 1
k = k + 1
F(m) = F(m - 1) - 2 * Abs(Y(m - 1)) + 1
X(m) = X(m - 1)
Y(m) = Y(m - 1) + 1
Picture1.Line (4500 + 300 * (a + l), 1000 - 300 * (b + k - 1))-(4500 + 300 * (a + l), 1000 - 300 * (b + k))
Form1.CurrentX = 200
Form1.CurrentY = 200 + m * 300
Print "第" & m & "步", " -△Y ", "F(" & m & ")=" & F(m), " X(" & m & ")=" & X(m), " Y(" & m & ")=" & Y(m), " Xe = " & Int(Text4), " Ye = " & Int(Text3), " ∑ = " & j - n
Else
l = l + 1
m = m + 1
F(m) = F(m - 1) + 2 * Abs(X(m - 1)) + 1
Y(m) = Y(m - 1)
X(m) = X(m - 1) + 1
Picture1.Line (4500 + 300 * (a + l - 1), 1000 - 300 * (b + k))-(4500 + 300 * (a + l), 1000 - 300 * (b + k))
Form1.CurrentX = 200
Form1.CurrentY = 200 + m * 300
Print "第" & m & "步", " +△X ", "F(" & m & ")=" & F(m), " X(" & m & ")=" & X(m), " Y(" & m & ")=" & Y(m), " Xe = " & Int(Text4), " Ye = " & Int(Text3), " ∑ = " & j - n
End If
Next n
End If
End Sub

Private Sub Command3_Click() '清除
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Picture1.Cls
Form1.Cls
Text1.SetFocus