frmvbamp.frm

一个类似于WinAmp的Mp3播放器,功能不错,有换肤等功能,是一个不错的vb播放器.

    On Error GoTo PLReadErr
    
    FF = GetBaseName(F) 'path+filename without extension
    Path = ValidateDir(GetPath(F)) 'Get path of playlist as base for entries
    Lbl(14).Caption = MakeTitle(F)
    
    PLCover = FindCover(FF)
    Call LoadCover(F)
        
    n = PlPath.ListCount
    
    FIO = FreeFile
    Open F For Input As FIO
    
    Select Case UCase(GetExtension(F))
      Case "M3U": GoSub LoadM3U
      Case "PLS": GoSub LoadPLS
    End Select
PLReadErr:
    Close FIO
    Exit Sub
    
LoadM3U:
    While Not EOF(FIO)
        Line Input #FIO, AA: A = Trim(AA)
        If n < 32766 And Left$(AA, 1) <> "#" Then GoSub AddIt
    Wend
    Return
  
LoadPLS:
    While Not EOF(FIO)
        Line Input #FIO, AA: AA = Trim(A)
        If n < 32766 And Left(AA, 4) = "File" Then
            i = InStr(AA, "=")
            If i > 0 Then A = Mid(AA, i + 1): GoSub AddIt
        End If
    Wend
    Return

AddIt:
    If Left$(UCase$(A), 5) = "HTTP:" Then
        PlPath.AddItem A
        PlNames.AddItem A
    Else
        FilePath = ValidateDir(GetPath(A))
        Filename = GetFileName(A)
        X = MakeTitle(Filename)
        If IsPic(B) Then X = X + " (picture)"
    
        PlNames.AddItem X
    
        If Mid(FilePath, 2, 1) = ":" Then
            'The path is the "full path"
            XX = FilePath + Filename
        ElseIf Left(FilePath, 1) = "\" Then
            'Root without drive
            XX = Left(Path, 2) + FilePath + Filename
        Else
            'The path is relative, so add the playlist path
            XX = Path + FilePath + Filename
        End If
    
        PlPath.AddItem XX
    End If
    n = n + 1
    Return

End Sub

'Display the Save Playlist Dialog box then save playlist保存列表
Private Sub PlSave()
Dim F As String
    On Error GoTo ErrHandler4
    
    CommonDialog1.CancelError = True
    CommonDialog1.InitDir = OptDefPath
    CommonDialog1.DialogTitle = "Save Playlist"
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.Filter = "MP3 Playlists (*.M3U)|*.M3U"
    CommonDialog1.FilterIndex = 1
    CommonDialog1.Filename = ""
    CommonDialog1.ShowSave
 
    F = CommonDialog1.Filename
    OptDefPath = GetPath(F)
    SaveSetting Prg, Sect, "Path", OptDefPath
    
    Call WritePL(F)
    Lbl(14).Caption = MakeTitle(F)
    
ErrHandler4:
End Sub

'Write the playlist to a file
Sub WritePL(F As String)
Dim P1 As String, L As Long, J As Integer, A As String
    On Error GoTo ErrHandler5
    
    P1 = GetPath(F): L = Len(P1)
    Open F For Output As 1
                
    For J = 1 To PlPath.ListCount
        A = PlPath.List(J - 1)
        If A <> "" Then If InStr(A, "**") = 0 Then GoSub WriteIt
    Next
    Close 1: Exit Sub

WriteIt:
    If Left(A, L) = P1 Then
        'same dir as playlist, so convert to relative
        Print #1, Mid(A, L + 1)
    Else
        'different directory, so just use it
        Print #1, A
    End If
    Return

ErrHandler5:
    Close
    MsgBox "Unable to write Playlist! Is the file read-only?"
    Exit Sub

End Sub

'Handle Slider Double-clicking
Private Sub iSlider_DblClick(Index As Integer)
    Select Case Index
        Case 3 'Balance
            Balance = 0.5
            Call SetSlider(Index, Balance)
            Call DoSlider(Index, Balance)
        Case 5 'Playback Rate
            Call DoSlider(5, 0.5)
    End Select
End Sub

'Slider is clicked
Private Sub iSlider_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If SlideFlag = 0 Then
        If Sli(Index).H = 0 Then
            IX = X: FX = iSlider(Index).Left: TX = Screen.TwipsPerPixelX
            Timer1.Enabled = False
        Else
            IY = Y: FY = iSlider(Index).Top: TY = Screen.TwipsPerPixelY
        End If
        SlideFlag = Index
    End If
End Sub

