form1.frm

一个很好的多媒体播放器

Const WM_NCLBUTTONDOWN = &HA1
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const HWND_TOPMOST = -1
Const SWP_SHOWWINDOW = &H40
'-------------------API  移动窗体完毕
Public TextLine  As String  '文字信息
Private Index     As Long    '字符索引

Private Scrolling As Boolean '滚动标志
Private t         As Long    '帧延时

Private RText     As RECT
Private RClip     As RECT
Private RUpdate   As RECT
Private 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
 

Private Sub A1_PlayStateChange(ByVal NewState As Long)
On Error Resume Next

Dim lrc As String, alrc As String, ttd As String

Dim LastSt As String
If A1.playState = 3 Then
Timer1.Enabled = True
Else
'Timer1.Enabled = False
End If
If A1.playState = 3 Then
Timer1.Enabled = True
Timer4.Enabled = True
Label6.Caption = "正在播放"
LastSt = "正在播放"
Timer2.Enabled = True
AAttributeName = "专辑名称：" & A1.currentMedia.getItemInfo("Album")
Atitel = "标题：" & A1.currentMedia.getItemInfo("Title")
AAuthor = "艺术家：" & A1.currentMedia.getItemInfo("Author")
AFileSize = "文件大小：" & Format(A1.currentMedia.getItemInfo("FileSize") / 1000000, "0.0") & "MB"
AFileType = "文件类型：" & A1.currentMedia.getItemInfo("FileType")
Form1.Label5.Caption = Atitel
Label10.Caption = A1.currentMedia.durationString
PAa = A1.Controls.currentPositionString
lrc = App.Path & "\lrc\" & Text1.Text & ".lrc"
List1.Clear
Open lrc For Append As #1
Print #1, ""
Close #1
Open lrc For Input As #4
Input #4, ttd
If ttd = "" Then
Form7.Show
Close #4
Else
Do While Not EOF(4)
Line Input #4, alrc
List1.AddItem Trim(alrc)
Loop
Close #4
End If


ElseIf A1.playState = 6 Then
Label6.Caption = "正在缓冲"
LastSt = "正在缓冲"
AaA = AaA + 5
Timer2.Enabled = True
ElseIf A1.playState = 9 Then
Label6.Caption = "正在连接"
LastSt = "正在连接"
AaA = 10
ElseIf A1.playState = 10 Then
Label6.Caption = "准备就绪"
AaA = 1
'If LastSt = "正在缓冲" Or laststr = "正在连接" Then
'List2.Selected(List2.ListIndex + 1) = True
'A1.URL = List2.Text
'A1.Controls.play
'End If
End If

End Sub


Private Sub FlatBttn1_Click()

AaA = 10
Timer1.Enabled = True
List3.AddItem Text1.Text, 0
List3.Selected(0) = True
Call Der
End Sub

Private Sub FlatBttn2_Click()
AaA = 10
Timer1.Enabled = True

If List2.ListCount - 1 > List2.ListIndex Then
List2.Selected(List2.ListIndex + 1) = True
End If
Label7.Caption = List2.Text
A1.URL = List2.Text
A1.Controls.play

End Sub

Private Sub FlatBttn3_Click()
Unload Me
End Sub

Private Sub Form_Load()
On Error Resume Next
  SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
A1.settings.autoStart = False
 With iScroll
        SetRect RClip, 0, 1, .ScaleWidth, .ScaleHeight
        SetRect RText, 0, .ScaleHeight, .ScaleWidth, .ScaleHeight + .TextHeight("")
    End With
        
    '-- 默认 = 居中
   Dim sed As String
Open App.Path & "\" & "setting.ini" For Input As #1
Do While Not EOF(1)
Line Input #1, sed
List3.AddItem sed
Loop
Close #1
Dim n As Long
For n = 0 To List3.ListCount - 1 Step 1
If List3.List(n) = "" Then
List3.RemoveItem (n)
End If
Next n
List3.Selected(0) = True
Text1.Text = List3.List(0)
End Sub
Public Sub Der()
'WebBrowser1.TheaterMode = True
'WebBrowser1.Navigate "http://www.baiday.com/search.php?word=" & List3.Text & "&lm=-1"
'WebBrowser1.Navigate "http://mp3.80bbs.com/search.asp?mname=" & Text1.Text & "&radiotype=ordermname"

