DDA直线插补和圆弧插补VB程序

'Option Explicit
'起点坐标，终点坐标，脉冲当量
Dim x1%, y1%, x2%, y2%, p!
Dim Di As Integer '-1为顺时针，1为逆时针
Const PI = 3.14159

Private Sub cmdShow_Click()
If Text1(0) <> "" And Text1(1) <> "" And _
Text1(2) <> "" And Text1(3) <> "" Then
x1 = Val(Text1(0)): y1 = Val(Text1(1))
x2 = Val(Text1(2)): y2 = Val(Text1(3))
Else
MsgBox "输入坐标不完整!"
Exit Sub
End If
pic.Cls '清屏
axis pic '画坐标轴
p = Val(Combo1.Text) '读取脉冲当量
cmdShow.Enabled = False
If Option1.Value Then '演示直线插补
pic.Circle (x1, y1), 0.1, vbBlack
pic.Circle (x2, y2), 0.1, vbBlack
chabu_l pic, x1, y1, x2, y2
ElseIf Option2.Value Then '圆弧插补
pic.Circle (x1, y1), 0.1, vbBlack
pic.Circle (x2, y2), 0.1, vbBlack
If x1 ^ 2 + y1 ^ 2 = x2 ^ 2 + y2 ^ 2 Then
chabu_c1 pic, x1, y1, x2, y2
Else
MsgBox "输入坐标错误！请重新输入！", vbCritical
End If
End If
cmdShow.Enabled = True
End Sub

Private Sub chabu_l(obj As Object, x0%, y0%, xe%, ye%) '直线插补
Dim x!, y!
f = 0
x = x0: y = y0
obj.Line (x0, y0)-(xe, ye), vbBlue
obj.CurrentX = x
obj.CurrentY = y
n = (Abs(xe - x0) + Abs(ye - y0)) / p '总步数
While n <> 0
If f >= 0 Then
If xe <> x0 Then
x = x + Sgn(xe - x0) * p
Else 'xe=0时，应该先向y轴运动
y = y + Sgn(ye - y0) * p
End If
f = f - Abs(ye - y0)
Else
If ye <> y0 Then
y = y + Sgn(ye - y0) * p
End If
f = f + Abs(xe - x0)
End If
obj.Line -(x, y), vbRed '画折线
n = n - 1
DoEvents
For i = 1 To 2000000 * p
'延时
Next i
Wend
End Sub

Private Sub Form_Load()
If App.PrevInstance Then End '禁止两个程序同时运行
Combo1.AddItem "0.01"
Combo1.AddItem "0.02"
Combo1.AddItem "0.05"
Combo1.AddItem "0.1"
Combo1.AddItem "0.2"
Combo1.AddItem "0.5"
Combo1.AddItem "1"
Show
st = "逐点比较插补法演示程序"
Me.Font.Size = 24
x = (Me.ScaleWidth - Me.TextWidth(st)) / 2
y = 10 '(pic.Top - Me.TextWidth(St)) / 2
Randomize
For i = 1 To 10
CurrentX = x: CurrentY = y
Me.ForeColor = Rnd * 65535
Print st
x = x + 0.6
y = y + 0.4
Next i
Combo1.Text = Combo1.List(5)
pic.Height = 450
pic.Width = 450
pic.Scale (-10, 10)-(10, -10)
axis pic '画坐标轴
End Sub
'**********************************************************************
Private Sub axis(obj As Object)
'画x轴
obj.Line (-obj.ScaleWidth / 2 + 0.5, 0)-(obj.ScaleWidth / 2 - 0.5, 0)
obj.Line -(obj.ScaleWidth / 2 - 1, 0.2)
obj.Line (obj.ScaleWidth / 2 - 0.5, 0)-(obj.ScaleWidth / 2 - 1, -0.2)
'画y轴
obj.Line (0, obj.ScaleHeight / 2 + 0.5)-(0, -obj.ScaleHeight / 2 - 0.5)
obj.Line -(-0.2, -obj.ScaleHeight / 2 - 1)
obj.Line (0, -obj.ScaleHeight / 2 - 0.5)-(0.2, -obj.ScaleHeight / 2 - 1)
obj.Font.Size = 9
'画刻度
For cx = -9 To

9 Step 3
obj.Line (cx, 0)-(cx, 0.2)
If cx <> 0 Then
obj.CurrentX = cx - 0.3
obj.CurrentY = -0.2
obj.Print cx
End If
Next
For cy = -9 To 9 Step 3
obj.Line (0, cy)-(0.2, cy)
If cy <> 0 Then
obj.CurrentX = -0.8
obj.CurrentY = cy + 0.2
obj.Print cy
End If
Next
obj.CurrentX = -0.5
obj.CurrentY = -0.2
obj.Font.Size = 12
obj.Print "O" '坐标原点

End Sub
'*********************************************************************
Private Sub chabu_c1(obj As Object, x0%, y0%, xe%, ye%)
'第一象限圆弧插补
n = Abs(xe - x0) + Abs(ye - y0): n = n / p '总步数
f = 0
r = Sqr(x0 ^ 2 + y0 ^ 2)
If x0 <> 0 Then
startP = Atn(y0 / x0)
Else
startP = PI / 2
End If
If xe <> 0 Then
endP = Atn(ye / xe)
Else
endP = PI / 2
End If
If x0 <= xe Then
Di = -1 '顺时针
obj.Circle (0, 0), r, vbBlue, endP, startP
Else
Di = 1
obj.Circle (0, 0), r, vbBlue, startP, endP
End If

obj.CurrentX = x0
obj.CurrentY = y0
x = x0: y = y0
While n <> 0
If f * Di > 0 Then
f = f - 2 * x * Di + p
x = x - p * Di
ElseIf f * Di < 0 Then
f = f + 2 * y * Di + p
y = y + p * Di
ElseIf f * Di = 0 Then
If Di = 1 Then
f = f + 2 * y * Di + p
y = y + p
Else
f = f - 2 * x * Di + p
x = x - p * Di
End If
End If
n = n - 1
obj.Line -(x, y), vbRed
DoEvents
For i = 1 To 2000000 * p
'延时
Next i
Wend
End Sub

Private Sub Text1_Change(Index As Integer)
If Abs(Val(Text1(Index).Text)) > 9 Then
MsgBox "输入数值过大，屏幕内不能完全显示！"
Text1(Index).Text = ""
End If
If Left(Text1(Index), 1) = "0" And Len(Text1(Index)) = 2 Then
Text1(Index) = Right(Text1(Index), 1)
End If
If Right(Text1(Index), 1) = "-" And Len(Text1(Index)) = 2 Then
Text1(Index) = Left(Text1(Index), 1)
End If
End Sub

'Private Sub Text1_Click(Index As Integer)
'Text1(Index).SelStart = 0
'Text1(Index).SelLength = Len(Text1(Index))
'End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
'只能输入数字，负号
If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 45 _
And KeyAscii <> 8 Then
KeyAscii = 0
End If

End Sub