www.pudn.com > tv_song > TV.BAS
Attribute VB_Name = "TV_Sub"
'Option Explicit
Public Declare Function SetFocusAPI& Lib "user32" Alias "SetFocus" (ByVal hwnd As Long)
'===========显示或隐藏鼠标==============================
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
'ShowCursor 0/1
Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Public Declare Function SetVolumeLabel Lib "kernel32" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long
Public Const IS_COMPRESSED = &H8000 '压缩盘的标记
'===========移动鼠标的位置==============================
Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
'SetCursorPos 20, 50
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'===========动画制作的函数==============================
Public Declare Function timeGetTime Lib "winmm.dll" () As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Type Bitmap
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Public pic As Picture
Public sX As Single, sY As Single
Public Leij As Single, hMemDc As Long
Public Bm As Bitmap, Q As Single, OldDc As Long
Public sOption As String
Public Const ZsDh = 20 '动画总数
'=============广告制作=================
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
'---------实现半透明窗体----------------------------
'首先谈谈在win2000实现半透明窗体的新函数setlayeredwindowattributes,利用这个函数
'就可以轻松创建一个半透明窗体，但是利用这个函数的程序编译后在win98下是无法运行的。
'SetLayeredWindowAttributes api函数介绍如下：
'函数功能：设置窗口透明颜色
'参数：
' hwnd //窗口手柄
' crkey //指定颜色值
' balpha //混合函数值
' dwflags //动作
'参数解释： hwnd:窗口句柄。当使用createwindowex函数创建窗口时，窗口由
' ws_ex_layered指定的值创建；或者窗口已经创建后，由setwindowlong根据
' ws_ex_layered指定的值改变。 crkey:指向一个color值，该值指定一个透
' 明颜色值，当创建窗口时，窗口将使用该值。 balpha:混合函数值。该值用
' 于描述窗口的不透明度。当balpha 值为0时，窗口完全透明，当balpha值为
' 255时，窗口完全不透明。 dwflags:指定动作。这个参数可以取一个或多个
' 值.用它我们可以创建一个不规则的窗体.
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crkey As Integer, ByVal balpha As Integer, ByVal dwflag As Long) As Boolean
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_Layered = &H80000
Public Const LWA_ColorKey = &H1
Public Const LWA_Alpha = &H2
'---如何创建透明的窗口？
'声明:
'Const WS_EX_TRANSPARENT = &H20&
'Const GWL_EXSTYLE = (-20)
'程序:
'retval = SetWindowLong(Form2.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT)
'说明:如果移动，屏幕会变乱。
'-------------------------------------
'=============检查Tv_Song.CFG中所有路径=================
Public sCOM As Integer '当前使用MODEM的串口或电话语音卡的通道号
Public mBjS As Integer '背景音乐的总数
Public MaxTime As Integer '限制操作的总计时间
Public Max As Integer '总限时
Public MpTime As Integer '每屏限制操作时间
Public Mp As Integer '每屏限时
Public YfZm As String '游飞字幕
Public YfZm0 As String '游飞字幕
Public Gqk_Path '歌曲库路径
Public GQfile_Path(99) As String '存放音像文件路径的数组
'=======================================================
Public FileName As String '播放文件名
Public ReturnValue '解霸的句柄
Public DB As Database '打开数据库
Public RmRsT As Recordset '打开数据库的记录集
Public GmRsT As Recordset '打开数据库的记录集
Public ZjBZ As Integer '摘机标志
Public Ajz As String '按键值
Public Buffer$ '接收数据缓冲区
Public tAJZ As String '临时按键值
Public KxAJZ As String
Public Flag
Public BuSy '播放标志
Public WWW As Long
Public GqDm() As String '歌曲代码
'-------------------------------------
Public RmZong As Integer '记录总数
Public RmUser As Integer '当前显示的记录总数
Public GmZong As Integer '记录总数
Public GmUser As Integer '当前显示的记录总数
'-------------------------------------
Public GqLb As String '歌曲类别
Public GqLb1 As String '歌曲类别
Public GsXm As String '歌手名称
'======================================================
Function ChkPath(FilePath As String) '检查Tv_Song.CFG中所有路径
Dim Tt
Tt = InStr(FilePath, ";")
If Tt > 0 Then FilePath = Mid(FilePath, 1, Tt - 1)
FilePath = Trim(FilePath)
If right(FilePath, 1) = "\" Then FilePath = Mid(FilePath, 1, Len(FilePath) - 1)
ChkPath = UCase(FilePath)
End Function
Sub SendCMD(sCMD As String) '向信息台发送命令
On Error Resume Next
'===如果MODEM方式的时间控件没有启动======
'If sCOMx.ComTimer.Enabled = True Then
'===向串口写指令====
sCOMx.CoMm.Output = sCMD + Chr$(13)
' Else '===否则
'===向端口2000写指令====
sCOMx.sSock.SendData sCMD
'End If
End Sub
Sub TV_Exit()
On Error Resume Next
Dim IiIi
'===向信息台发送"正在播放"或限时已到的指令====
SendCMD "PAUSE"
'===禁用TVSONG窗体的所有定时器====
TVsong.TVsongTimer.Enabled = False
TVsong.CshTimer.Enabled = False
TVsong.GqLbTimer.Enabled = False
TVsong.XzGsTimer.Enabled = False
TVsong.XzGqTimer.Enabled = False
TVsong.ZfyTimer.Enabled = False
'===摘机标志符0=====
ZjBZ = 0
'===按键值符"S"表示让点播系统初始化===
Ajz = "S"
'===停止在该通道播放语音文件===
TV_StopPlayFile (sCOM)
If Max <= 1 Or Mp <= 1 Then '===如果限时已到=====
TV_StartPlayFile sCOM, App.Path + "\XianShi", 1, LONG_MAX
Else '===否则,那就是歌曲已经点播,请用户挂机====
TV_StartPlayFile sCOM, App.Path + "\cut", 1, LONG_MAX
End If
For IiIi = 0 To 50000: DoEvents: Next IiIi
'===挂机====
TV_HangUpCtrl sCOM
'===限时操作的窗体不可见===
frmXSCZ.Visible = False
'===显示TVSONG界面====
TVsong.Flash.Visible = True
TVsong.Show
TVsong.TVsongTimer.Enabled = True
'===向信息台发送"挂机"或系统空闲的指令====
SendCMD "STOP"
Unload frmPLay
End Sub
Function TV_BL(A As Integer, B As Integer) As String
Dim AA, Bb
AA = Trim(CStr(Round((A + 4) / 9)))
Bb = Trim(CStr(Round((B + 4) / 9)))
TV_BL = AA + "/" + Bb
End Function
'===========动画制作的函数==============================
Sub XieX(Obj As Object, StartX As Long, EndX As Long, StartY As Long, EndY As Long, Xstep As String, Ystep As Single, PicX As Long, PicY As Long)
Obj.Cls
Dim XX As Single
XX = StartY + Ystep
For Q = StartX To EndX Step Xstep
XX = XX - Ystep
BitBlt Obj.hdc, Q, XX, Obj.Width, Obj.Height, hMemDc, PicX, PicY, vbSrcCopy
Delay 0.0001
Next Q
DeleteObject OldDc: DeleteObject hMemDc
End Sub
Sub Delay(ByVal N As Single)
Dim tm1 As Long, tm2 As Long
tm1 = timeGetTime
Do
tm2 = timeGetTime
If (tm2 - tm1) / 1000 > N Then Exit Do
DoEvents
Loop
End Sub
Sub MoveForm(Obj As Object, Begin As Long, XEnd As Long, Fuhao As String, Zhou As String)
Dim Q As Single, LS As Single
Obj.Cls
If Zhou = "y" Then
For Q = Begin To XEnd Step Fuhao
BitBlt Obj.hdc, 0, Q, Obj.Width, Obj.Height, hMemDc, 0, 0, vbSrcCopy
Next Q
End If
If Zhou = "x" Then
For Q = Begin To XEnd Step Fuhao
BitBlt Obj.hdc, Q, 0, Obj.Width, Obj.Height, hMemDc, 0, 0, vbSrcCopy
Next Q
End If
DeleteObject hMemDc: DeleteObject OldDc
End Sub
Sub Instal(sBmp As String, sObj As Object)
'把图形 Load 入 Pic
sObj.Cls
Set pic = LoadPicture(App.Path + "\picturebj\" + sBmp + ".jpg")
'Set Pic = sObj.Picture
'获得 Pic 的数据
GetObject pic.Handle, Len(Bm), Bm
'建立和 picturebox 相兼容的虚拟 DC
hMemDc = CreateCompatibleDC(sObj.hdc)
'建立以后恢复用的 DC
OldDc = CreateCompatibleDC(sObj.hdc)
SelectObject OldDc, sObj.Picture.Handle
'把已经 Load 图形的 Pic 选入虚拟 DC
SelectObject hMemDc, pic.Handle
End Sub
Sub DH(Xh As Integer, sBmp As String, sObj As Object)
Dim Fen As Integer, Kuan As Single
Dim Ystep As Single
Call Instal(sBmp, sObj)
Select Case Xh
'==单轴计算的图形载入方式(A)===
Case 1
MoveForm sObj, Bm.bmHeight, 0, "-40", "y"
'==单轴计算的图形载入方式(<)====
Case 2
MoveForm sObj, Bm.bmWidth, 0, "-40", "x"
'==单轴计算的图形载入方式(>)====
Case 3
MoveForm sObj, 0 - Bm.bmWidth, 0, "+40", "x"
'==单轴计算的图形载入方式(V)====
Case 4
MoveForm sObj, 0 - Bm.bmHeight, 0, "+40", "y"
'==X轴的百叶窗==================
Case 5
Fen = 20: sObj.Cls
sX = Bm.bmWidth / Fen
For Kuan = 0 To sX + 1
For Q = 0 To Fen
BitBlt sObj.hdc, sX * Q, 0, Kuan, sObj.Height, hMemDc, sX * Q, 0, vbSrcCopy
Next Q
Delay 0.0001
Next Kuan
DeleteObject hMemDc: DeleteObject OldDc
'==Y轴的百叶窗====
Case 6
Fen = 20: sObj.Cls
sY = Bm.bmHeight / Fen
For Kuan = 0 To sY + 1
For Q = 0 To Fen
BitBlt sObj.hdc, 0, sY * Q, sObj.Width, Kuan, hMemDc, 0, sY * Q, vbSrcCopy
Next Q
Delay 0.0001
Next Kuan
DeleteObject hMemDc: DeleteObject OldDc
'==由小到大的图形载入方式====
Case 7
Dim DifX As Single, DifY As Single
Dim W As Single, H As Single
sObj.Cls: Fen = 20
DifX = Bm.bmWidth / Fen: DifY = Bm.bmHeight / Fen
For Q = 1 To Fen
sX = (Bm.bmWidth - DifX * Q) / 2: sY = (Bm.bmHeight - DifY * Q) / 2
StretchBlt sObj.hdc, sX, sY, DifX * Q, DifY * Q, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
Delay 0.0001
Next Q
DeleteObject hMemDc: DeleteObject OldDc
'==斜向载入图形(\)====
Case 8
Ystep = Bm.bmHeight / Bm.bmWidth
XieX sObj, Bm.bmWidth, 0, Bm.bmHeight, 0, "-40", Ystep * 40, 0, 0
'==斜向载入图形(\)====
Case 9
Ystep = Bm.bmHeight / Bm.bmWidth
XieX sObj, 0 - Bm.bmWidth, 0, 0 - Bm.bmHeight, 0, "+40", 0 - Ystep * 40, 0, 0
'==斜向载入图形(/)====
Case 10
Ystep = Bm.bmHeight / Bm.bmWidth
XieX sObj, 0 - Bm.bmWidth, 0, Bm.bmHeight, 0, "+40", Ystep * 40, 0, 0
'==斜向载入图形(/)====
Case 11
Ystep = Bm.bmHeight / Bm.bmWidth
XieX sObj, Bm.bmWidth, 0, 0 - Bm.bmHeight, 0, "-40", 0 - Ystep * 40, 0, 0
'==分成两块X轴的载入方式====
Case 12
Dim iY As Long
sObj.Cls: iY = Bm.bmWidth: Q = 0 - Bm.bmWidth / 2
For Q = 0 - Bm.bmWidth / 2 - 1 To 0 Step 20
iY = iY - 20
BitBlt sObj.hdc, iY, 0, Bm.bmWidth / 2 + 1, Bm.bmHeight, hMemDc, Bm.bmWidth / 2, 0, vbSrcCopy
BitBlt sObj.hdc, Q, 0, Bm.bmWidth / 2, Bm.bmHeight, hMemDc, 0, 0, vbSrcCopy
Delay 0.0001
Next Q
BitBlt sObj.hdc, 0, 0, Bm.bmWidth, Bm.bmHeight, hMemDc, 0, 0, vbSrcCopy
DeleteObject hMemDc: DeleteObject OldDc
'==分成四块的图形载入方式====
Case 13
Dim ILUx As Single, ILUy As Single, IRUx As Single, IRUy As Single, _
ILDx As Single, ILDy As Single, IRDx As Single, IRDy As Single, _
Lsbmp As Long, Leij As Single
sObj.Cls
Leij = sObj.ScaleHeight / sObj.ScaleWidth
'---制作时的参照-----
ILUx = 0 - Bm.bmWidth / 2: ILUy = 0 - Bm.bmHeight / 2
IRUx = Bm.bmWidth: IRUy = 0 - Bm.bmHeight / 2
ILDx = 0: ILDy = Bm.bmHeight
IRDx = Bm.bmWidth / 2: IRDy = Bm.bmHeight / 2
'---分别计算四个图块X，Y 轴的运动轨迹------
For ILUx = 0 - Bm.bmWidth / 2 To 0 Step 20
ILUy = ILUy + Leij * 20
IRUx = IRUx - 1 * 20
IRUy = IRUy + Leij * 20
ILDy = ILDy - Leij * 20
'---直接显示在picturebox上------------
BitBlt sObj.hdc, ILUx, ILUy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, 0, 0, vbSrcCopy
BitBlt sObj.hdc, IRUx, IRUy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, Bm.bmWidth / 2, 0, vbSrcCopy
BitBlt sObj.hdc, ILUx, ILDy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, 0, Bm.bmHeight / 2, vbSrcCopy
BitBlt sObj.hdc, IRUx, ILDy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, Bm.bmWidth / 2, Bm.bmHeight / 2, vbSrcCopy
'---延时--------
Delay 0.0001
Next ILUx
'---去除接缝---------
BitBlt sObj.hdc, 0, 0, sObj.ScaleWidth, sObj.ScaleHeight, hMemDc, 0, 0, vbSrcCopy
'---删除无用的DC-------
DeleteObject hMemDc: DeleteObject OldDc
Case 14 '-->
For Fen = 0 To Bm.bmWidth Step 100
StretchBlt sObj.hdc, 0, 0, Fen, Bm.bmHeight, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
Next
DeleteObject hMemDc: DeleteObject OldDc
Case 15 '<--
For Fen = 0 To Bm.bmWidth Step 100
StretchBlt sObj.hdc, Bm.bmWidth - Fen, 0, Fen, Bm.bmHeight, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
Next
DeleteObject hMemDc: DeleteObject OldDc
Case 16 'V
For Fen = 0 To Bm.bmHeight Step 100
StretchBlt sObj.hdc, 0, 0, Bm.bmWidth, Fen, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
Next
DeleteObject hMemDc: DeleteObject OldDc
Case 17 'A
For Fen = 0 To Bm.bmHeight Step 100
StretchBlt sObj.hdc, 0, Bm.bmHeight - Fen, Bm.bmWidth, Fen, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
Next
DeleteObject hMemDc: DeleteObject OldDc
Case 18 '<->
For Fen = 0 To Bm.bmWidth / 2 Step 50
StretchBlt sObj.hdc, Bm.bmWidth / 2 - Fen, 0, Fen * 2, Bm.bmHeight, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
Next
DeleteObject hMemDc: DeleteObject OldDc
Case 19 'H
For Fen = 0 To Bm.bmHeight / 2 Step 50
StretchBlt sObj.hdc, 0, Bm.bmHeight / 2 - Fen, Bm.bmWidth, Fen * 2, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
Next
DeleteObject hMemDc: DeleteObject OldDc
Case 20 '雨滴
Dim i As Long
Dim j As Long
Dim height5 As Long, width5 As Long
Dim Picture1 As New StdPicture
sObj.ScaleMode = 3 '设定成Pixel的度量单位
'设定待Display的图
Set Picture1 = LoadPicture(App.Path + "\picturebj\" + sBmp + ".jpg")
'stdPicture物件的度量单位是Himetric所以要转换成Pixel
'height5 = ScaleY(Picture1.Height, vbHimetric, vbPixels)
'If height5 > sObj.ScaleHeight Then
height5 = sObj.ScaleHeight
'End If
'width5 = ScaleX(Picture1.Width, vbHimetric, vbPixels)
'If width5 > sObj.ScaleWidth Then
width5 = sObj.ScaleWidth
'End If
hMemDc = CreateCompatibleDC(sObj.hdc)
'将Picture1的BitMap图指定给hMemDc
Call SelectObject(hMemDc, Picture1.Handle)
For i = height5 To 1 Step -1
Call BitBlt(sObj.hdc, 0, i, width5, 1, hMemDc, 0, i, vbSrcCopy)
For j = i - 1 To 1 Step -10
Call BitBlt(sObj.hdc, 0, j, width5, 1, hMemDc, 0, i, vbSrcCopy)
Next j
Next i
'Call DeleteDC(hMemDc)
DeleteObject hMemDc: DeleteObject OldDc
Case 21
Dim A(0 To 1000) As Integer
Dim B(0 To 400) As Integer
Dim S1, S2 As Integer
Dim k, v1, k2, k1, r%, kk
sObj.Cls
'产生随机数组
For i = 0 To 1000
A(i) = 0
Next
For i = 0 To 400
Loop1: k = Int(Rnd() * 1000) + 1
If Not (A(k) = 0) Then GoTo Loop1
A(k) = i
Next
v1 = 0
For i = 0 To 1000
If Not (A(i) = 0) Then
B(v1) = A(i)
v1 = v1 + 1
End If
Next
'根据随机数组的值，拷贝小图片
S1 = Bm.bmWidth / 20
S2 = Bm.bmHeight / 20
For i = 0 To 400
k2 = B(i) Mod 20
k1 = ((Int(B(i)) - k2) / 20) * S2
k2 = k2 * S1
r% = BitBlt(sObj.hdc, k2, k1, S1 + 2, S2 + 2, hMemDc, k2, k1, &HCC0020)
For kk = 0 To 200
DoEvents
Next kk
Next
DeleteObject hMemDc: DeleteObject OldDc
End Select
End Sub