请问如何用vb的图片框画图?要求是鼠标按下来画矩形、圆之类的图(旁边有单选按钮来选择图形)。

请问如何用vb的图片框画图?要求是鼠标按下来画矩形、圆之类的图(旁边有单选按钮来选择图形)。,第1张

Dim x1 As Single, y1 As Single, s As Integer
Const pi = 314159265
Private Sub Form_Load()
Command1Caption = "圆"
Command2Caption = "矩形"
Command3Caption = "三角"
Command4Caption = "五角"
Command5Caption = "清"
End Sub
Private Sub Command1_Click()
s = 1
End Sub
Private Sub Command2_Click()
s = 2
End Sub
Private Sub Command3_Click()
s = 3
End Sub
Private Sub Command4_Click()
s = 4
End Sub
Private Sub Command5_Click()
Picture1Cls
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then x1 = x: y1 = y
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Picture1AutoRedraw = False
Picture1Refresh
Picture1PSet (x1, y1)
Select Case s
Case 1
Picture1Circle (x1, y1), Sqr((x - x1) ^ 2 + (y - y1) ^ 2)
Case 2
Picture1Line (x1, y1)-(x, y), , B
Case 3
duobianxing x1, y1, x, y, 3, 60
Case 4
duobianxing x1, y1, x, y, 5, 36
End Select
End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Picture1AutoRedraw = True
Select Case s
Case 1
Picture1Circle (x1, y1), Sqr((x - x1) ^ 2 + (y - y1) ^ 2)
Case 2
Picture1Line (x1, y1)-(x, y), , B
Case 3
duobianxing x1, y1, x, y, 3, 60
Case 4
duobianxing x1, y1, x, y, 5, 36
End Select
End If
End Sub
'duobianxing函数参数:
'zhongxinX-多边形中心的横坐标
'zhongxinY-多边形中心的纵坐标
'dingdianX-多边形一个顶点的横坐标
'dingdianY-多边形一个顶点的纵坐标
'bianhuoxing-正多边形的边数或者星形的星角数,例如biaohuoxing=5,dingjiao=72则为正五边形,若dingjiao=36则为五角星(该函数将正多边形按相邻顶角点间的折点成直线的特殊星形绘制)
'dingjiao-多边形的顶角的角度(角度制°)
Function duobianxing(ByVal zhongxinX As Single, ByVal zhongxinY As Single, ByVal dingdianX As Single, ByVal dingdianY As Single, ByVal bianhuoxing As Integer, ByVal dingjiao As Single)
If bianhuoxing = 0 Then Exit Function
l = Sqr((zhongxinX - dingdianX) ^ 2 + (zhongxinY - dingdianY) ^ 2) '星形中心到顶角距离
t1 = Abs(Tan((dingjiao / 2) pi / 180)) '星形顶角的1/2求正切
t2 = Abs(Tan((360 / (2 bianhuoxing)) pi / 180)) '星形每条边所对应的中心角的1/2求正切
r = l t2 / (t1 + t2) / Cos((dingjiao / 2) pi / 180) '星形边长
If zhongxinX = dingdianX Then '求星形中心到顶角这条线的角度j
j = IIf(dingdianY < zhongxinY, 90, -90)
Else
j = Atn((zhongxinY - dingdianY) / (dingdianX - zhongxinX)) 180 / pi
If dingdianX < zhongxinX Then
If dingdianY > zhongxinY Then
j = j - 180
Else
j = j + 180
End If
End If
End If
j1 = j - dingjiao / 2 '边偏离初始角1
j2 = 360 / bianhuoxing + dingjiao + j - dingjiao / 2 '边偏离初始角2(如果是正多边形j1=j2)
px1 = dingdianX: py1 = dingdianY '指定星形的第一个顶点
For i = 1 To bianhuoxing 2
If i Mod 2 = 0 Then
px2 = px1 + r Cos(j2 pi / 180): py2 = py1 - r Sin(j2 pi / 180) '指定星形下一个顶点
j2 = j2 + 360 / bianhuoxing '边偏角+2个边长对应的中心角
Else
px2 = px1 - r Cos(j1 pi / 180): py2 = py1 + r Sin(j1 pi / 180)
j1 = j1 + 360 / bianhuoxing
End If
Picture1Line (px1, py1)-(px2, py2) '画线
px1 = px2: py1 = py2
Next
End Function

调整这个
Picture1PSet
(1500
+
6000

x,
5500
-
5000

y),
RGB(50

R,
100

R,
10

R)
把6000x,和5000y,做调整,6000和5000变大或者变小,看看效果。

Private Sub Command1_Click()
Dim i As Integer, j As Integer, k As Integer
Dim n As Integer, m As Integer
For n = 1 To 2000 Step 50
    For m = 1 To 2000 Step 50
    Form1ForeColor = RGB(Rnd  255, Rnd  255, Rnd  255)
    If Rnd > 08 Then s1 m + 500, n + 500
    Next
Next
End Sub
Public Sub s1(x As Integer, y As Integer)
Dim i As Integer, j As Integer
Dim n As Integer, m As Integer
For n = 1 To 50 Step 2
    For m = 1 To 50 Step 2
    If Rnd < 01 Then Exit For
    If Rnd > 09 Then PSet (x + m, y + n)
    Next
    If Rnd < 01 Then Exit For
Next
End Sub

VB提供的绘制图形的方法:(可以在窗体上或PicTureBox控件上使用)
与你主题相关的有:
1,绘制直线
objectLine (x1,y1) - (x2,y2), [color]
其中:(x1,y1) 和 (x2,y2)分别是平面上的两个点坐标。
2,绘制一点:
objectPSet (x,y), [color]
其中:(x1,y1) 是平面上的一个点坐标。
3,绘制图形的笔尖的粗细:
objectDrawWidth = size
默认粗细为1。
4,绘制图形的线条的颜色设置:
1)ObjectForeColor = QbColor(n) :n = 0 -- 15
2) 或者在使用上述方法时,在后边跟的参数[color]
思路:
绘制曲线,就是根据函数关系:y = f(x),采用描点法,在某一区域范围内,根据x计算y,然后用
PSet (x,y)实现曲线的绘制。

Private Sub Form_Load()
Picture1AutoRedraw = True
Picture1DrawWidth = 2
Picture1Circle (500, 500), 200
SavePicture Picture1Image, "c:\tupianbmp"
End Sub


欢迎分享,转载请注明来源:内存溢出

原文地址: http://outofmemory.cn/yw/12967575.html

(0)
打赏 微信扫一扫 微信扫一扫 支付宝扫一扫 支付宝扫一扫
上一篇 2023-05-29
下一篇 2023-05-29

发表评论

登录后才能评论

评论列表(0条)

保存