WebBrowser1.Navigate "http://search.tom.com/searchmp3.php?word=" & List3.Text & "&mimetype=all"
End Sub


Private Sub Form_Unload(Cancel As Integer)
Dim Vcxc As Long
Open App.Path & "\setting.ini" For Output As #8
For Vcxc = 0 To List3.ListCount - 1 Step 1
Print #8, List3.List(Vcxc)
Next Vcxc
Close #8

A1.Close
Unload Form7
End Sub

Private Sub Label11_Click()
Form1.WindowState = 1
End Sub

Private Sub Label14_Click()
Unload Me
End Sub

Private Sub Label2_Change()
'If Label2.Caption = "搜索完毕" Then
'If List2.ListCount > 0 Then
'List2.Selected(1) = True
'End If
'End If
End Sub



Private Sub Label8_Change()
On Error Resume Next
Dim cdc As Long, ccc As Long
cdc = Label8.Caption
ccc = Label10.Caption
If cdc = ccc - 1 And List3.ListIndex < List3.ListCount - 1 Then
List3.Selected(List3.ListIndex + 1) = True
Text1.Text = List3.Text
Call Der
ElseIf cdc = ccc - 1 And List3.ListIndex >= List3.ListCount - 1 Then
List3.Selected(0) = True
Text1.Text = List3.Text
Call Der
End If
End Sub

Private Sub List3_DblClick()
Text1.Text = List3.Text
Call Der
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
'按下鼠标左键
If Button = vbLeftButton Then
'为当前的应用程序释放鼠标捕获
ReleaseCapture
'移动窗体
SendMessage Form1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
Else
Me.Hide
MsgBox "制作版权:孙凤鸣,请注意原作者权利", vbInformation, "版权信息"
Me.Show
End If
End Sub

Private Sub Timer1_Timer()
If AaA >= 1 Then
AaA = AaA - 1
Else
If Label6.Caption = "正在缓冲" Then
AaA = 10
'Timer1.Enabled = False
End If
If Label6.Caption <> "正在播放" And List2.ListCount - 1 > List2.ListIndex Then
Timer1.Enabled = True
List2.Selected(List2.ListIndex + 1) = True
Label7.Caption = List2.Text
A1.URL = List2.Text
A1.Controls.play
AaA = 10
End If
End If


End Sub

Private Sub Timer2_Timer()
Dim AVlu As Double, Smin As Long, Ssor As Long
'Label8.Caption = PAa
AVlu = A1.Controls.currentPosition
Smin = AVlu \ 60
Ssor = AVlu - ((AVlu \ 60) * 60)
Form1.Label8.Caption = Format$(Smin, "00") & ":" & Format$(Ssor, "00")


'If A1.URL = "" Then
'Form1.Label4.Enabled = False
'Else
'Form1.Label4.Enabled = True
'End If
'If Form1.cpvSlider1.Value >= Form1.cpvSlider1.Max - 1 Then
'Form2.List1.Selected(Form2.List1.ListIndex) = True
'If Kloop = True Then
'Call Sloop
'End If
'A1.URL = Form2.List1.Text
'A1.Controls.play
'End If
Dim ntime As Long, itt As Long, tqq As String, pos As Long
tqq = Form1.Label8.Caption
For ntime = 0 To List1.ListCount - 1
For itt = 1 To Len(List1.List(ntime)) Step 1
pos = InStr(1, List1.List(ntime), tqq)
If pos > 0 Then
If Mid$(List1.List(ntime), 90, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 90)
ElseIf Mid$(List1.List(ntime), 80, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 80)
ElseIf Mid$(List1.List(ntime), 70, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 70)
ElseIf Mid$(List1.List(ntime), 60, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 60)
ElseIf Mid$(List1.List(ntime), 50, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 50)
ElseIf Mid$(List1.List(ntime), 40, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 40)
ElseIf Mid$(List1.List(ntime), 30, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 30)
ElseIf Mid$(List1.List(ntime), 20, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 20)
ElseIf Mid$(List1.List(ntime), 10, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 10)
ElseIf Mid$(List1.List(ntime), 63, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 63)
ElseIf Mid$(List1.List(ntime), 56, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 56)
ElseIf Mid$(List1.List(ntime), 49, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 49)
ElseIf Mid$(List1.List(ntime), 42, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 42)
ElseIf Mid$(List1.List(ntime), 35, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 35)
ElseIf Mid$(List1.List(ntime), 28, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 28)
ElseIf Mid$(List1.List(ntime), 21, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 21)
ElseIf Mid$(List1.List(ntime), 14, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 14)
ElseIf Mid$(List1.List(ntime), 7, 1) = "]" Then
Form1.Label4.Caption = Right$(List1.List(ntime), Len(List1.List(ntime)) - 7)
End If
End If
Next itt
Next ntime
End Sub

