eddvdsys.bas

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

Attribute VB_Name = "EdDVDSys"
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 RsSong As New ADODB.Recordset
Public RsStar As New ADODB.Recordset

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 hSearch As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
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 WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Dim WFD As WIN32_FIND_DATA

Public WecomeMessage As String
Public ThisBFName As String
Public WecomeNumber As String
Public DbDriver As String
Public DvdCarState As String

Public Sub Main()
  If Not FindMpg(App.Path + "\EtDVD.Dll") Then
    MsgBox "EtDVD.Dll已损坏或不存在!", vbCritical, "严重错误"
    End
  End If
  ConfigINI
  If Not FindMpg(App.Path + "\EtKlok.Mdb") Then
    MsgBox "EtKlok.Mdb已损坏或不存在!", vbCritical, "严重错误"
    End
  End If
  Cnn.ConnectionString = "driver={" + DbDriver + "};FIL=MS Access;UID=admin;PWD=EtSoftWare;DBQ=" + App.Path + "\EtKlok.mdb"
  Cnn.Open Cnn.ConnectionString
  RsSong.Open "EtSong", Cnn, adOpenKeyset, adLockOptimistic
  RsStar.Open "EtStar", Cnn, adOpenKeyset, adLockOptimistic
  SongINI
  StarINI
  If Not ScanDVD Then
    MsgBox "DVD卡驱动错误或DVD卡不存在!", vbCritical, "严重错误"
    CloseDVD
  End If
  EtSysFrm.Show 1
End Sub

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
        If EtDVD_AudioLeftFMP = 1 Then
          PlayDVD = True
        End If
        PlayDVD = True
      Else
        PlayDVD = False
      End If
    Else
      PlayDVD = False
    End If
  Else
    MsgBox "播放文件不存在!"
  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 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 ScanNull(ScanDt) As Boolean
  If ScanDt = "" Or IsNull(ScanDt) Then
    ScanNull = True
  Else
    ScanNull = False
  End If
End Function

Public Sub SongINI()
  If RsSong.State Then
    If Not RsSong.EOF Then
      If ScanNull(RsSong.Fields("Song_GM").Value) Then
        EtSysFrm.SongNameTxt.Text = ""
      Else
        EtSysFrm.SongNameTxt.Text = RsSong.Fields("Song_GM").Value
      End If
      If ScanNull(RsSong.Fields("Song_GXM").Value) Then
        EtSysFrm.StarNameTxt.Text = ""
      Else
        EtSysFrm.StarNameTxt.Text = RsSong.Fields("Song_GXM").Value
      End If
      If ScanNull(RsSong.Fields("Song_GXM").Value) Then
        EtSysFrm.StarNameTxt.Text = ""
      Else
        EtSysFrm.StarNameTxt.Text = RsSong.Fields("Song_GXM").Value
      End If
      If ScanNull(RsSong.Fields("Song_FilePath").Value) Then
        EtSysFrm.SongFileTxt.Text = ""
      Else
        EtSysFrm.SongFileTxt.Text = RsSong.Fields("Song_FilePath").Value
      End If
      If Not ScanNull(RsSong.Fields("Song_GMCD").Value) Then
        EtSysFrm.SongCountCbo.Text = RsSong.Fields("Song_GMCD").Value
      End If
      If Not ScanNull(RsSong.Fields("Song_GMZS").Value) Then
        EtSysFrm.SongZSCbo.Text = RsSong.Fields("Song_GMZS").Value
      End If
      If FindMpg(Trim(EtSysFrm.SongFileTxt.Text)) Then
        EtSysFrm.FileLinkLab = "此文件连接正确!"
      Else
        Beep
        EtSysFrm.FileLinkLab = "此文件连接不正确!"
      End If
      Select Case RsSong.Fields("Song_GQYZ").Value
              Case 1
                  EtSysFrm.SongYZCbo.ListIndex = 0
              Case 2
                  EtSysFrm.SongYZCbo.ListIndex = 1
              Case 3
                  EtSysFrm.SongYZCbo.ListIndex = 2
              Case 4
                  EtSysFrm.SongYZCbo.ListIndex = 3
              Case 5
                  EtSysFrm.SongYZCbo.ListIndex = 4
              Case 6
                  EtSysFrm.SongYZCbo.ListIndex = 5
              Case 7
                  EtSysFrm.SongYZCbo.ListIndex = 6
              Case 8
                  EtSysFrm.SongYZCbo.ListIndex = 7
              Case 9
                  EtSysFrm.SongYZCbo.ListIndex = 8
      End Select
      Select Case RsSong.Fields("Song_GXXB").Value
              Case 0
                  EtSysFrm.StarXBCbo.ListIndex = 1
              Case 1
                  EtSysFrm.StarXBCbo.ListIndex = 0
              Case 2
                  EtSysFrm.StarXBCbo.ListIndex = 2
      End Select
      If RsSong.Fields("Song_ISHC").Value Then
          EtSysFrm.SongHCCbo.ListIndex = 0
      Else
          EtSysFrm.SongHCCbo.ListIndex = 1
      End If
      If RsSong.Fields("Song_YCSD").Value Then
        EtSysFrm.SongSDCbo.ListIndex = 1
      Else
        EtSysFrm.SongSDCbo.ListIndex = 0
      End If
      If RsSong.Fields("Song_ISLX").Value Then
        EtSysFrm.SongLXCbo.ListIndex = 1
      Else
        EtSysFrm.SongLXCbo.ListIndex = 0
      End If
    End If
  End If
End Sub

Public Sub StarINI()
  If RsStar.State Then
    EtSysFrm.StarNTxt.Text = RsStar.Fields("StarName").Value
    EtSysFrm.StarPTxt.Text = RsStar.Fields("StarPath").Value
    If FindMpg(Trim(App.Path + "\" + EtSysFrm.StarPTxt.Text)) Then
      EtSysFrm.Picture2.Picture = LoadPicture(App.Path + "\" + EtSysFrm.StarPTxt.Text)
    Else
      Beep
      MsgBox "找不到该歌星图片!", vbInformation, "图片显示错误"
      EtSysFrm.Picture2.Picture = LoadPicture()
    End If
  End If
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
    End
  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)
  EtSysFrm.BfNameTxt.Text = ThisBFName
  EtSysFrm.BDCountTxt.Text = WecomeNumber
  EtSysFrm.WelcomeMsgTxt.Text = WecomeMessage
End Sub

Public Function SaveCfgINI(AppName As String, KeyName As String, ThisValue As String) As Boolean
  On Error GoTo Err
  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
    End
  End If
  StrTemp = Trim(ThisValue)
  WritePrivateProfileString AppName, KeyName, StrTemp, PathStr
  MsgBox "保存成功！", vbInformation, "成功"
  SaveCfgINI = True
  Exit Function
Err:
  MsgBox "保存失败！", vbInformation, "失败"
  SaveCfgINI = False
End Function