'Slider is being moved
Private Sub iSlider_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If SlideFlag > 0 Then
    Dim Min As Long, Max As Long, pos As Long
        If Sli(Index).H = 0 Then
            Min = Sli(Index).X: Max = Sli(Index).W + Min 'Horizontal slider
            pos = FX + (X - IX)
            If pos < Min Then pos = Min
            If pos > Max Then pos = Max
            FX = pos
            NewP = (pos - Min) / (Max - Min)
        Else
            Min = Sli(Index).Y: Max = Sli(Index).H + Min 'vertical slider
            pos = FY + (Y - IY)
            If pos < Min Then pos = Min
            If pos > Max Then pos = Max
            FY = pos
            NewP = 1 - ((pos - Min) / (Max - Min))
        End If
        
        Call SetSlider(Index, NewP)
        Call DoSlider(Index, NewP)

    End If
    
End Sub

'Slider is released. Call appropriate routine with new position
Private Sub iSlider_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim p As Double
If Index = 1 Then p = Int(NewP * SongLen): Call PlayFrom(p)
Timer1.Enabled = True
SlideFlag = 0
End Sub

'Set specified slider to position (percentage 0.00 to 1.00)
'Note: Does NOT actually control feature linked to slider
Private Sub SetSlider(SliNum, ByVal PctPos As Single)
    Dim n As Long
        
    Sli(SliNum).V = PctPos 'store slider value (0 to 1)
    If iSlider(SliNum).Visible = False Then Exit Sub
    
    Select Case SliNum
        Case 1 To 3, 5: GoSub SetSPos
        Case 4: GoSub SetInd
    End Select
    iSlider(SliNum).Refresh
    Exit Sub
    
SetSPos:
    If Sli(SliNum).H = 0 Then
        'Horizontal slider
        n = Sli(SliNum).X + Int(PctPos * Sli(SliNum).W)
        If n <> Sli(SliNum).F Then iSlider(SliNum).Left = n: Sli(SliNum).F = n
    Else
        'Vertical Slider
        n = Sli(SliNum).Y + Sli(SliNum).H - Int(PctPos * Sli(SliNum).H)
        If n <> Sli(SliNum).F Then iSlider(SliNum).Top = n: Sli(SliNum).F = n
    End If
    Return

SetInd:
    If Sli(SliNum).H = 0 Then
        'Horizontal slider
        n = Int(PctPos * Sli(SliNum).W)
        If n <> Sli(SliNum).F Then iSlider(SliNum).Width = n: Sli(SliNum).F = n
    Else
        'Vertical Slider
        n = Sli(SliNum).H - Int(PctPos * Sli(SliNum).H)
        If n <> Sli(SliNum).F Then iSlider(SliNum).Height = n: Sli(SliNum).F = n
    End If
    Return

End Sub

' Acts on slider being adjusted (real time)
' Note: Some sliders only react when the slider is released (iSlider_MouseUp)
Private Sub DoSlider(SliNum, PctPos As Single)
        Select Case SliNum
            Case 1 'Playback position; Show Time only (position changes when released)
                Dim CPos As Long
                CPos = Int(PctPos * SongLen)
                Dim Min As Integer, Sec As Integer, X As String
                Dim LastTime As String, Remain As Double
                Remain = SongLen - Elapsed
                If TimeFlag Then TimeDisp = Remain Else TimeDisp = Elapsed
                Min = CPos \ 60: Sec = Int(CPos - Min * 60)
                X = Format(Min, "") + ":" + Format(Sec, "00")
                If TimeFlag Then X = "-" + X
            
                If X <> LastTime Then
                    Lbl(1).Caption = X: Call SetDD(1, CPos)
                    LastTime = X
                End If
            Case 2
                Call SetVol(PctPos) 'Volume changes as slider moves
                Lbl(18).Caption = Str$(Int(PctPos * 100))
                Call SetSlider(4, PctPos)
            Case 3 'Balance; Changes as slider moves
                Call SetBalance(PctPos)
                Call SetSlider(3, PctPos)
            Case 4 'Volume indicator; changes when volume is adjusted
            Case 5 'speed slider
                Call SetRate(PctPos)
                Call SetSlider(5, PctPos)
        End Select
End Sub

'Display Folder Browse dialog then add files from selected path to playlist
Sub AddFromDir()
Dim A As String
    A = GetBrowseDir(Me, "Select Directory containing Media Files:")
    If A <> "" Then Call AddDir(A, Me, PlNames, PlPath, OptValExt)
End Sub