Private Sub Timer3_Timer()
Label1.Caption = AaA
If Label7.Width > Picture2.Width Then
Label7.Left = Label7.Left - 10
If Label7.Left <= -Label7.Width Then
Label7.Left = Picture2.Width
End If
End If
End Sub

Private Sub Timer4_Timer()
If Form1.Label5.Caption = Atitel Then
Form1.Label5.Caption = AAuthor
ElseIf Form1.Label5.Caption = AAuthor Then
Form1.Label5.Caption = AAttributeName
ElseIf Form1.Label5.Caption = AAttributeName Then
Form1.Label5.Caption = AFileSize
ElseIf Form1.Label5.Caption = AFileSize Then
Form1.Label5.Caption = AFileType
ElseIf Form1.Label5.Caption = AFileType Then
Form1.Label5.Caption = Atitel
End If
End Sub

Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
On Error Resume Next
Dim AcV As Boolean
Dim alrc As String
'Form6.a1.Controls.stop
If WebBrowser1.ReadyState = READYSTATE_LOADING Then
Me.Label2.Caption = "正在搜索歌曲，请稍后..."
End If
If WebBrowser1.ReadyState = READYSTATE_COMPLETE Then
Me.Label2.Caption = "搜索完毕"
Dim vTag, vDoc

Dim Allcount, i

List2.Clear

Set vDoc = WebBrowser1.Document.All

Allcount = vDoc.Length

For i = 0 To Allcount - 1

If UCase(vDoc.Item(i).TagName) = "A" Then '\'找到URL

vTag = vDoc.Item(i).href

If InStr(LCase(vTag), ".mp3") Or InStr(LCase(vTag), ".wma") Then ' \'检测URL中是否含有http://dhunter.51.net

List2.AddItem vDoc.Item(i).href '\'如果有,则添加到list2中

End If

End If

Next i
If List2.ListCount >= 0 Then
List2.Selected(0) = True
Label7.Caption = List2.Text
A1.URL = List2.Text
A1.Controls.play
Timer1.Enabled = True
AaA = 10
'AcV = DownloadFile(List1.Text, PathLrc)
'If AcV = True Then
'AcV = False
'Me.Label4.Caption = "歌词下载完毕"
'If Form6.a1.URL = "" Then
'Else
'Form6.List1.Clear
'Open Left$(Form6.a1.URL, Len(Form6.a1.URL) - 4) + ".lrc" For Input As #4
'Do While Not EOF(4)
'Line Input #4, alrc
'Form6.List1.AddItem Trim(alrc)
'Loop
'Close #4
'Form6.a1.Controls.pause
'Form6.a1.Controls.play
'Me.Hide
'Unload Me
'End If
'End If
'End If
End If
End If
End Sub
Private Sub Scroll()

  Dim Char As String
  
    With iScroll
         SetRect RClip, 1, 2, .ScaleWidth, .ScaleHeight
         SetRect RText, .ScaleWidth, 2, .ScaleWidth + .TextWidth(Left$(TextLine, 1)), .ScaleHeight
    End With

    Char = Left$(TextLine, 1)

    With iScroll

        Do
            If (timeGetTime - t >= 30) Then

                t = timeGetTime

                If (RText.Right <= .ScaleWidth) Then

                    Index = Index + 1
                    Char = Mid$(TextLine, Index, 1)
                    SetRect RText, .ScaleWidth, 2, .ScaleWidth + .TextWidth(Mid$(TextLine, Index, 1)), .ScaleHeight
                End If

                DrawText .hdc, Char, 1, RText, &H0

                OffsetRect RText, -1, 0

                ScrollDC .hdc, -1, 0, RClip, RClip, 0, RUpdate
                iScroll.Line (.ScaleWidth - 1, 0)-(.ScaleWidth - 1, .ScaleHeight - 1), .BackColor
            End If

            If (Index > Len(TextLine)) Then Index = 0
            DoEvents
            
        Loop Until Scrolling = 0
    End With
End Sub