frmvbamp.frm

一个无需MP3控件的MP3播放器源码

        If SnoozeTm < 1 Then GoSub DoAutoOff: OptSnooze = 0
    Else
        Lbl(5).Caption = OptSnoozeAt
        If Left$(Time$, 5) = OptSnoozeAt Then GoSub DoAutoOff
    End If
    Return
    
CheckOO:
    J = AutoList.ListCount - 1: T2$ = Left$(Time$, 5)
    For I = 0 To J
        A$ = AutoList.List(I): D$ = Left$(A$, 1)
        Select Case D$
            Case "E": GoSub CheckTime
            Case "D": If InStr("MTWRF", DowS$) > 0 Then GoSub CheckTime
            Case "N": If InStr("US", DowS$) > 0 Then GoSub CheckTime
            Case Else: If D$ = DowS$ Then GoSub CheckTime
        End Select
    Next I
    Return
    
CheckTime:
    p = Val(Mid$(A$, 15, 2))
    If T2$ = Mid$(A$, 3, 5) Then GoSub DoAutoOn
    If T2$ = Mid$(A$, 9, 5) Then GoSub DoAutoOff
    Return

DoAutoOn:
    
    Return
    
DoAutoOff:
    If OptMinOnSnz = 1 Then Me.Visible = False
    Return
    
End Sub

'Digital display routine. Copy bitmaps from resource image.
Sub SetDD(ByVal F, ByVal vn As Variant)
    'f=Format index, vn=number
    'zflag determines if initial zero's are shown (0=no, 1=yes, -1=first only no)
    
    If Dig(F).Visible = False Then Exit Sub
    
    X = 0: ZFlag = 0
    N2 = Di(F).F
    
    Select Case N2
        Case 0 'time
            Min = vn \ 60: Sec = vn - Min * 60
            Z$ = Format$(Min, "00") + ":" + Format$(Sec, "00")
            ZFlag = -1
        Case 1 To 6 'number of digits
            Z$ = Format$(vn, Left$("000000", N2))
        Case 7 'frequency
            Z$ = Format$(vn, "000.0")
        Case 8 'time
            FJ$ = "hh:mm    ": ZFlag = 1
            If OptTimeFmt = 0 Then FJ$ = "hh:mm AMPM": ZFlag = 0
            ZZ$ = Format$(Time, FJ$)
            AM$ = Mid$(ZZ$, 7, 2): Z$ = Left$(ZZ$, 5)
            Lbl(9).Caption = AM$
        Case 9 'full time
            Z$ = Format$(vn, "hh:mm:ss")
    End Select
          
    X2 = Di(F).X: Y2 = Di(F).Y
    W = Di(F).W: H = Di(F).H: W2 = Di(F).W2
        
    For J = 1 To Len(Z$)
        XQ$ = Mid$(Z$, J, 1): W3 = W
        If XQ$ = "0" And ZFlag < 1 Then XQ$ = " "
        Select Case XQ$
            Case "0" To "9": p = Val(XQ$): ZFlag = 1
            Case ".": p = 11: W3 = W2
            Case ":": p = 12: W3 = W2
            Case Else: p = 10
        End Select
        If ZFlag = -1 Then ZFlag = 1
        '**** Blit Digit to destination
        Dig(F).PaintPicture ResBmp.Picture, X, 0, W3, H, X2 + p * W, Y2, W3, H
        X = X + W3
    Next J
    
End Sub

'Read the Auto On/Off list
Private Sub LoadAutoList()

    F$ = App.Path + "\autolist.txt"
    If Exists(F$) = False Then Exit Sub
    
    FIO4 = FreeFile
    Open F$ For Input As FIO4
    While Not EOF(FIO4)
        Line Input #FIO4, A$
        If RTrim$(A$) <> "" Then AutoList.AddItem A$
    Wend
    Close FIO4
End Sub

'Save the Auto On/Off entries to file
Private Sub SaveAutoList()
    F$ = App.Path + "\autolist.txt"
    
    FIO5 = FreeFile
    Open F$ For Output As FIO5
    For I = 0 To AutoList.ListCount - 1
        Print #FIO5, AutoList.List(I)
    Next
    Close FIO5
End Sub

'Get MP3 Info and ID Tag from file
Sub GetMP3Info()
    Dim InBuf As String * 256
    Dim D1 As Byte
    
    If SongPath <> "" Then If Exists(SongPath) = True Then GoSub GetID
    Exit Sub
        
