初一成绩管理系统VB2

Public Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
使用方法：比如用在循环语句中循环显示多个图
for
……
doevents
sleep(1000)
next
Private Sub Command1_Click()
Picture1.Picture = LoadPicture("E:\ZJB文件夹\Pictures\0092.bmp")
DoEvents
Sleep (1000)
Picture1.Picture = LoadPicture("E:\ZJB文件夹\Pictures\1.bmp")
DoEvents
Sleep (1000)
Picture1.Picture = LoadPicture("E:\ZJB文件夹\Pictures\2.bmp")
DoEvents
Sleep (3000)
End Sub

VB中没有撤消编辑功能要用API
public declare function SendMessage Lib "user32" Alias "SendMessageA"(byval x as long,byval y as long,byval z as long,p as any) as long
调用方法：
dim t as long
t=SendMessage(Text1.hwnd,&HC7,0&,0&)

控制ctr+alt+del是否生效
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

Public Sub disabledctraltdel(flag As Boolean)
Dim ret As Long, pold As Boolean
If flag Then
ret = SystemParametersInfo(97, True, pold, 0)
Else
ret = SystemParametersInfo(97, False, pold, 0)
End If
End Sub

Call disabledctraltdel(True)
Call disabledctraltdel(false)
'出现实时错误453，找不到dll入口点:SystemParamesInfoA in user32

通用 声明
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uflags As Long, ByVal dwReserved As Long) As Long 'API函数区分大小写
Public Sub shutdownpc() '自定义的全局过程，实现关机
ExitWindowsEx 1, 0 '或：exitwindowsex 8,0
End Sub
Public Sub restartpc() '自定义的全局过程，实现重开机
ExitWindowsEx 2, 0
End Sub
Public Sub rpc() '注销当前用户，并以其它用户重新登录系统
ExitWindowsEx 0, 0
End Sub
Private Sub Command1_Click()
shutdownpc
End Sub

Private Sub Command2_Click()
restartpc
End Sub

Private Sub Command3_Click()
rpc
End Sub

对无标题栏的窗口的拖动
1、在标准模块中
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wmsg As Long, ByVal wparam As Long, iparam As Any) As Long
2、在窗体的mousedown
ReleaseCapture
SendMessage hwnd,&HA1,2,0&

检测有无声卡
Public Declare Function waveOutGetNumDevs Lib "winmm.dll" Alias "waveOutGetNumDevs"() as long
x=waveOutGetNumDevs()
if x=0 then
msgbox "无"
else
msgbox "有"
end if

开关光驱 只能打开第一个光驱?如何打开指定的光驱
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA"(byval x as string,byval y as string,byval z as long,byval h as long) as long
调用方法
mciSendString "Set CDAudio Door Open Wait",0&,0&,0&
mciSendString "Set CDAudio Door closed Wait",0&,0&,0&

调用默认的

浏览器浏览网页
public declare function ShellExecute Lib "shell32.dll" alias "ShellExecuteA"(byval x as long,byval y as string, byval z as string,byval t as string, byval s as string,byval p as long) as long
private sub label1_click()
dim ret as long
dim webaddress as string
webaddress="D:\ZJB\ZJB1.HTM"
ret=ShellExecute(0&,vbNullString,webaddress,vbNullString,vbNullString,vbNormalFocus)
end sub

利用默认的电子邮件软件发送电子邮件
public declare function ShellExecute Lib "shell32.dll" alias "ShellExecuteA"(byval x as long,byval y as string, byval z as string,byval t as string, byval s as string,byval p as long) as long
private sub label1_click()
dim ret as long
dim mailaddress as string
mailaddress="mailto:ucau@https://www.wendangku.net/doc/99571068.html,?Subject=VB问题&body+"
mailaddress=mailaddress+"VB中如何检测光驱盘符？"
ret=ShellExecute(0&,vbNullString,mailaddress,vbNullString,vbNullString,vbNormalFocus)
end sub
只能用在outlook中,其它软件中可能有错
根据电子邮件的协议，在mailto:ucau@https://www.wendangku.net/doc/99571068.html,语句末尾用？开头来指定参数
mailto:ucau@https://www.wendangku.net/doc/99571068.html,?Subject=VB问题&Body=VB中如何&CC=抄送者的邮件地址&BCC=密件抄送者的地址
Subject是邮件主题，Body是邮件的正文
主题或正文中有空格用%20来表示一个空格用一个%20

