etkloksub.bas

vod 点歌系统,VB开发,操作相对比较简单.

Attribute VB_Name = "EtKlokSub"
Option Explicit
Private Declare Function EtDVD_OpenDRV Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_CloseDRV Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_CloseFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_StopFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_OpenFMP Lib "EtDVD.dll" (ByVal FileName As String) As Long
Private Declare Function EtDVD_PlayFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_PauseFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_IsEndFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_PlayTVFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_PlayVGAFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_AudioLeftFMP Lib "EtDVD.dll" () As Long
Private Declare Function EtDVD_AudioRightFMP Lib "EtDVD.dll" () As Long
Public Cnn As New ADODB.Connection
Public Rs As New ADODB.Recordset
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public XhFlag As Boolean
Dim hSearch As Long
Public PlayAudName As String
Public PlayFileName As String
Public YCSDFlag As String
Public PauseFlag As Boolean
Public PlaySDFlag As String
Private Type SongType
    SongName As String
    SongYCSD As String
    SongPath As String
    SongCaption As String
    SongID As String
End Type
Public WecomeMessage As String
Public ThisBFName As String
Public WecomeNumber As String
Public DbDriver As String
Public DvdCarState As String
Const MAX_PATH = 260
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
Dim WFD As WIN32_FIND_DATA
Public TDayStr As String
Public GremListNet(8) As Integer
Public GremListCPU(4) As Integer

Private Sub Main()
  If App.PrevInstance Then
    MsgBox "系统已经运行,单击确定返回!", vbInformation, "提示"
    End
  End If
  EtKlokSplash.Show
  ShowInitStyle "检测系统信息", 5
  ShowInitStyle "检查动态链接库", 10
  If Not FindMpg(App.Path + "\EtDVD.Dll") Then
    Unload EtKlokSplash
    MsgBox "EtDVD.Dll已损坏或不存在!", vbCritical, "严重错误"
    End
  End If
  ShowInitStyle "配置本机信息", 20
  ConfigINI
  ShowInitStyle "检测核心链接库及加载", 30
  If DvdCarState = "0" Then
    If Not ScanDVD Then
      Unload EtKlokSplash
      MsgBox "DVD卡驱动错误或DVD卡不存在!", vbCritical, "严重错误"
      End
    End If
  End If
  ShowInitStyle "初始化系统参数", 40
  VarINI
  ShowInitStyle "检查并连接歌曲数据库", 50
  Cnn.ConnectionString = "driver={" + DbDriver + "};FIL=MS Access;UID=admin;PWD=EtSoftWare;DBQ=" + App.Path + "\EtKlok.mdb"
  Cnn.Open Cnn.ConnectionString
  ShowInitStyle "清除历史数据", 60
  If Cnn.State Then
    Cnn.Execute "Delete * From EtYDSong"
    Cnn.Execute "Update EtSong Set EtSong.Song_DQ='0'"
  End If
  ShowInitStyle "初始化歌星数据库", 75
  EtKlokMain.StarPicInit
  ShowInitStyle "加载界面信息", 85
  BtnPicINI
  ShowInitStyle "初始化歌曲列表", 95
  ShowInitStyle "初始化完成", 100
  Unload EtKlokSplash
  EtKlokMain.Timer2.Enabled = True
  EtKlokMain.Show 1
End Sub

