pf.bas

VOD卡拉OK点歌系统源码

Attribute VB_Name = "pf"
Option Explicit

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 GetShortPathName Lib "Kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer 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 mciGetDeviceID Lib "winmm.dll" Alias "mciGetDeviceIDA" (ByVal lpstrName As String) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam 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 dq As Integer
Public yl As Long

Public Type songt
songname As String
wordcount As Integer
firstword As String
swan As String
spell As String
volume As Integer
tarck As Integer
time As Integer
type As String
crc As String
love As Boolean
path As String
lang As String
End Type

Public Type swant
id As Integer
swanname As String
sex As String
firstword As String
spell As String
End Type

Public Type gamea
gamename As String
gamepath As String
End Type

Public Type js
jsname As String
jstype As String
jstip As String
jsjg As Integer
none As Integer
End Type

Public gamesz(9) As gamea
Public gamepage As Integer

Public jssz(200) As js
Public jspage As Integer
Public jstype As String
Public jsi As Integer

Public songsz(10000) As songt
Public yxsongsz(500) As songt
Public swan(1000) As swant
Public temp As songt

Public songi As Integer
Public swani As Integer
Public yxsongi As Integer


Public scountpage As Integer
Public spage As Integer
Public ysscountpage As Integer
Public ysspage As Integer
Public swanpage As Integer
Public swancountpage As Integer

Public jybj As String
Public stopbj As Boolean
Public chanbj As String

Public pydg As String
Public sdbj As String
Public from As String
Public lenght As Integer
Public sex As String

Public serverip As String
Public serverport As String
Public clinet As String
Public clinetip As String
Public clinetport As String
Public pcname As String

Public playbj As String


Public volume As Integer


Public Sub Main()
nextForm.Visible = True
主界面.Show
End Sub

Public Sub chosid(jm As String)
Unload 已选歌曲
已选歌曲.Show
Call pf.nextv
已选歌曲.jm = jm
End Sub




Public Sub calls()
呼叫.Show
End Sub




Public Sub ysong()
Dim sou As String
'Form2.msg = " 原 唱"
'Form2.Show
bcForm.Visible = True
pf.chanbj = "ys"

If pf.sdbj = "080+" Then
mciSendString "setaudio MyAVI left on", vbNullString, 0, 0
Else
mciSendString "setaudio MyAVI right on", vbNullString, 0, 0
End If

End Sub


Public Sub bsong()


Dim sou As String

bcForm.Visible = False
pf.chanbj = "bs"
If pf.sdbj = "0" Then
mciSendString "setaudio MyAVI left off", vbNullString, 0, 0

Else
mciSendString "setaudio MyAVI right off", vbNullString, 0, 0

End If

End Sub


Public Sub spaly()

sstop
End Sub

Public Sub sstop()
If pf.stopbj Then
stopform.Visible = False
mciSendString "pause MyAVI", vbNullString, 0, 0
pf.stopbj = Not pf.stopbj
Else
stopform.Visible = True
pf.stopbj = Not pf.stopbj
mciSendString "play MyAVI", vbNullString, 0, 0
End If
End Sub

Public Sub back(jn As String)
Select Case jn
Case "主界面"
主界面.Show
nextForm.Visible = True
Case "字数点歌"
字数点歌.Show
Case "歌星点歌"
歌星点歌.Show
Case "歌星选择"
歌星选择.Show
Case "歌曲列表"
歌曲列表.Show
Case "类型点歌"
类型点歌.Show
Case "语种点歌"
语种点歌.Show
Case "拼音点歌"
拼音点歌.Show
Case "已选歌曲"
已选歌曲.Show
Case "点酒水"
点酒水.Show
Case "酒水列表"
酒水列表.Show
Case Else
End Select
End Sub

Public Sub vol0()
If pf.jybj = "no" Then
mciSendString "setaudio MyAVI off", vbNullString, 0, 0
pf.jybj = "jy"
信息.text1 = "音量"
信息.text1 = "静音"
信息.Timer2.Interval = 300
Else
mciSendString "setaudio MyAVI on", vbNullString, 0, 0
pf.jybj = "no"
End If
End Sub