+运算符在连接字符串时，两边的类型必须为字符型。由于varNum在上一步运算时，已变为数值型，因此，应改用&运算符来连接。即连接变体型变量时，要用&运算符，一般不用+。

ByVal关键字用于指定参数采用传值的方式进行传递。如果参数定义时，未加byval，则参数只能接收常数，不能接收变量作为函数的参数。否则在调用函数Maxnum(n1,n2,n3)时将出错。另外，ByRef表示传址。
一
Private Sub Command1_Click()
Dim NewLeft, n As Long
NewLeft = Form1.ScaleWidth ' 设置标签框初始出现的位置
Do
Label1.Move NewLeft, 300 ' 移动到新位置
NewLeft = NewLeft - 50 ' 设置下次出现的位置
For n = 1 To 350 ' 利用循环实现暂停
DoEvents ' 将执行权交还操作系统
Next
Loop Until NewLeft <= -Label1.Width
End Sub

Private Sub Command2_Click()
Dim NewLeft, n As Long
NewLeft = Form1.ScaleWidth
Do While True
Label1.Move NewLeft, 300
NewLeft = NewLeft - 50
For n = 1 To 350
DoEvents
Next
' 若标签框最末端滚动出窗体视野区域，则重置初始位置
If NewLeft <= -Label1.Width Then
NewLeft = Form1.ScaleWidth
End If
Loop
End Sub
二
Option Explicit
Private Sub Command1_Click()
Static Num As Integer
If Num < 2 Then
If Text1.Text <> "Hys249078Azop^!" Then
Num = Num + 1
MsgBox "口令错误，

请重新输入！", 64, "口令校对"
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
Text1.SelText = ""
Text1.SetFocus
Else
Load MainFrm ' 装载应用程序的主窗体
MainFrm.Show
Unload Form1 ' 卸除口令校对窗体
End If
Else
MsgBox "口令无效，请与管理员联系！", 16, "口令校对"
End
End If
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Command1.Value = 1
End If
End Sub
三
Option Explicit
Public search As String
Public object As String
Public where As Long

Private Sub Command1_Click()
search = Text1.Text
object = Text2.Text
Unload Me
End Sub