Public Sub PlayAudio()
Dim IsPlayFilePath As String

  If Rs.State = 1 Then Rs.Close
  Rs.Open "Select * From EtYDSong", Cnn, adOpenStatic, adLockBatchOptimistic
  If (Not IsPlayDVD) And (Not Rs.EOF) Then
    If Not XhFlag Then
      PlayAudName = Rs.Fields("Song_GM").Value
      PlayFileName = Rs.Fields("Song_FilePath").Value
      IsPlayFilePath = Rs.Fields("Song_FilePath").Value
      If Rs.Fields("Song_YCSD").Value = 0 Then
        YCSDFlag = "L"
        PlaySDFlag = "L"
      Else
        YCSDFlag = "R"
        PlaySDFlag = "R"
      End If
    Else
      IsPlayFilePath = PlayFileName
    End If
    If EtKlokMain.SelectName.Caption = Rs.Fields("Song_Caption").Value Then
      EtKlokMain.GQList.ListItems(Int(Rs.Fields("Song_ID").Value)).ForeColor = &HFFFFFF
      EtKlokMain.GQList.ListItems(Int(Rs.Fields("Song_ID").Value)).ListSubItems.Item(1).ForeColor = &HFFFFFF
      EtKlokMain.GQList.ListItems(Int(Rs.Fields("Song_ID").Value)).ListSubItems.Item(2).ForeColor = &HFFFFFF
      EtKlokMain.GQList.Refresh
    End If
    If FindMpg(IsPlayFilePath) Then
      If Not XhFlag Then
        Rs.Delete
        Rs.UpdateBatch
      End If
      Rs.Close
      StopDVD
      PlayDVD IsPlayFilePath
    Else
      MsgBox "这首歌已经损坏或不正确！", vbCritical, "连接严重错误"
      Rs.Delete
      Rs.UpdateBatch
      Rs.Close
    End If
    Cnn.Execute "Update EtSong Set EtSong.Song_DQ='0' Where Song_GM='" + PlayAudName + "' And Song_FilePath='" + PlayFileName + "'"
    EtKlokMain.YDGQUpdate
    If YCSDFlag = "L" Then
      RightDVD
    Else
      LeftDVD
    End If
  End If
  If Rs.State Then Rs.Close

End Sub

Public Sub KlokYx(SongName As String, SongYCSD As String, SongPath As String, SongCaption As String, SongID As String)
Dim YDSong() As SongType
Dim h, i, j As Integer
    i = 0
    Rs.Open "EtYDSong", Cnn, adOpenStatic, adLockBatchOptimistic
    If Not Rs.EOF Then ReDim YDSong(Rs.RecordCount + 1)
    Do While Not Rs.EOF
     i = i + 1
     YDSong(i).SongName = Rs.Fields("Song_GM").Value
     YDSong(i).SongYCSD = Rs.Fields("Song_YCSD").Value
     YDSong(i).SongPath = Rs.Fields("Song_FilePath").Value
     YDSong(i).SongCaption = Rs.Fields("Song_Caption").Value
     YDSong(i).SongID = Rs.Fields("Song_ID").Value
     Rs.MoveNext
    Loop
    Rs.Close
    For j = 1 To i
      If (YDSong(j).SongName = SongName) And (YDSong(j).SongYCSD = SongYCSD) And (YDSong(j).SongPath = SongPath) Then
        For h = j To 2 Step -1
          YDSong(h).SongName = YDSong(h - 1).SongName
          YDSong(h).SongYCSD = YDSong(h - 1).SongYCSD
          YDSong(h).SongPath = YDSong(h - 1).SongPath
          YDSong(h).SongCaption = YDSong(h - 1).SongCaption
          YDSong(h).SongID = YDSong(h - 1).SongID
        Next h
        YDSong(1).SongName = SongName
        YDSong(1).SongYCSD = SongYCSD
        YDSong(1).SongPath = SongPath
        YDSong(1).SongCaption = SongCaption
        YDSong(1).SongID = SongID
        Exit For
      End If
    Next j
    Cnn.Execute "Delete * From EtYDSong"
    Rs.Open "EtYDSong", Cnn, adOpenStatic, adLockBatchOptimistic
    For j = 1 To i
      Rs.AddNew
      Rs.Fields("Song_GM").Value = YDSong(j).SongName
      Rs.Fields("Song_YCSD").Value = YDSong(j).SongYCSD
      Rs.Fields("Song_FilePath").Value = YDSong(j).SongPath
      Rs.Fields("Song_Caption").Value = YDSong(j).SongCaption
      Rs.Fields("Song_ID").Value = YDSong(j).SongID
      Rs.UpdateBatch
    Next j
    Rs.Close
    EtKlokMain.YDGQUpdate
End Sub