Public Sub help()

End Sub

Public Sub track()
If pf.chanbj = "bs" Then
Call pf.ysong
ElseIf pf.chanbj = "ys" Then
Call pf.bsong
End If
End Sub

Public Sub stops()
If pf.stopbj = "yes" Then

Call pf.spaly
ElseIf pf.stopbj = "no" Then

Call pf.sstop
End If
End Sub

Public Sub pubkey(key As Integer, win As String)
Select Case key
Case 219
Call pf.volumeadd
Case 221
Call pf.volumesub
Case 73
Call pf.nextsong
Form1.msg = "下一首"
Form1.Show

Case 82
Call pf.repaly

Case 88
Call pf.calls

Case 65
Call pf.Main

Case 72
Call pf.help

Case 75
Unload 已选歌曲
已选歌曲.Show

Case 77
Call pf.vol0

Case 66
Call pf.track

Case 84
Call pf.stops

Case 85
Call pf.kj

Case 89
Call pf.back(win)

Case 86
Call pf.kt

Case 67
Call pf.paly

Case Else
End Select
End Sub

Public Sub kj()
Dim fstat As Long
Dim length As Long

fstat = pf.pos
MsgBox fstat
'length = pf.length
'If fstat < length - 300 Then
mciSendString "seek MyAVI to " & CStr(fstat + 500), vbNullString, 0, 0
mciSendString "play MyAVI", vbNullString, 0, 0
'End If
End Sub

Public Sub kt()
Dim fstat As Long
fstat = pf.fastat
If fstat > 300 Then
mciSendString "seek MyAVI to " & CStr(fstat - 300), vbNullString, 0, 0
mciSendString "play MyAVI", vbNullString, 0, 0
End If
End Sub

Public Sub nextv()

If pf.yxsongsz(1).songname <> "" Then
     nextForm.Label11.Caption = pf.yxsongsz(1).songname
     Call nextForm.Form_Initialize
Else

     nextForm.Label11.Caption = "没有待播的歌曲"
     已选歌曲.Timer1.Enabled = False
End If
End Sub


Public Sub paly()

On Error Resume Next
Dim mciCommand As String
'Dim sou As String
Dim vol As Integer
Dim PathName As String
Dim S As String
Dim ShortPathName As String
    mciSendString "close Myavi", vbNullString, 0, 0
    
    'PathName = pf.yxsongsz(0).path & pf.yxsongsz(0).crc
    
    PathName = "h:\" & pf.yxsongsz(0).crc & ".wmv"
    
    mciCommand = "open " & PathName & " type " & " MPEGVideo " & " Alias MyAVI parent " & tv.Picture1.hwnd & " Style 1073741824"
    mciSendString mciCommand, 0, 0, 0
    'With tv.Picture1
    '    .ScaleMode = vbPixels
    '    mciCommand = "put MyAVI window at 0 0 " & _
    '                 .ScaleWidth & " " & .ScaleHeight
    '    mciSendString mciCommand, vbNullString, 0, 0
    'End With
    mciSendString "play Myavi", vbNullString, 0, 0
'sou = pf.soustat

If pf.yxsongsz(0).tarck = 0 Then
pf.sdbj = "1"
'mciSendString "setaudio MyAVI right off", vbNullString, 0, 0
Else
pf.sdbj = "0"
'mciSendString "setaudio MyAVI left off", vbNullString, 0, 0
End If

'vol = pf.yxsongsz(0).volume * 100
'mciSendString "setaudio MyAVI volume to " & CStr(vol), vbNullString, 0, 0

End Sub

Public Sub nextsong()
'MsgBox pf.yxsongi
If pf.yxsongi > 0 Then
Form1.Show
End If
End Sub


Public Sub repaly()
mciSendString "seek MyAVI to 1", vbNullString, 0, 0
mciSendString "play MyAVI", vbNullString, 0, 0
End Sub

Public Sub volumeadd()
If pf.playbj = "zero" Then


