【例9-1】 用Shape控件的Shape属性显示Shape控件的6种形状，并填充不同的图案，
Private Sub Form_Activate()
Dim i As Integer
Print " 0 1 2 3 4 5"
Shape1(0).Shape = 0
Shape1(i).FillStyle = 2
For i = 1 To 5
Load Shape1(i) ' 装入数组控件
Shape1(i).Left = Shape1(i -1).Left +1000 '确定控件Left属性
Shape1(i).Visible = True ' 显示该控件
Shape1(i).Shape = i ' 确定所需要的几何形状
Shape1(i).FillStyle = i + 2 ' 填充不同的图案
Next i
End Sub
【例9-2】 在Form_Paint事件中通过Scale方法定义窗体Form1的坐标系。
Private Sub Form_Paint()
Cls
Form1.Scale (-200,250) - (300,-150)
Line (-200,0) -(300,0) ' 画X轴
Line (0,250) - (0,-150) ' 画Y轴
CurrentX = 0,CurrentY = 0,Print 0 ' 标记坐标原点
CurrentX = 280,CurrentY = 20,Print "X" ' 标记X轴
CurrentX = 10,CurrentY = 240,Print "Y" ' 标记Y轴
End Sub
【例9-3】 用Print方法在窗体上随机显示50个"★"和50个"☆"。
Private Sub Form_Click()
Dim i As Integer
Randomize
For i = 1 To 100
CurrentX = Form1.Width * Rnd
CurrentY = Form1.Height * Rnd
If (i Mod 2) = 0 Then
Print "★ "
Else
Print "☆ "
End If
Next i
End Sub
【例9-4】 通过改变DrawStyle属性值在窗体上画出不同的线形，产生如图9.5所示效果。
Private Sub Form_Click()
Dim j As Integer
Print "DrawStyle 0 1 2 3 4 5 6"
Print " 线 型 实线 长划线 点线 点划线 点点划线 透明线 内实线"
Print " 图 示 "
CurrentX =600 ' 设置直线的开始位置
CurrentY = ScaleHeight / 3
DrawWidth = 1 ' 宽度为1时DrawStyle属性才能产生线型
For j = 0 To 6
DrawStyle = j ' 定义线的形状
CurrentX = CurrentX + 150
Line -Step(600,0) ' 画线长600的线段
Next j
End Sub
【例9-5】 利用滚动条设计一个调色板。
Private Sub HScroll1_Change(Index As Integer)
Picture1.BackColor = RGB(HScroll1(0),HScroll1(1),HScroll1(2))
For i = 0 To 2
label1(i).Caption = HScroll1(i).Value
Next
End Sub
【例9-6】 演示颜色的渐变过程。
Private Sub Form_Click()
Dim j As Integer,x As Single,y As Single
y = Form1.ScaleHeight
x = Form1,ScaleWidth ' 设置直线X方向终点坐标
sp = 255 / y ' 每次改变基色的增量
For j = 0 To y
Line (0,j)-(x,j),RGB(j * sp,j * sp,j * sp) ' 画线
Next j
End Sub
【例9-7】 画金刚石图案。
Option Explicit
Const Pi As Double = 3.1415926
Private Sub Command1_Click()
′画金刚石图案
Me.BackColor = vbWhite
Me.ForeColor = RGB(Rnd * 255,Rnd * 255,Rnd * 255)
Cls
Dim n,x0,y0,r As Integer
n = 20 ′ n 为角点个数
x0 = Width / 2
y0 = Height / 2
r = y0 * 0.8
Dim px(),py() As Double
ReDim px(n),py(n)
Dim i,j As Integer
′计算坐标
For i = 1 To n
px(i) = x0 + r * Cos(i * 2 * Pi / n)
py(i) = y0 + r * Sin(i * 2 * Pi / n)
Next
′画对角线
For i = 1 To n
For j = 1 To i - 1
Line (px(i),py(i))-(px(j),py(j))
Next
Next
End Sub
Private Sub Form_Load()
Randomize
End Sub
【例9-8】 画圆环。
Private Sub Form_Paint()
p.Cls
p.Scale (-300,-300)-(300,300)
p.ForeColor = QBColor(4)
pi = 3.1416
For k = -pi To pi Step 0.25
For i = 0 To 2 * pi Step 0.001
ix = 120 * Cos(i)
iy = 80 * Sin(i)
ix1 = ix * Cos(k) - iy * Sin(k)
iy1 = ix * Sin(k) + iy * Cos(k)
p.PSet (ix1,iy1)
Next i
Next k
End Sub
【例9-9】 画螺线。
Dim i As Single
Scale (-15,15)-(15,-15)
Line (0,14)-(0,-14)
Line (14,0)-(-14,0)
For i = 0 To 12 Step 0.01
X = i * Cos(i)
Y = i * Sin(i)
PSet (X,Y)
Next i
End Sub
【例9-10】利用菜单在窗体图片框中选择画出正弦曲线和余弦曲线。
Private Sub mnu_San1_Click（Index As Integer）
oldx = Picture1.ScaleWidth / 2
oldy = Picture1.ScaleHeight / 2
Select Case Index
Case 0
For t = -oldx To oldx Step 0.01
xt = 10 * t
yt = 10 * Sin（t）
Picture1.PSet （xt + oldx,oldy - yt）,RGB（0,127,127）
Next
Case 1
For t = -oldx To oldx Step 0.01
xt = 10 * t
yt = 10 * Cos（t）
Picture1.PSet （xt + oldx,oldy - yt）,RGB（0,127,127）
Next
Case 2
Picture1.Cls
Form_Paint
Exit Sub
Case 4
Unload Me
End Select
End Sub
利用Paint事件绘制坐标轴及刻度，其代码为：
Private Sub Form_Paint()
Const PI = 3.14159
With Picture1
,Top = 0
,Left = 0
,Width = Me.ScaleWidth
,Height = Me.ScaleHeight
,ScaleMode = 6
oldx =,ScaleWidth / 2
oldy =,ScaleHeight / 2
,Cls
'画坐标轴
Picture1.Line （oldx,0）-（oldx,.ScaleHeight）,RGB（255,0,0）
Picture1.Line （0,oldy）-（.ScaleWidth,oldy）,RGB（255,0,0）
End With
Picture1.CurrentX = oldx - 4
Picture1.CurrentY = oldy + 0.5
Picture1.Print 0
'画x轴的刻度
For xt = -Int（oldx） To Int（oldx） Step 0.5
If xt <> 0 Then
st = xt * 10 * PI
Picture1.CurrentX = oldx + st - 3
Picture1.CurrentY = oldy + 0.5
Picture1.Print xt & "π"
Picture1.Line （oldx + st,oldy - 1）-（oldx + st,oldy）,RGB（255,0,0）
End If
Next
'画y轴的刻度
For yt = -5 To 7
If yt <> 0 Then
st = yt * 10
Picture1.CurrentX = oldx - 4
Picture1.CurrentY = oldy + st - 1
Picture1.Print yt
Picture1.Line （oldx,oldy + st）-（oldx + 1,oldy + st）,RGB（255,0,0）
End If
Next
End Sub
Private Sub Form_Resize()
Refresh
End Sub
【例9-11】 曲柄滑块机构的演示。
Private Sub Command1_Click()
If Command1.Caption = "暂停" Then
Command1.Caption = "继续"
Timer1.Enabled = False
Else
Command1.Caption = "暂停"
Timer1.Enabled = True
End If
End Sub
Private Sub Form_Load()
With Shape1
,Tag =,Width / 2 '圆的半径
X0 =,Left +,Tag '圆心的X坐标
Y0 =,Top +,Tag '圆心的Y坐标
End With
With Line2 '连杆的长
Line2.Tag = Sqr((.X1 -,X2) ^ 2 + (.Y1 -,Y2) ^ 2)
End With
End Sub
Private Sub Timer1_Timer()
t = t + 1
Shape3.Left = X0 - Shape1.Tag * Cos(PI * t / 30) - Shape3.Width /2
Shape3.Top = Y0 + Shape1.Tag * Sin(PI * t / 30) - Shape3.Width /2
Line2.X1 = Shape3.Left + Shape3.Width /2
Line2.Y1 = Shape3.Top + Shape3.Width /2
Line2.X2 = Shape3.Left + Sqr(Line2.Tag ^ 2 - (Shape3.Top - Y0) ^ 2)
Line1.X2 = Line2.X1
Line1.Y2 = Line2.Y1
Shape2.Left = Line2.X2
End Sub
【例9-12】 一个走动的时钟。
编写代码时，先在通用段说明几个常数：
Const DX = 2800
Const DY = 2300
Const PI = 3.14159265
Private Sub Form_Load()
Linem.X1 = DX,Lines.X1 = DX,Lineh.X1 = DX
Linem.Y1 = DY,Lines.Y1 = DY,Lineh.Y1 = DY
Shape1.Left = DX - 2000
Shape1.Top = DY - 2000
Shape1.Width = 4000
Shape1.Height = 4000
For i = 0 To 11 '定位刻度
Line1(i).X1 = DX + 1400 * Cos((i - 12) * 2 * PI / 12 - PI / 2)
Line1(i).Y1 = DY + 1400 * Sin((i - 12) * 2 * PI / 12 - PI / 2)
If i > 10 Or i < 2 Then
Line1(i).X2 = DX + 2000 * Cos((i - 12) * 2 * PI / 12 - PI / 2)
Line1(i).Y2 = Shape1.Top + 10
ElseIf i < 5 Then
Line1(i).X2 = Shape1.Left + Shape1.Width - 10
Line1(i).Y2 = DY + 2000 * Sin((i - 12) * 2 * PI / 12 - PI / 2)
ElseIf i < 8 Then
Line1(i).X2 = DX + 2000 * Cos((i - 12) * 2 * PI / 12 - PI / 2)
Line1(i).Y2 = Shape1.Top + Shape1.Height - 10
ElseIf i < 11 Then
Line1(i).X2 = Shape1.Left + 10
Line1(i).Y2 = DY + 2000 * Sin((i - 12) * 2 * PI / 12 - PI / 2)
End If
Next i
End Sub
Private Sub Timer1_Timer(Index As Integer)
Dim h As Integer,s As Integer,mm As Integer
s = Second(Time) '秒
mm = Minute(Time) '分
h = Hour(Time) '时
If h >= 12 Then h = h - 12
Lineh.X2 = 500 * Cos((h - 12) * 2 * PI / 12 - PI / 2) + DX
Lineh.Y2 = 500 * Sin((h - 12) * 2 * PI / 12 - PI / 2) + DY
Lines.X2 = 1000 * Cos((s - 60) * 2 * PI / 60 - PI / 2) + DX
Lines.Y2 = 1000 * Sin((s - 60) * 2 * PI / 60 - PI / 2) + DY
Linem.X2 = 800 * Cos((mm - 60) * 2 * PI / 60 - PI / 2) + DX
Linem.Y2 = 800 * Sin((mm - 60) * 2 * PI / 60 - PI / 2) + DY
End Sub
【例9-13】 图像的颜色处理
Option Explicit
Dim PColor() As Long
Private Sub Command1_Click()
Dim i,j As Integer
Dim r,g,b,y As Long
Dim m As Long
For i = 0 To ScaleWidth
For j = 0 To ScaleHeight
PColor(i,j) = Point(i,j)
r = GetRValue(PColor(i,j))
g = GetGValue(PColor(i,j))
b = GetBValue(PColor(i,j))
y = 0.299 * r + 0.587 * g + 0.144 * b ′亮度
PSet (i,j),RGB(y,y,y) ′变灰
′PSet (i,j),RGB(y * 1.4,y * 0.9,y * 0.7) ′若用该语句，则变成淡淡的红色
Next
DoEvents
Next
End Sub
Private Sub Command2_Click()
Dim i,j As Integer
Dim r,g,b,y As Long
Dim m As Long
For i = 0 To ScaleWidth
For j = 0 To ScaleHeight
PColor(i,j) = Point(i,j)
Next
DoEvents
Next
Dim ratio As Long
ratio = 3′锐化的程度
For i = 1 To ScaleWidth - 1
For j = 1 To ScaleHeight - 1
r = GetRValue(PColor(i,j)) + ratio * (GetRValue(PColor(i,j)) - GetRValue(PColor(i + 1,j + 1)))
g = GetGValue(PColor(i,j)) + ratio * (GetGValue(PColor(i,j)) - GetGValue(PColor(i + 1,j + 1)))
b = GetBValue(PColor(i,j)) + ratio * (GetBValue(PColor(i,j)) - GetBValue(PColor(i + 1,j + 1)))
If r < 0 Then r = 0
If g < 0 Then g = 0
If b < 0 Then b = 0
If r > 255 Then r = 255
If g > 255 Then g = 255
If b > 255 Then b = 255
PSet (i,j),RGB(r,g,b)
Next
DoEvents
Next
End Sub
Private Sub Form_Load()
Picture = LoadPicture(App.Path & "D:\Zhumlm.jpg")
Me.ScaleMode = vbPixels
ReDim PColor(ScaleWidth,ScaleHeight)
End Sub
Function GetRValue(PntColor As Long) As Long
′颜色在内存中的表示是&H00bbggrr
GetRValue = PntColor And &HFF
End Function
Function GetGValue(PntColor As Long) As Long
GetGValue = (PntColor / &H100) And &HFF
End Function
Function GetBValue(PntColor As Long) As Long
GetBValue = (PntColor And &HFF0000) / &H10000
End Function
