一个画圆的程序

ludy0088 2003-05-10 12:25:27
Private Type Point '自定义point型数据,保存点的坐标
x As Single
y As Single
End Type

Dim pointfirst As Point '第一次mousedown事件所得点坐标
Dim pointlast As Point '最后一次mousemove事件所得点坐标
Dim pointmid1 As Point '中间量1
Dim pointmid2 As Point '中间量2
Dim downthing As Boolean '判定mousedown事件是否发生,保证在mousemove前先确定起始点
Dim pictype As Integer '判断画图类型
Dim downtime As Integer '判断mousedown事件发生的次数
Dim mybackcolor As Integer
Dim myforecolor As Integer

'初始化变量
Private Sub Form_Load()
downthing = False
pictype = 0
downtime = 0
Label1.Caption = ""
Label1.ForeColor = Me.ForeColor
Label1.BackColor = Me.ForeColor
End Sub
'mousedown事件,取得点坐标
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Label1.Caption = "X:" & Space(3) & x & vbCrLf & "Y:" & Space(3) & y
downtime = downtime + 1

If downtime = 1 Then
If Button And vbLeftButton Then
downthing = True
pointfirst.x = x
pointfirst.y = y
pointmid1.x = pointfirst.x
pointmid1.y = pointfirst.y
ElseIf Button And vbRightButton Then
PopupMenu mnuPictype
downtime = 0
End If
Else
downthing = False
downtime = 0 '单击第二次则获得最终图形
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Label1.Caption = "X:" & Space(3) & x & vbCrLf & "Y:" & Space(3) & y
If downthing = False Then
Exit Sub '未确定起始点则不于处理
Else
Select Case pictype
Case 0
Exit Sub
Case 1 '画直线
paintline x, y
Case 2 '画矩形
paintrect x, y
Case 3 '画圆
paintcircle x, y
End Select
End If
End Sub
'响应菜单
Private Sub Form_Resize()
Label1.Left = 0
Label1.Top = Me.ScaleHeight - Label1.Height
End Sub
Private Sub mnulinestyleDash_Click()
Me.DrawStyle = vbDash
End Sub
Private Sub mnulinestyleDashDot_Click()
Me.DrawStyle = vbDashDot
End Sub
Private Sub mnulinestyleDashDotDot_Click()
Me.DrawStyle = vbDashDotDot
End Sub
Private Sub mnulinestyleDot_Click()
Me.DrawStyle = vbDot
End Sub
Private Sub mnulinestyleSolid_Click()
Me.DrawStyle = vbSolid
End Sub
Private Sub mnuPictypeCircle_Click()
Cls
pictype = 3
End Sub
Private Sub paintcircle(x, y) '画圆过程
Dim radius As Single '半径
radius = Sqr((pointfirst.x - pointmid1.x) ^ 2 + (pointfirst.y - pointmid1.y) ^ 2)
Circle (pointfirst.x, pointfirst.y), radius / 2, Me.BackColor
pointmid2.x = x
pointmid2.y = y
radius = Sqr((pointfirst.x - pointmid2.x) ^ 2 + (pointfirst.y - pointmid2.y) ^ 2)
Circle (pointfirst.x, pointfirst.y), radius / 2, Me.ForeColor
pointmid1.x = pointmid2.x
pointmid1.y = pointmid2.y
End Sub

Private Sub mnuPictypeLine_Click() '响应菜单mnupictypeline
Cls
pictype = 1
End Sub
Private Sub paintline(x, y) '画直线过程
Line (pointfirst.x, pointfirst.y)-(pointmid1.x, pointmid1.y), Me.BackColor
pointmid2.x = x
pointmid2.y = y
Me.Line (pointfirst.x, pointfirst.y)-(pointmid2.x, pointmid2.y), Me.ForeColor
pointmid1.x = pointmid2.x
pointmid1.y = pointmid2.y
End Sub

Private Sub mnuPictypeRect_Click() '响应菜单munpictyperect
Cls
pictype = 2
End Sub
Private Sub paintrect(x, y) '画矩形过程
Line (pointfirst.x, pointfirst.y)-(pointmid1.x, pointmid1.y), Me.BackColor, B
pointmid2.x = x
pointmid2.y = y
Me.Line (pointfirst.x, pointfirst.y)-(pointmid2.x, pointmid2.y), Me.ForeColor, B
pointmid1.x = pointmid2.x
pointmid1.y = pointmid2.y
End Sub

Private Sub mnuPictyperesh_Click() '刷新操作
Cls
End Sub

Private Sub mnucolorBackcolor_Click() '选背景色
Me.BackColor = selectcolor(Me.BackColor)
Label1.BackColor = Me.BackColor
End Sub

Private Sub mnucolorForecolor_Click() '选前景色
Me.ForeColor = selectcolor(Me.ForeColor)
Label1.ForeColor = Me.ForeColor
End Sub

Private Function selectcolor(inicolor As Variant)
With CommonDialog1
.Flags = cdlCCRGBInit
.Color = inicolor
.CancelError = False
.ShowColor
selectcolor = .Color
End With
End Function

————————————————————————————————————
为什么,我画出的圆不是不像画图软件的效果呢,如何修正?
我的一个大二的女生,在学习的过程中遇到了问题,请高手多多指教哦









...全文
73 点赞 收藏 1
写回复
1 条回复
切换为时间正序
当前发帖距今超过3年,不再开放新的回复
发表回复
vcshcn 2003-05-10
在mousedown里保存圆心,在mousemove里画圆
在每次画圆以前先用背景色或异或重画一便上次的圆
回复
相关推荐
发帖
VB基础类
创建于2007-09-28

7491

社区成员

VB 基础类
申请成为版主
帖子事件
创建了帖子
2003-05-10 12:25
社区公告
暂无公告