Option Explicit
Dim KZD(0 To 10) As xydxy_type
Dim BDMG As Integer
Dim dqtx As Integer
'MouseDown 定心
'MouseMove 定形
'MouseUp 画图
'利用line和shape控件,在vb6.0下,实现几何画板的设计原理。
'补充
'通过鼠标右键移动来实现控点的移动
'根据控点位置决定显示图形大小形状
Private Sub Form_Load()
Dim i As Integer
Shape0(0).Width = 150
Shape0(0).Height = 150
Shape0(0).FillStyle = 0
For i = 1 To 5 '加载控件几何图形 line0通过复制粘贴操作设置为控件数组
Load Line0(i)
Load Shape0(i)
Shape0(i).Width = 150
Shape0(i).Height = 150
Shape0(i).FillStyle = 0
Next i
Shape0(0).BorderColor = &HFF00FF '控点颜色
Shape0(0).FillColor = &HFF00FF
Shape0(1).BorderColor = vbGreen
Shape0(1).FillColor = vbGreen
Shape0(2).BorderColor = vbBlue
Shape0(2).FillColor = vbBlue
Shape0(3).BorderColor = &HC0C000
Shape0(3).FillColor = &HC0C000
Picturego.Width = Picturego.Height
BDMG = CInt(Picturego.Width / 20)
Call Optiontx_Click(dqtx)
End Sub
Sub shoutx(ByVal dq As Integer)
Dim i As Integer
Dim x As Integer
'功能 根据控点位置决定显示图形大小形状
For i = 0 To 2 '显示控点位置
Shape0(i).Left = KZD(i).xx - Shape0(i).Width / 2
Shape0(i).Top = KZD(i).yy - Shape0(i).Height / 2
Shape0(i).Visible = True
Next i
If dq = 0 Then '圆
For i = 0 To 2
Line0(i).Visible = False
Next
Shape_tx.Visible = True
x = KZD(1).xx - KZD(0).xx
x = Abs(x)
Shape_tx.Shape = 3 '1 2 4 5 6 椭圆 矩形 自己实验
Shape_tx.Height = 2 * x
Shape_tx.Width = Shape_tx.Height
Shape_tx.Left = KZD(0).xx - Shape_tx.Width / 2
Shape_tx.Top = KZD(0).yy - Shape_tx.Height / 2
End If
If dq = 1 Then '三角形
For i = 0 To 2
Line0(i).Visible = True
Next
Shape_tx.Visible = False
Line0(0).x1 = KZD(0).xx '0-1 显示3条线中的一条
Line0(0).y1 = KZD(0).yy
Line0(0).x2 = KZD(1).xx
Line0(0).y2 = KZD(1).yy
Line0(1).x1 = KZD(0).xx '0-2
Line0(1).y1 = KZD(0).yy
Line0(1).x2 = KZD(2).xx
Line0(1).y2 = KZD(2).yy
Line0(2).x1 = KZD(1).xx '1-2
Line0(2).y1 = KZD(1).yy
Line0(2).x2 = KZD(2).xx
Line0(2).y2 = KZD(2).yy
End If
End Sub
Private Sub Optiontx_Click(Index As Integer)
Dim i As Integer
Optiontx(Index).Value = True
If Index = 0 Then '圆 初始位置显示一个圆
dqtx = 0
KZD(0).xx = 10 * BDMG '设置红色控点初始位置
KZD(0).yy = 4 * BDMG
KZD(1).dx = 3 * BDMG '绿色的相对偏移量
KZD(1).dy = 0
KZD(2).dx = 0 '兰色的相对偏移量
KZD(2).dy = 3 * BDMG
For i = 1 To 2 '建设控点位置
KZD(i).xx = KZD(0).xx + KZD(i).dx
KZD(i).yy = KZD(0).yy + KZD(i).dy
Next i
ElseIf Index = 1 Then '三角形
dqtx = 1
KZD(0).xx = 10 * BDMG
KZD(0).yy = 4 * BDMG
KZD(1).dx = 4 * BDMG
KZD(1).dy = 0
KZD(2).dx = 3 * BDMG
KZD(2).dy = -3 * BDMG
For i = 1 To 2
KZD(i).xx = KZD(0).xx + KZD(i).dx
KZD(i).yy = KZD(0).yy + KZD(i).dy
Next i
End If
Call shoutx(dqtx)
End Sub
Private Sub Picturego_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Integer
If Button = 2 Then '右键是移动控点功能
Exit Sub
End If
KZD(0).xx = x
KZD(0).yy = y
For i = 1 To 2 '实现整体移动,相对位置不动
KZD(i).xx = KZD(0).xx + KZD(i).dx
KZD(i).yy = KZD(0).yy + KZD(i).dy
Next i
Call shoutx(dqtx)
End Sub
Sub set_daxiao(ByVal MOVx As Integer, ByVal MOVy As Integer, ByVal dq As Integer)
Dim i, mv As Integer '设置形状大小 几何图形 通过鼠标右键移动来实现
Dim dx, dy, ddd, ddd2, ddb, bl As Double
Dim x, y As Integer
'功能 通过鼠标右键移动来实现控点的移动
ddb = 50000 '判断是那个控点近鼠标 三角形等有用
mv = 1
For i = 1 To 2
x = KZD(i).xx
y = KZD(i).yy
dx = Abs(MOVx - x)
dy = Abs(MOVy - y)
ddd = Sqr(dx * dx + dy * dy)
If ddd < ddb Then
mv = i
ddb = ddd
End If
Next i
If dq = 0 Then
x = KZD(0).xx '用勾股定理计算距离
y = KZD(0).yy
dx = Abs(MOVx - x)
dy = Abs(MOVy - y)
ddd = Sqr(dx * dx + dy * dy)
KZD(1).dx = ddd '实际只有一个控点有效,对称的么
KZD(1).dy = 0
KZD(2).dx = 0
KZD(2).dy = ddd
For i = 1 To 2
KZD(i).xx = KZD(0).xx + KZD(i).dx
KZD(i).yy = KZD(0).yy + KZD(i).dy
Next i
ElseIf dq = 1 Then
dx = MOVx - KZD(0).xx
dy = MOVy - KZD(0).yy
KZD(mv).xx = KZD(0).xx + dx '一次只有一个控点位置变化
KZD(mv).yy = KZD(0).yy + dy
KZD(mv).dx = dx
KZD(mv).dy = dy
End If
Call shoutx(dq)
End Sub
Private Sub Picturego_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
'实现目的 设置形状大小 通过鼠标右键移动来实现
If Button = 2 Then
Call set_daxiao(x, y, dqtx)
End If
End Sub
Private Sub Command1_Click() '画图
Dim x, y, x1, y1, x2, y2, rr As Integer
Picturego.DrawWidth = 4
If dqtx = 0 Then '圆
x = KZD(0).xx
y = KZD(0).yy
rr = Abs(KZD(1).xx - KZD(0).xx)
Picturego.Circle (x, y), rr, RGB(0, 0, 0)
Picturego.Circle (x, y), 30, vbRed
ElseIf dqtx = 1 Then '三角形
x1 = KZD(0).xx
y1 = KZD(0).yy
x2 = KZD(1).xx
y2 = KZD(1).yy
Picturego.Line (x1, y1)-(x2, y2), RGB(0, 0, 0) '0-1
x2 = KZD(2).xx
y2 = KZD(2).yy
Picturego.Line (x1, y1)-(x2, y2), RGB(0, 0, 0) '0-2
x1 = KZD(1).xx
y1 = KZD(1).yy
Picturego.Line (x1, y1)-(x2, y2), RGB(0, 0, 0) '1-2
End If
Call Optiontx_Click(dqtx)
End Sub
Private Sub Command2_Click() '清空
Picturego.Cls
End Sub |