Public Sub KlokDel(SongName As String, SongYCSD As String, SongPath As String, SongCaption As String, SongID As String)
  If EtKlokMain.SelectName.Caption = SongCaption Then
    EtKlokMain.GQList.ListItems(Int(SongID)).ForeColor = &HFFFFFF
    EtKlokMain.GQList.ListItems(Int(SongID)).ListSubItems.Item(1).ForeColor = &HFFFFFF
    EtKlokMain.GQList.ListItems(Int(SongID)).ListSubItems.Item(2).ForeColor = &HFFFFFF
    EtKlokMain.GQList.Refresh
  End If
  Cnn.Execute "Delete * From EtYDSong Where Song_GM='" + SongName + "' And Song_YCSD=" + SongYCSD + " And Song_FilePath='" + SongPath + "'"
  Cnn.Execute "Update EtSong Set EtSong.Song_DQ='0' Where Song_GM='" + SongName + "' And Song_YCSD=" + SongYCSD + " And Song_FilePath='" + SongPath + "'"
  EtKlokMain.YDGQUpdate
End Sub


Public Function KlokName(Str As String) As String
Dim Stemp As String
Dim Stemp2 As String
If Len(Str) <> 0 Then
    Stemp = ""
    Stemp2 = Str
    Do While Mid(Stemp2, Len(Stemp2), 1) <> "\"
        Stemp = Mid(Stemp2, Len(Stemp2), 1) + Stemp
        Stemp2 = Mid(Stemp2, 1, Len(Stemp2) - 1)
    Loop
    KlokName = Stemp
End If
End Function

Public Function BtnPicINI() As Boolean
Dim i As Integer
  EtKlokMain.CaptionImg.Picture = LoadPicture(App.Path + "\Pic\Caption.bmp")
  EtKlokMain.SysBackImg.Picture = LoadPicture(App.Path + "\Pic\BackImg.bmp")
  EtKlokSplash.Picture1.Picture = LoadPicture(App.Path + "\pic\start.bmp")
  EtKlokSplash.Picture1.Refresh
  EtKlokMain.StarBackImg.Picture = LoadPicture(App.Path + "\Pic\StarBack.bmp")
  EtKlokMain.CaseImg.Picture = LoadPicture(App.Path + "\Pic\CaseBack.bmp")
  EtKlokMain.GqflBackImg.Picture = LoadPicture(App.Path + "\Pic\FlgqBack.bmp")
  EtKlokMain.HcgqBack.Picture = LoadPicture(App.Path + "\Pic\HcgqBack.bmp")
  EtKlokMain.LxgbBackImg.Picture = LoadPicture(App.Path + "\Pic\LxgbBack.bmp")
  EtKlokMain.DyxpImg.Picture = LoadPicture(App.Path + "\Pic\XsxpBack.bmp")
End Function

Public Function FindMpg(FmName As String) As Boolean
hSearch = FindFirstFile(LCase(Trim(FmName)), WFD)
If hSearch <> -1 Then
    FindMpg = True
Else
    FindMpg = False
End If
End Function

Public Function ScanDVD() As Boolean
  CloseDVD
  If EtDVD_OpenDRV Then
    ScanDVD = True
  Else
    ScanDVD = False
  End If
End Function

Public Function CloseDVD() As Boolean
  If EtDVD_StopFMP = 1 Then
    If EtDVD_CloseFMP = 1 Then
      EtDVD_CloseDRV
      CloseDVD = True
    Else
      CloseDVD = False
    End If
  Else
    CloseDVD = False
  End If
End Function

Public Function PlayDVD(PlayFile As String) As Boolean
  If FindMpg(PlayFile) Then
    If EtDVD_OpenFMP(PlayFile) Then
      If EtDVD_PlayFMP = 1 Then
          PlayDVD = True
        PlayDVD = True
      Else
        PlayDVD = False
      End If
    Else
      PlayDVD = False
    End If
  Else
    MsgBox "播放文件不存在!"
  End If
End Function

Public Function ContinuePlayDVD() As Boolean
  If EtDVD_PlayFMP = 1 Then
    ContinuePlayDVD = True
  Else
    ContinuePlayDVD = False
  End If
End Function

Public Function PauseDVD() As Boolean
  If EtDVD_IsEndFMP <> 1 Then
    If EtDVD_PauseFMP = 1 Then
      PauseDVD = True
    Else
      PauseDVD = False
    End If
  Else
    EtDVD_PlayFMP
  End If
End Function

Public Function StopDVD() As Boolean
  If EtDVD_IsEndFMP <> 1 Then
    If EtDVD_StopFMP = 1 Then
      StopDVD = True
    Else
      StopDVD = False
    End If
  End If
End Function