Private Sub Command1_Click()
Dim sFile, temp As String
sFile = InputBox("请输入要打开的文件名及路径：", "打开文件")
If Dir(sFile) <> "" Then
Open sFile For Input As #1
temp = StrConv(InputB(LOF(1), #1), vbUnicode)
EditTXT.Text = temp
Close #1
EditFrm.Caption = "文本编辑器 — " & sFile
Else
MsgBox "指定的文件" & sFile & "未找到!", 48, "文件打开"
End If
End Sub

Private Sub Command2_Click()
Dim sFile As String
sFile = InputBox("请输入保存的路径及文件名：", "保存文件")
Open sFile For Output As #1
Write #1, EditTXT.Text
Close #1
MsgBox "文件已成功保存!", 64, "保存文件"
EditFrm.Caption = "文本编辑器 — " & sFile
End Sub

Private Sub Command3_Click()
Dim value As Integer
' 获取需要查找的字符串。
Load searchDlg
searchDlg.Show 1
where = InStr(EditTXT.Text, search) ' 在文本中查找字符串。
If where Then ' 如果找到，
EditTXT.SelStart = where - 1 ' 设置选定的起始位置并
EditTXT.SelLength = Len(search) ' 设置选定的长度。
value = MsgBox("替换吗？", 36, "查找与替换")
If value = vbYes Then
EditTXT.SelText = object
End If
Else
MsgBox "字符串未发现", 64, "查找与替换" ' 给出通知。
End If
End Sub

Private Sub Command4_Click()
Dim value As Integer
' 获取需要查找的字符串。
where = InStr(where + Len(object), EditTXT.Text, search) ' 在文本中查找字符串。
If where Then ' 如果找到，
EditTXT.SelStart = where - 1 ' 设置选定的起始位置并
EditTXT.SelLength = Len(search) ' 设置选定的长度。
value = MsgBox("替换吗？", 36, "查找与替换")
If value = vbYes Then
EditTXT.SelText = object
End If
Else
MsgBox "搜索完毕", 64, "查找下一个" ' 给出通知。
End If
End Sub

Private Sub Command5_Click()
If Command5.Caption = "编辑框只读" Then
Edit

TXT.Locked = True
Command5.Caption = "取消只读"
Else
EditTXT.Locked = False
Command5.Caption = "编辑框只读"
EditTXT.SetFocus
End If
End Sub

Private Sub Command6_Click()
Dim value As Integer
value = MsgBox("真的要退出吗？", 36, "文本编辑器")
If value = vbYes Then
End
End If
End Sub

Private Sub Form_Resize()
EditTXT.Top = 440
EditTXT.Left = 0
EditTXT.Width = EditFrm.ScaleWidth
If EditFrm.WindowState <> 1 Then '当窗体最小化时，则不执行下面语句
EditTXT.Height = EditFrm.ScaleHeight - 440
End If
End Sub
四
Option Explicit
Private Sub Timer1_Timer()
Label1.Caption = Time
End Sub
五
Option Explicit
Public hh, mm, ss As Integer
Public Function hmsValueToString(ByVal h As Integer, ByVal m As Integer, ByVal s As Integer) As String
Dim hstring, mstring, sstring As String
If h < 10 Then
hstring = "0" + Trim(Str(h))
Else
hstring = Trim(Str(h))
End If
If m < 10 Then
mstring = "0" + Trim(Str(m))
Else
mstring = Trim(Str(m))
End If
If s < 10 Then
sstring = "0" + Trim(Str(s))
Else
sstring = Trim(Str(s))
End If
hmsValueToString = hstring + ":" + mstring + ":" + sstring
End Function

Private Sub Command1_Click()
Dim temp, Hs, Ms As String, valuetime As Integer
temp = InputBox("请输入倒计时数（以分钟为单位）：", "设置倒计时")
valuetime = Val(temp)
hh = Int(valuetime / 60) '获得小时部分
mm = valuetime - hh * 60
ss = 0
Label1.Caption = hmsValueToString(hh, mm, ss)

End Sub

Private Sub Command2_Click()
Timer1.Enabled = True

End Sub

Private Sub Command3_Click()
End
End Sub

Private Sub Timer1_Timer()
If ss < 1 Then '如果秒位已为0，则向高位借
If mm < 1 Then '若分位也已为0，则向小时位借
If hh < 1 Then
Timer1.Enabled = False
MsgBox "时间到"
Exit Sub
Else
hh = hh - 1
mm = 59
ss = 60
End If
Else
mm = mm - 1
ss = 60
End If
End If
ss = ss - 1 '秒数减1
'------将本次剩余时间转换为HH:MM:SS格式
Label1.Caption = hmsValueToString(hh, mm, ss)
End Sub
六
Private Sub Command1_Click()
Picture1.Picture = LoadPicture("C:\samples\boy.gif")
End Sub

Private Sub Command2_Click()
Picture1.CurrentX = 1200
Picture1.CurrentY = 200
Picture1.FontName = "宋体"
Picture1.FontSize = 11
Picture1.Print "自画像"
End Sub

Private Sub Command3_Click()
Picture2.Picture = Picture1.Image
End Sub

Private Sub Command4_Click()
Picture2.Picture = LoadPicture("")
End Sub

Private Sub Command5_Click()
Picture2.Picture = Picture1.Picture
End Sub
七
Private Sub Command1_Click()
Dim

width2, height2 As Single
width2 = Picture1.ScaleWidth
height2 = Picture1.ScaleHeight
Picture2.PaintPicture LoadPicture("C:\samples\boy.gif"), 0, 0, , , 0, 0, width2, height2, vbSrcAnd
End Sub

Private Sub Command2_Click()
Picture3.PaintPicture Picture2.Image, 0, 0, , , 0, 0, 120, 120, vbSrcCopy
End Sub

Private Sub Command3_Click()
Set Picture3.Picture = Nothing
End Sub

Private Sub Command4_Click()
End
End Sub
八
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Command1_Click()
Dim stepheight, width2, height2, i, j, num As Long
Picture2.Width = Picture1.Width
Picture2.Height = Picture1.Height
stepheight = Val(Text1.Text)
width2 = Picture1.ScaleWidth
height2 = Picture1.ScaleHeight
num = Int(height2 / stepheight) '获得每次处理的次数
num = Int(num / 2) * 2
Set Picture2.Picture = Nothing
For i = 1 To num Step 2
Picture2.PaintPicture Picture1.Picture, 0, i * stepheight, , , 0, i * stepheight, width2, stepheight, vbSrcCopy
DoEvents
Sleep (10)
Next i
For j = 0 To num - 1 Step 2
Picture2.PaintPicture Picture1.Picture, 0, j * stepheight, , , 0, j * stepheight, width2, stepheight, vbSrcCopy
DoEvents
Sleep (10)
Next j
End Sub

Private Sub Command2_Click()
Dim stepheight, width2, height2, i, j, num As Long
stepheight = Val(Text1.Text)
width2 = Picture1.ScaleWidth
height2 = Picture1.ScaleHeight
num = Int(height2 / stepheight) '获得每次处理的次数
num = Int(num / 3) * 3


Set Picture2.Picture = Nothing
For i = 1 To num Step 3
Picture2.PaintPicture Picture1.Picture, 0, i * stepheight, , , 0, i * stepheight, width2, stepheight, vbSrcCopy
DoEvents
Sleep (30)
Next i
For j = 0 To num - 1 Step 3
Picture2.PaintPicture Picture1.Picture, 0, j * stepheight, , , 0, j * stepheight, width2, stepheight, vbSrcCopy
DoEvents
Sleep (30)
Next j
For j = 2 To num - 1 Step 3
Picture2.PaintPicture Picture1.Picture, 0, j * stepheight, , , 0, j * stepheight, width2, stepheight, vbSrcCopy
DoEvents
Sleep (30)
Next j
End Sub

Private Sub Command3_Click()
End
End Sub
九
Option Explicit
Public color As Integer

Public Sub ShowNum(source As PictureBox, Target As PictureBox, Digit As Integer, color As Integer, position As Integer)
If position <> 3 Or position < 6 Then
Target.PaintPicture source.Picture, (position - 1) * 13 + 4, 4, 13, 23, 13 * (Digit), 23 * (color - 1), 13, 23, vbSrcCopy
' Target.Refresh
End If
'注释：由于在图形数字中排列第一位的是数字0，故此处不再减1
End Sub

Public Sub ShowMaoHao(source As PictureBox, Target As PictureBox, color As Integer)
Target.PaintPicture source.Picture, (3 - 1) * 13 + 4, 4, 13, 23, 0, 23 * (color - 1), 13, 23, vbSrcCopy
Target.PaintPicture source.Picture, (6 - 1) * 13 + 4, 4, 13, 23, 0, 23 * (color - 1), 13, 23, vbSrcCopy
End Sub

Private Sub Command1_Click()
Tim

er1.Enabled = True
End Sub

Private Sub Command2_Click()
color = 1
End Sub

Private Sub Command3_Click()
color = 2
End Sub

Private Sub Command4_Click()
color = 3
End Sub

Private Sub Form_Load()
color = 1
End Sub

Private Sub Timer1_Timer()
Dim fhHour As Integer
Dim fhMin As Integer
Dim fhSec As Integer
Dim fhHour1 As Integer
Dim fhHour2 As Integer
Dim fhMin1 As Integer
Dim fhMin2 As Integer
Dim fhSec1 As Integer
Dim fhSec2 As Integer
fhHour = Hour(Now)
fhMin = Minute(Now)
fhSec = Second(Now)
If fhHour < 10 Then
fhHour1 = 0
fhHour2 = fhHour
Else
fhHour1 = Int(fhHour / 10)
fhHour2 = fhHour - fhHour1 * 10
End If
If fhMin < 10 Then
fhMin1 = 0
fhMin2 = fhMin
Else
fhMin1 = Int(fhMin / 10)
fhMin2 = fhMin - fhMin1 * 10
End If
If fhSec < 10 Then
fhSec1 = 0
fhSec2 = fhSec
Else
fhSec1 = Int(fhSec / 10)
fhSec2 = fhSec - fhSec1 * 10
End If
'------------
ShowNum SrcPic, LEDPic, fhHour1, color, 1
ShowNum SrcPic, LEDPic, fhHour2, color, 2
ShowNum SrcPic, LEDPic, fhMin1, color, 4
ShowNum SrcPic, LEDPic, fhMin2, color, 5
ShowNum SrcPic, LEDPic, fhSec1, color, 7
ShowNum SrcPic, LEDPic, fhSec2, color, 8
'-----------
ShowMaoHao MaoHaoPic, LEDPic, color
'以下代码用于数码颜色改变后，即时改变冒号的显示颜色
'当用户单击时间显示面板框时，可调整显示颜色
End Sub
十
Private Sub Timer1_Timer()
Static Forward, Down As Boolean, num As Integer
Dim NewLeft, NewTop As Long
If (((ImgWork.Left + ImgWork.Width) > Form1.ScaleWidth) And Forward) Or ((ImgWork.Left < 0) And Not Forward) Then
Forward = Not Forward
End If
If Forward Then
NewLeft = ImgWork.Left + 10
Else
NewLeft = ImgWork.Left - 10
End If
If (((ImgWork.Top + ImgWork.Height) > Form1.ScaleHeight) And Down) Or ((ImgWork.Top < 0) And Not Down) Then
Down = Not Down
End If
If Down Then
NewTop = ImgWork.Top + 7
Else
NewTop = ImgWork.Top - 7
End If
'------
ImgWork.Move NewLeft, NewTop
If num > 3 Then num = 0
ImgWork.Picture = ImgPic(num).Picture
num = num + 1
End Sub
十一
Public Sub DispCard(PicSource As PictureClip, PicObject As Image, ByVal cardtype As Integer, ByVal value As Integer)
If value > 13 Then value = value - 13 ' 对该参数进行简单的容错处理
PicSource.ClipX = (value - 1) * 73
PicSource.ClipY = (cardtype - 1) * 99
PicSource.ClipWidth = 73
PicSource.ClipHeight = 99
PicObject.Picture = PicSource.Clip
End Sub
Option Explicit

Private Sub Command1_Click()
Dim RndValue, RndCardType As Integer
RndValue = Int(Rnd * 13) + 1
RndCardType = Int(Rnd * 4) + 1
DispCard PictureClip1, Image1, RndCardType, RndValue
RndValue = Int(Rnd * 13) + 1
RndCard

Type = Int(Rnd * 4) + 1
DispCard PictureClip1, Image2, RndCardType, RndValue
RndValue = Int(Rnd * 13) + 1
RndCardType = Int(Rnd * 4) + 1
DispCard PictureClip1, Image3, RndCardType, RndValue
End Sub

Private Sub Form_Load()
PictureClip1.Picture = LoadPicture("c:\samples\cards.bmp")
Randomize
End Sub
十二
Public Num As Long
Public Sub DispCard(PicSource As PictureClip, PicObject As Image, ByVal cardtype As Integer, ByVal value As Integer)
PicSource.ClipX = (value - 1) * 73
PicSource.ClipY = (cardtype - 1) * 99
PicSource.ClipWidth = 73
PicSource.ClipHeight = 99
PicObject.Picture = PicSource.Clip
End Sub

Private Sub Command1_Click()
Dim RndValue, RndCardType, js, Col, Row As Long
Col = 1
Row = 10
Num = Val(Text1.Text)
For n = 1 To Num
RndValue = Int(Rnd * 13) + 1 ' 获得随机点值
RndCardType = Int(Rnd * 4) + 1 ' 获得随机花色
Load ImgCard(n)
DispCard PictureClip1, ImgCard(n), RndCardType, RndValue
ImgCard(n).Left = (Col - 1) * 93 + 10
ImgCard(n).Top = (Row - 1) * 20 + 10
ImgCard(n).Visible = True
js = js + 1
Row = Row - 1
If js >= 10 Then
Col = Col + 1
Row = 10
js = 0
End If
Next
Command1.Enabled = False
Command2.Enabled = True
End Sub

Private Sub Command2_Click()
For n = 1 To Num
Unload ImgCard(n)
Next
Command2.Enabled = False
Command1.Enabled = True
End Sub

Private Sub Form_Load()
Randomize
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
If (KeyAscii < Asc("0") Or KeyAscii > Asc("9")) And KeyAscii <> 8 Then
KeyAscii = 0
End If
End Sub
十三
Private Sub HScroll1_Change()
Label1.Caption = "红色分量值：" & HScroll1.Value ' 显示当前的红色分量值
LabColor.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub HScroll1_Scroll()
Label1.Caption = "红色分量值：" & HScroll1.Value ' 显示当前的红色分量值
LabColor.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub HScroll2_Change()
Label2.Caption = "绿色分量值：" & HScroll2.Value ' 显示当前的绿色分量值
LabColor.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub HScroll2_Scroll()
Label2.Caption = "绿色分量值：" & HScroll2.Value ' 显示当前的绿色分量值
LabColor.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub HScroll3_Change()
Label3.Caption = "蓝色分量值：" & HScroll3.Value ' 显示当前的蓝色分量值
LabColor.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub HScroll3_Scroll()
Label3.Caption = "蓝色分量值：" & HScroll3.Value ' 显示当前的蓝色分量值
LabColor.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)

End Sub
十四
Private Sub Form_Load()
'加载位图。
SunPic.Picture = LoadPicture("c:\samples\p01.jpg")
'初始化两个图片框的位置。
fatherPic.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height
SunPic.Move 0, 0
'将水平滚动条定位。
HScroll1.Top = fatherPic.Height
HScroll1.Left = 0
HScroll1.Width = fatherPic.Width
'将垂直滚动条定位。
VScroll1.Top = 0
VScroll1.Left = fatherPic.Width
VScroll1.Height = fatherPic.Height
'设置滚动条的 Max 属性。
HScroll1.Max = SunPic.Width - fatherPic.Width
VScroll1.Max = SunPic.Height - fatherPic.Height
'判断子图片框是否将充满屏幕。
'若如此，则无需使用滚动条。
VScroll1.Visible = (fatherPic.Height < SunPic.Height)
HScroll1.Visible = (fatherPic.Width < SunPic.Width)
End Sub

Private Sub Form_Resize()
'调整窗体大小时，改变 Picture1
'的尺寸。
fatherPic.Height = Form1.ScaleHeight
fatherPic.Width = Form1.ScaleWidth
'重新初始化图片和滚动条的
'位置。
fatherPic.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height
SunPic.Move 0, 0
HScroll1.Top = fatherPic.Height
HScroll1.Left = 0
HScroll1.Width = fatherPic.Width
VScroll1.Top = 0
VScroll1.Left = fatherPic.Width
VScroll1.Height = fatherPic.Height
HScroll1.Max = SunPic.Width - fatherPic.Width
VScroll1.Max = SunPic.Height - fatherPic.Width
'检查是否需要滚动条。
VScroll1.Visible = (fatherPic.Height < SunPic.Height)
HScroll1.Visible = (fatherPic.Width < SunPic.Width)
End Sub

Private Sub HScroll1_Change()
SunPic.Left = -HScroll1.Value
End Sub

Private Sub HScroll1_Scroll()
SunPic.Left = -HScroll1.Value
End Sub

Private Sub VScroll1_Change()
SunPic.Top = -VScroll1.Value
End Sub

Private Sub VScroll1_Scroll()
SunPic.Top = -VScroll1.Value
End Sub
十五
Private Sub Command1_Click()
List2.Clear
End Sub

Private Sub Command2_Click()
List2.RemoveItem List2.ListIndex
End Sub

Private Sub Form_Load()
Dim i As Integer
For i = 0 To Printer.FontCount - 1
List1.AddItem Printer.Fonts(i)
Next i
'-----
List3.Clear
For i = 8 To 12
List3.AddItem Trim(Str(i))
Next i
For i = 14 To 72 Step 2
List3.AddItem Trim(Str(i))
Next i
End Sub
Private Sub List1_ItemCheck(Item As Integer)
List2.AddItem List1.Text
End Sub
Private Sub List2_Click()
LabPreView.FontName = List2.Text
End Sub
Private Sub List3_Click()
LabPreView.FontSize = Val(List3.Text)
End Sub
十六
Private Sub Check1_Click()
Label1.FontBold = Check1.Value
End Sub
Private Sub Check2_Click()
Label1.FontItalic = Check2.Value
End Sub
Private Sub Check3_Click()
Label1.FontUnderline = Check3.Value
End Sub
Private Sub Check4_Click()
Label1.FontStrikethru = Check4.Value
End Sub