If volume < 1000 Then
volume = volume + 100
mciSendString "setaudio MyAVI volume to " & CStr(volume), 0, 0, 0
信息.text1 = "音量"
信息.text2 = " " & CStr(volume)
信息.Timer2.Interval = 300
信息.Show
End If

End If
End Sub

Public Sub volumesub()
If pf.playbj = "zero" Then

If volume > 100 Then
volume = volume - 100
mciSendString "setaudio MyAVI volume to " & CStr(volume), 0, 0, 0

信息.text1 = "音量"
信息.text2 = " " & CStr(volume)
信息.Timer2.Interval = 300
信息.Show
End If
End If
End Sub


Public Sub rsselect()

On Error Resume Next

pf.songi = 0
Do While Not rs.EOF
pf.songsz(pf.songi).songname = rs.Fields("songname")
pf.songsz(pf.songi).crc = rs.Fields("crc")
pf.songsz(pf.songi).path = rs.Fields("path")
pf.songsz(pf.songi).love = rs.Fields("love")
'If rs.Fields("lang") <> "" Then
pf.songsz(pf.songi).lang = rs.Fields("lang")
'Else
'pf.songsz(pf.songi).lang = ""
'End If
'If rs.Fields("swan") <> "" Then
pf.songsz(pf.songi).swan = rs.Fields("swan")
'Else
'pf.songsz(pf.songi).swan = "无名"
'End If
pf.songsz(pf.songi).volume = rs.Fields("volume")
pf.songsz(pf.songi).tarck = rs.Fields("track")
pf.songi = pf.songi + 1
rs.movenext
Loop

rs.Close

Unload 歌曲列表
歌曲列表.Show

End Sub

Public Sub movenext()
Dim I As Integer
If pf.yxsongi > 0 Then
     For I = 0 To pf.yxsongi - 1
     pf.yxsongsz(I) = pf.yxsongsz(I + 1)
     Next I
     pf.yxsongi = pf.yxsongi - 1
         If pf.yxsongi = 0 Then
              pf.playbj = "one"
         End If
     Call pf.nextv
     Call pf.publicpage
     
     I = pf.yxsongi
     If (I Mod 6) = 0 Then
         pf.ysscountpage = (pf.yxsongi) \ 6
     Else
         pf.ysscountpage = (pf.yxsongi) \ 6 + 1
     End If

     已选歌曲.Label19.Caption = CStr(pf.ysscountpage)
     If pf.ysspage >= pf.ysscountpage Then
         pf.ysspage = 1
         已选歌曲.Label18.Caption = CStr(pf.ysspage)
     End If

End If
End Sub


Public Sub publicpage()

Dim I&
For I = 0 To 5
已选歌曲.Label12(I).Caption = ""
已选歌曲.Label12(I).ForeColor = RGB(255, 255, 255)
已选歌曲.Label12(I).Caption = pf.yxsongsz(pf.ysspage * 6 + I - 5).songname
已选歌曲.Label13(I).Caption = ""
已选歌曲.Label13(I).Caption = pf.yxsongsz(pf.ysspage * 6 + I - 5).swan
已选歌曲.Label13(I).ForeColor = RGB(255, 255, 255)
Next I

End Sub


Public Function audiostat() As Long
Dim refstr As String * 80
mciSendString "status MyAVI volume", refstr, 80, 0
audiostat = CInt(refstr)
End Function


Public Function soustat() As String
Dim refstr As String * 80
mciSendString "status MyAVI audio source", refstr, 80, 0
soustat = refstr
End Function

Public Function fastat() As String
Dim I As Integer
Dim CharA As String
Dim RChar As String
Dim refstr As String * 255
mciSendString "status MyAVI mode", refstr, 255, 0

RChar = Right$(refstr, 1)
For I = 1 To Len(refstr)
    CharA = Mid(refstr, I, 1)
    If CharA = RChar Then Exit For
    fastat = fastat + CharA
Next I
End Function

Public Function length() As Long
Dim refstr As String * 80
mciSendString "status MyAVI length", refstr, 255, 0
length = Val(refstr)
End Function

Public Function pos() As Long
Dim refstr As String * 255
mciSendString "status MyAVI position", refstr, 255, 0
pos = Val(refstr)
End Function