Public Function LeftDVD() As Boolean
  If EtDVD_AudioLeftFMP = 1 Then
    LeftDVD = True
  Else
    LeftDVD = False
  End If
End Function

Public Function RightDVD() As Boolean
  If EtDVD_AudioRightFMP = 1 Then
    RightDVD = True
  Else
    RightDVD = False
  End If
End Function

Public Function IsPlayDVD() As Boolean
  If EtDVD_IsEndFMP = 1 Then
    IsPlayDVD = False
  Else
    IsPlayDVD = True
  End If
End Function

Public Sub OutputTV()
  EtDVD_PlayTVFMP
End Sub


Public Sub OutputVGA()
  EtDVD_PlayVGAFMP
End Sub

Public Sub ConfigINI()
  Dim PathStr As String
  Dim StrTemp As String
  PathStr = Space(100)
  StrTemp = Space(100)
  PathStr = App.Path + "\EtDVD.ini"
  If Not FindMpg(Trim(PathStr)) Then
    MsgBox "配置文件丢失，请与系统管理员联系！", vbCritical
    RunEnd
  End If
  GetPrivateProfileString "ThisBFName", "ThisBFName", "-1", StrTemp, 100, PathStr
  ThisBFName = Mid(Trim(StrTemp), 1, Len(Trim(StrTemp)) - 1)
  StrTemp = Space(100)
  GetPrivateProfileString "BDNumber", "BDNumber", "-1", StrTemp, 100, PathStr
  WecomeNumber = Mid(Trim(StrTemp), 1, Len(Trim(StrTemp)) - 1)
  StrTemp = Space(100)
  GetPrivateProfileString "WelcomeMessage", "WelcomeMessage", "-1", StrTemp, 100, PathStr
  WecomeMessage = Mid(Trim(StrTemp), 1, Len(Trim(StrTemp)) - 1)
  StrTemp = Space(100)
  GetPrivateProfileString "DBDriver", "DriverName", "-1", StrTemp, 100, PathStr
  DbDriver = Mid(Trim(StrTemp), 1, Len(Trim(StrTemp)) - 1)
  StrTemp = Space(100)
  GetPrivateProfileString "DVDCardSet", "IsNoDVD", "-1", StrTemp, 100, PathStr
  DvdCarState = Mid(Trim(StrTemp), 1, Len(Trim(StrTemp)) - 1)
End Sub

Public Sub ShowInitStyle(IsMsg As String, IsBfb As Integer)
  EtKlokSplash.JDBar.Value = IsBfb
  EtKlokSplash.JDLab.Caption = "正在: " + IsMsg + "....."
  EtKlokSplash.JDLab.Refresh
End Sub

Public Sub RunEnd()
On Error GoTo Err
    If IsNull(Cnn) Then
      Cnn.Execute "Delete * From EtYDSong"
    End If
    StopDVD
    CloseDVD
    Set Rs = Nothing
    Set Cnn = Nothing
    ExitWindowsEx 1, &HFFFFFFFF
End
Exit Sub
Err:
    EtKlokMain.Timer2.Enabled = False
    If IsNull(Cnn) Then
      Cnn.Execute "Delete * From EtYDSong"
    End If
    EtDVD_StopFMP
    EtDVD_CloseFMP
    EtDVD_CloseDRV
    Set Rs = Nothing
    Set Cnn = Nothing
    ExitWindowsEx 1, &HFFFFFFFF
End Sub

Private Sub VarINI()
  XhFlag = False
  PauseFlag = False
  YCSDFlag = "L"
End Sub

Public Function MyHotKey(vKeyCode) As Boolean
MyHotKey = (GetAsyncKeyState(vKeyCode) < 0)
End Function

Public Sub ScanKey()
  If MyHotKey(vbKeyF2) Then
    OutputVGA
  End If
  If MyHotKey(vbKeyF3) Then
    OutputTV
  End If
  
  If MyHotKey(37) Then
    If EtKlokMain.StarLbe.Caption = "已点歌曲" Then
      EtKlokMain.ChangeImg_Click
    End If
    EtKlokMain.StarPageUp_Click
  End If
  
  If MyHotKey(39) Then
    If EtKlokMain.StarLbe.Caption = "已点歌曲" Then
      EtKlokMain.ChangeImg_Click
    End If
    EtKlokMain.StarPageDown_Click
  End If
End Sub