在本例中，我们制作一个外轮廓是椭圆、中间有一个方孔的窗体。
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF012
Private Sub Command1_Click()
End
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage Form1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0
End Sub
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const EM_SETRECTNP = &HB4
Private Const EM_SETRECT = &HB3
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Command1_Click()
Dim R As RECT
Dim X As Long
ScaleMode = 3
R.Left = 0
R.Top = 0
R.Right = Text1.Width
R.Bottom = Text1.Height / 2
'重新设置文本框范围
X = SendMessage(Text1.hwnd, EM_SETRECTNP, 0, R)
End Sub
Private Sub Command2_Click()
Dim R As RECT
Dim X As Long
ScaleMode = 3
R.Left = 0
R.Top = 0
R.Right = Text1.Width
R.Bottom = Text1.Height
'重新设置文本框的范围
X = SendMessage(Text1.hwnd, EM_SETRECT, 0, R)
End Sub
菜 单 标 记
本例将讲解如何在菜单项的左边显示“√”标记。
Private Sub MenColor_Click()
Diacolor.Action = 3
Text1.ForeColor = Diacolor.Color
End Sub
Private Sub MenExit_Click()
End
End Sub
Private Sub MenFont_Click()
If MenFont.Checked = False Then
Text1.FontBold = True
MenFont.Checked = True
MenMsize.Visible = True
Else
Text1.FontBold = False
MenFont.Checked = False
MenMsize.Visible = False
End If
End Sub
Private Sub MenSize_Click(Index As Integer)
Select Case Index
'选择了四号字
Case 0
Text1.FontSize = 14
MenSize(0).Checked = True
MenSize(1).Checked = False
MenSize(2).Checked = False
Case 1
Text1.FontSize = 18
MenSize(1).Checked = True
MenSize(0).Checked = False
MenSize(2).Checked = False
Case 2
Text1.FontSize = 20
MenSize(2).Checked = True
MenSize(0).Checked = False
MenSize(1).Checked = False
End Select
End Sub
五彩缤纷的清屏效果
在一些软件演示中，屏幕内容间的切换往往以一些有趣的清屏图案来相互切换。有的像演出舞台上的开幕、闭幕方式，有的像百叶窗效果，也有一些圆形、菱形等形态各异的清屏效果。本例将介绍在VB中如何实现这些清屏效果。
'设置清屏色
Dim bcolor
Private Sub Clscolor()
Randomize
bcolor = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
End Sub
'从左右两边到中间清屏
Private Sub ClrScrl()
Dim i As Integer
Clscolor
For i = 0 To ScaleWidth / 2
Line (i, 0)-(i, ScaleHeight), bcolor
Line (ScaleWidth - i, 0)-(ScaleWidth - i, ScaleHeight), bcolor
Next i
End Sub
'从中间到左右两边清屏
Private Sub ClrScr2()
Dim i As Integer
Clscolor
For i = ScaleWidth / 2 To 0 Step -1
Line (i, 0)-(i, ScaleHeight - 1), bcolor
Line (ScaleWidth - i, 0)-(ScaleWidth - i, ScaleHeight), bcolor
Next i
End Sub
'从上(顶)下(低)到中间清屏
Private Sub ClrScr3()
Dim i As Integer
Clscolor
For i = 0 To ScaleHeight / 2
Line (0, i)-(ScaleWidth, i), bcolor
Line (0, ScaleHeight - i)-(ScaleWidth, ScaleHeight - i), bcolor
Next i
End Sub
'从中间到上(顶)下(底)清屏
Private Sub ClrScr4()
Dim i As Integer
Clscolor
For i = ScaleHeight / 2 To 0 Step -1
Line (0, i)-(ScaleWidth, i), bcolor
Line (0, ScaleHeight - i)-(ScaleWidth, ScaleHeight - i), bcolor
Next i
End Sub
'菱形清屏，从四角向中心
Private Sub ClrScr5()
Dim i, j As Integer
Clscolor
For i = 0 To ScaleWidth Step 200
For j = 0 To ScaleHeight Step 200 * ScaleHeight / ScaleWidth
Line (i, 0)-(0, j), bcolor
Line (ScaleWidth - i, ScaleHeight)-(ScaleWidth, ScaleHeight - j), bcolor
Line (0, ScaleHeight - j)-(i, ScaleHeight), bcolor
Line (ScaleWidth - i, 0)-(ScaleWidth, ScaleHeight - j), bcolor
Next j
Next i
End Sub
'圆形清屏，由大至小从外围向中心
Private Sub ClrScr6()
Dim i As Integer
Clscolor
For i = ScaleWidth To 0 Step -3
Circle (ScaleWidth / 2, ScaleHeight / 2), i / 2, bcolor
Next i
End Sub
'圆形清屏，由小至大从中心向外围
Private Sub ClrScr7()
Dim i As Integer
Clscolor
For i = 0 To ScaleHeight Step 3
Circle (ScaleWidth / 2, ScaleHeight / 2), i / 2, bcolor
Next i
End Sub
Private Sub Command1_Click()
ClrScr7
ClrScr6
ClrScr5
ClrScr4
ClrScr3
ClrScr2
ClrScrl
End Sub
Private Sub Form_Load()
End Sub
重新启动计算机
本例介绍如何使用VB编写一个小程序，用来重新启动Windows和系统。
Private Declare Function exitwindows Lib "User" (ByVal dwReturnCode As Long, ByVal wReserved As Integer) As Integer
Private Sub Command1_Click()
Dim j As Integer
Dim i As Integer
j = MsgBox("真的重新启动Windows吗？", 36, "提示")
If j = 6 Then
'重启动Windows
i = exitwindows(&H42, 0)
End If
End Sub
Private Sub Command2_Click()
Dim j As Integer
Dim i As Integer
j = MsgBox("真的要重启动系统吗？", 36, "提示")
If j = 6 Then
'重新启动系统
i = exitwindows(&H43, 0)
End If
End Sub
Private Sub Command3_Click()
End
End Sub