GetID:
    Close
    
    FIO% = FreeFile
    Open SongPath For Binary As FIO%
    n& = LOF(1): If n& < 256 Then Close FIO%: Return
    
    'Read first MP3 frame header and set info text labels
    Get #1, 3, D1
    A$ = LTable$(D1, 4, 7, 4, "144 16  32  48  56  64  80  96  112 128 160 192 224 256 320 ")
    Lbl(10).Caption = A$: Call SetDD(4, Val(A$))
    
    A$ = LTable$(D1, 2, 3, 3, "44 48 32 ?? ")
    Lbl(11).Caption = A$: Call SetDD(5, Val(A$))
    
    Get #1, 4, D1
    Lbl(12).Caption = LTable$(D1, 6, 7, 8, "stereo  jstereo dualch  mono    ")
    
    'Now look for ID tag
    Get #1, (n& - 256), InBuf:  Close FIO%
    A$ = "": Cr$ = Chr$(13)
    p = InStr(1, InBuf, "tag", 1)
    If p = 0 Then
        A$ = "No ID Tag in file!"
    Else
        A$ = A$ & Cr$ & "Title: " & Mid$(InBuf, p + 3, 30)
        A$ = A$ & Cr$ & "Artist: " & Mid$(InBuf, p + 33, 30)
        A$ = A$ & Cr$ & "Album: " & Mid$(InBuf, p + 63, 30)
        A$ = A$ & Cr$ & "Year: " & Mid$(InBuf, p + 93, 4)
        A$ = A$ & Cr$ & "Comment: " & Mid$(InBuf, p + 97, 30)
    End If
    Info = A$: A$ = ""
    Return
End Sub

'Display Track Info window
Private Sub ShowInfo()
    MsgBox Info, vbInformation, "Track Info"
End Sub

'Clear Track info
Sub ClearInf()
    Lbl(1).Caption = ":": Lbl(4).Caption = ""
    Lbl(10).Caption = "": Lbl(11).Caption = ""
    Lbl(12).Caption = "": Lbl(13).Caption = ""
    sBlip.Visible = False: iSlider(1).Visible = False
End Sub

'Display Playlist Load dialog box then load playlist
Sub PlLoad()
    On Error GoTo ErrHandler2
    
    CommonDialog1.CancelError = True
    CommonDialog1.InitDir = OptDefPath
    CommonDialog1.DialogTitle = "Load Playlist"
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.Filter = "MP3 Playlists (*.M3U)|*.M3U|Playlists (*.PLS)|*.PLS"
    CommonDialog1.FilterIndex = 1
    CommonDialog1.Filename = ""
    
    CommonDialog1.ShowOpen
 
    F$ = CommonDialog1.Filename
    
    OptDefPath = GetPath$(F$)
    SaveSetting Prg, Sect, "Path", OptDefPath
    
    If OptClrPl = 1 Then Call PlClear
    
    PlRead (F$)
    If OptAutoPlay = 1 Then TNum = 1: Call PlayIt
    
ErrHandler2:
    Exit Sub
End Sub
Public Sub PlRead(F$)
    
    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$)
    
    Call LoadCover(FF$)
        
    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$ = LTrim$(AA$)
        If n < 32766 Then GoSub AddIt
    Wend
    Return
  
LoadPLS:
    While Not EOF(FIO%)
        Line Input #FIO%, AA$: AA$ = LTrim$(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:
    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$
    n = n + 1
    Return

End Sub

'Display the Save Playlist Dialog box then save playlist
Private Sub PlSave()
    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:
    Exit Sub
End Sub

'Write the playlist to a file
Sub WritePL(F$)
    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

'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
        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
        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)
    Select Case Index
        Case 1 'change playback position
            p! = Int(NewP * SongLen): Call PlayFrom(p!)
        Case 2 'volume:no change since it's changed as slider moves
    End Select
    SlideFlag = 0
End Sub

'Set specified slider to position (percentage 0.00 to 1.00)
Private Sub SetSlider(SliNum, PctPos As Single)
    If iSlider(SliNum).Visible = False Then Exit Sub
    Select Case SliNum
        Case 1 To 3: 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

Private Sub DoSlider(SliNum, PctPos As Single)
        Select Case SliNum
            Case 1 'playback position only changes when released
            Case 2
                Call SetVol(PctPos) 'Volume changes as slider moves
                Lbl(18).Caption = Int(PctPos * 100) & "%"
                Call SetSlider(4, PctPos)
            Case 3 'balance
            Case 4 'volume indicator
                    
        End Select
End Sub
'Display Folder Browse dialog then add files from selected path to playlist
Sub AddFromDir()
    A$ = GetBrowseDir(Me, "Select Directory containing Media Files:")
    If A$ <> "" Then Call AddDir(A$, Me, PlNames, PlPath, Pref.ValExt.Text)
End Sub

'Load a bitmap album cover file