'Load a bitmap album cover file
Sub LoadCover(A As String)
Dim C As String
    On Error GoTo LCErr:
    If A = LastCover Then Exit Sub 'don't reload same cover!
    If Pref.Visible = True Then Exit Sub 'can't open if prefs visible!
    
    If A = "" Then GoSub ClearCover: Exit Sub
    
    C = ""
    If InStr(A, ".") = 0 Then
        C = FindCover(A) 'filename without extension, so try different types
    Else
        C = A 'full filename, so just use it
    End If
  
    If Exists(C) = True Then
        If IsPic(C) Then
            iCover.Picture = LoadPicture(C)
            If iCover.Visible = False Then
                frmAlbum.Cover = LoadPicture(C)
                frmAlbum.Visible = True
            End If
            LastCover = C
        End If
    Else
        GoSub ClearCover
    End If
LCErr:
    Exit Sub
    
ClearCover:
    iCover.Picture = Nothing
    frmAlbum.Cover = Nothing
    frmAlbum.Visible = False
    LastCover = ""
    Return
    
End Sub

'Display Preferences window显示参数选择窗体
Sub ShowPrefs()
    If Pref.Visible = False Then
      Call AlwaysOnTop(Me, False)
      Pref.Show 1
    End If
End Sub
    
'Run standard windows sound-mixer program显示系统音量控制窗体
Sub ShowMixer()
    Shell "sndvol32.exe", vbNormalFocus
End Sub

'Show Visual Playlist selector显示可视的列表选择器
Sub ShowVisSelect()
    Call AlwaysOnTop(Me, False)
    Load frmVisLoader
End Sub

'Display Select Cover dialog
Sub SelectCover()
Dim F As String
    On Error GoTo ErrHandler1
    
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "Select Cover"
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.InitDir = ""
    CommonDialog1.Filter = "Bitmap|*.gif;*.bmp;*.jpg"
    CommonDialog1.FilterIndex = 1
    CommonDialog1.ShowOpen
    
    F = CommonDialog1.Filename
    Call LoadCover(F)
ErrHandler1:

End Sub

'Display Load skin dialog box显示选择皮肤对话框
Sub SelectSkin()
Dim F As String, Path As String
    On Error GoTo ErrHandler1
    
    Path = OptSkinPath: If Path = "" Then Path = App.Path
    
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "Select Skin"
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.InitDir = Path
    CommonDialog1.Filter = "Skin control file (*.skin)|*.skin"
    CommonDialog1.FilterIndex = 1
    
    CommonDialog1.ShowOpen
    
    F = CommonDialog1.Filename
    Call LoadSkin(ByVal F, False)
ErrHandler1:

End Sub

'Load the skin file. The UseLast flag bypasses the import file selector and
'uses the last imported file (for use when form initially loads)
'加载皮肤
Private Sub LoadSkin(ByVal F As String, UseLast As Boolean)

Dim NumPoints As Integer, NumPoly As Integer, Dum As Integer, FIO As Integer, X As Long, Y As Long, C As Integer, Fg As Long, Bg As Long, Pt As Long, FT As Long
Dim K As Single, Multi As Boolean, SkinErr As Boolean, Path As String, J As Integer, FileSpec As String, SkE As String, X2 As Long, Y2 As Long, G As Long, S As Long
Dim TmpSize(2) As Coord, SkinInf As String, Condition As Integer, Label As String, Skip As String, n As Integer, Fb As Long, Bb As Long, Bv As Long, WW As Long
Dim p As String, PP As String, A As String, FF As String, B1 As String, B2 As String, Z As String, Fr As Long, Br As Long, CV As Long, TT As String, Sh As Long
Dim W As Long, H As Long, W2 As Long, H2 As Long, ScnPos As Long, ZZ As String, LinkText As String, Att As String

Static LastPath As String
    
    On Error Resume Next 'GoTo IsErr
    
    Multi = False: SkinErr = False
    Skip = ""
    
    'Make sure skin path is set
    p = ValidateDir(OptSkinPath)
    If p = "" Then
        If LastPath <> "" Then p = LastPath Else p = App.Path
    End If
    
    'Check for Resolution-dependent skin (IE: name* -> name1024.skin)
    If Right(F, 1) = "*" Then
        A = Mid(Str(Screen.Width / Screen.TwipsPerPixelX), 2)
        F = Left(F, Len(F) - 1) + A + ".skin"
    End If
    
    'Look for skin file in skin directory then app directory else error
    If InStr(F, ":") = 0 Then PP = p + F Else PP = F
    If Exists(PP) = False Then
        PP = ValidateDir(App.Path) + GetFileName(F)
        If Exists(PP) = False Then
            MsgBox "Skin not found!" + Chr(13) & "SkinName=" + F + Chr(13) + "SkinPath=" + OptSkinPath
            Exit Sub