tv.bas

广播级有线电视台MTV互动点播系统

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