frmvbamp.frm

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

    'only update if user not adjusting position!
    If SlideFlag <> 1 And iSlider(1).Visible = True Then
        PStr = Int((Elapsed / SongLen) * 10000)
        Call SetSlider(1, Val(PStr) / 10000)
    End If
       
    If Intro = True Then
        'Check if 10 seconds elapsed
        If Elapsed > 10 Then GoSub GoNext
    End If
    
    If RptB > 0 Then
        'Check if past B position
        If Elapsed >= RptB Then Call PlayFrom(RptA)
    End If
'Check if song is finished or past overlap
    If Elapsed >= SongLen Then GoSub GoNext
    Exit Sub

' If Repeat=True, Play same track
' If STP=True, Go to next track but don't play
GoNext:
    If OptPBOverlap > 0 Then PlayUnit = 1 - PlayUnit 'switch playback control
    If Repeat = False Then
        If Shuffle = True Then
            TNum = Rnd(Timer) * PlNames.ListCount + 1
        Else
            TNum = TNum + 1
        End If
    End If
    Call PlayIt
    If STP = True Then Call StopIt
    Return
    
End Sub

'Timer 2 used for Auto On/Off events and Realtime Clock display/date
'and volume level checking
Private Sub Timer2_Timer()
Dim volume As Long, Pct As Single, FJ As String, J As Integer
Dim T2 As String, i As Integer, D As String, p As String, A As String
    If OptScrollName = 1 Then Call SetDD(6, SongName)
    
    'Check Auto On/Off and Snooze
    If Right(Time, 2) = "00" Then
        GoSub CheckZero
    Else
        If OptAuto = 1 Then
            If OptSnooze = 1 Then
                If SnoozeTm < 0 Then GoSub SetSnoozeLbl
            Else
                Lbl(5).Caption = ""
            End If
        Else
            Lbl(5).Caption = ""
        End If
    End If
    
    'Check Volume
    Pct = GetVol()
    If Pct <> Sli(2).V Then Call SetSlider(2, Pct) 'move slider
   
Exit Sub

CheckZero:
    FJ = "hh:mm   "
    If OptTimeFmt = 0 Then FJ = "hh:mm AMPM"
            
    Lbl(3).Caption = Format(Time, FJ)
    Call SetDD(3, 0)
    If Time = "00:00:00" Then Call MakeDayStr
    If OptAuto = 1 Then
        If OptSnooze = 1 Then GoSub CheckSnooze
        GoSub CheckOO
    End If
    Return
    
SetSnoozeLbl:
    SnoozeTm = Abs(SnoozeTm)
    If OptSnooze = 1 Then
        If OptSnoozeMd = 0 Then
            Lbl(5).Caption = Format(SnoozeTm, "00")
        Else
            Lbl(5).Caption = OptSnoozeAt
        End If
    End If
    Return

CheckSnooze:
    If OptSnoozeMd = 0 Then
        SnoozeTm = SnoozeTm - 1
        Lbl(5).Caption = Format(SnoozeTm, "00")
        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 As Integer, 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)zflag 决定是否被显示 (0= 没有,1= 是的,-1= 第一唯一的没有)
    
Dim ZFlag As Integer, N2 As Long, Z As String, FJ As String
Dim Min As Integer, Sec As Integer, ZZ As String, AM As String
Dim X2 As Long, X As Long, Y2 As Long, W As Long, H As Long
Dim W2 As Long, Y As Long, Flag As Integer, J As Long, XQ As String
Dim Max As Long, W3 As Long, p As Integer, Row As Integer
Dim Col As Long, Weird As String, PP As String
    
    If Dig(F).Visible = False Then Exit Sub
    
    ZFlag = 0: N2 = Di(F).F
    
    Select Case N2
        Case -15 To -1 'number of digits
        'FORMAT可以调整格式
            Z$ = Format$(vn, Left$("000000000000000", -N2))
        Case 0 'elapsed time共用...时(间)
            Min = vn \ 60: Sec = vn - Min * 60
            Z$ = Format$(Min, "00") + ":" + Format$(Sec, "00")
            ZFlag = -1
        Case 1 'real 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 2
            FJ$ = "hh:mm:ss "
            ZFlag = 1
            If OptTimeFmt = 0 Then FJ$ = "hh:mm:ss AMPM": ZFlag = 0
            ZZ$ = Format$(Time, FJ$)
            AM$ = Mid$(ZZ$, 7, 2): Z$ = Left$(ZZ$, 5)
            Lbl(9).Caption = AM$
        Case 3 'frequency频率
            Z$ = Format$(vn, "000.0")
        Case 4
            Z$ = Format$(vn, "000.000")
        Case Else
            Z$ = vn
    End Select
            
    If OptScrollName = 1 And F = 6 Then
        If Len(Z) > N2 Then
            If ScrollStart > Len(Z) + 4 Then ScrollStart = 1
            Z = Mid(Z + "  *  " + Z, ScrollStart)
            ScrollStart = ScrollStart + 1
        Else
            ScrollStart = 1
        End If
    End If
    
    X2 = Di(F).X: Y2 = Di(F).Y
    W = Di(F).W: H = Di(F).H: W2 = Di(F).W2
    X = Dig(F).Left: Y = Dig(F).Top
    
    'now display based on graphics format
    Select Case Di(F).G
        Case 0: GoSub Numeric
        Case 1: Flag = 0: GoSub Alpha
        Case 2: Flag = 1: GoSub Alpha
        Case 3: Flag = 1: GoSub WinAmp
    End Select
    Exit Sub
    
Numeric:
    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
        Me.PaintPicture ResBmp.Picture, X, Y, W3, H, X2 + p * W, Y2, W3, H  'Blit Digit to destination到目的地的 Blit 数字
        X = X + W3 + Di(F).S
    Next J
    Return

Alpha:
    If Flag = 1 Then Z = UCase(Z) 'uppercase only
    Max = Len(Z)
    For J = 1 To Abs(N2)
        If J <= Max Then p = Asc(Mid(Z, J, 1)) Else p = 32
        If p < 32 Or p > 127 Then p = 32
        Row = (p \ 16) - 2: Col = p Mod 16
        Me.PaintPicture ResBmp.Picture, X, Y, W, H, X2 + Col * W, Y2 + Row * H, W, H
        X = X + W + Di(F).S
    Next J
    Return

WinAmp:
    Max = Len(Z): Z = UCase(Z) 'uppercase only
    Weird = ":()-'!_+\/[]^&.=#" 'who ordered the character set anyway?
    For J = 1 To Abs(N2)
        If J <= Max Then p = Asc(Mid(Z, J, 1)) Else p = 32
        Select Case p
            Case 32: Row = 0: Col = 29
            Case 34: Row = 0: Col = 27
            Case 42: Row = 2: Col = 4
            Case 48 To 57: Row = 1: Col = p - 48
            Case 63: Row = 2: Col = 3
            Case 64: Row = 0: Col = 8
            Case 65 To 90: Row = 0: Col = p - 65
            Case Else
                PP = InStr(Weird, Chr(p))
                If PP < 1 Then Row = 0: Col = 29 Else Row = 1: Col = PP + 11
        End Select
        Me.PaintPicture ResBmp.Picture, X, Y, W, H, X2 + Col * W, Y2 + Row * H, W, H
        X = X + W + Di(F).S
    Next J
    Return

End Sub

'Read the Auto On/Off list加载自动列表
Private Sub LoadAutoList()
Dim F As String, FIO4 As Integer, A As String
    F = App.Path + "\autolist.txt"
    If Exists(F) = False Then Exit Sub
    '使用 FreeFile 提供一个尚未使用的文件号
    FIO4 = FreeFile
    Open F For Input As FIO4
    While Not EOF(FIO4)
        Line Input #FIO4, A
        If Trim(A) <> "" Then AutoList.AddItem A
    Wend
    Close FIO4
End Sub

'Save the Auto On/Off entries to file保存自动列表
Private Sub SaveAutoList()
Dim F As String, FIO5 As Integer, i As Integer
    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, A As String, n As Long, FIO As Integer
    Dim D1 As Byte, p As Long
    
    With InfoTag
        .Title = ""
        .Artist = ""
        .Album = ""
        .Year = ""
        .Comment = ""
        .Track = ""
        .Genre = Chr(80)
    End With
        
    If SongPath <> "" Then If Exists(SongPath) = True Then GoSub GetID
    Exit Sub
        
GetID:
    Close
    
    FIO = FreeFile
    Open SongPath For Binary As FIO
    n = LOF(FIO): If n < 256 Then Close FIO: Return
    
    'Read first MP3 frame header and set info text labels
    Get #FIO, 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 #FIO, 4, D1
    Lbl(12).Caption = LTable(D1, 6, 7, 8, "stereo  jstereo dualch  mono    ")
    
    'Now look for ID tag
    Get #FIO, (n - 255), Inbuf:  Close FIO
    p = InStr(1, Inbuf, "tag", 1)
    If p > 0 Then
        With InfoTag
            .Title = Mid(Inbuf, p + 3, 30)
            .Artist = Mid(Inbuf, p + 33, 30)
            .Album = Mid(Inbuf, p + 63, 30)
            .Year = Mid(Inbuf, p + 93, 4)
            .Comment = Mid(Inbuf, p + 97, 29)
            .Track = Mid(Inbuf, p + 126, 1)
            .Genre = Mid(Inbuf, p + 127, 1)
        End With
    End If
    Return
    
End Sub

' Try to load Album Cover using IDTag fields
' Try Album and Artist-Album, if not found use playlist cover or "nocover"
Sub LoadTagCover(ByVal Path As String, ByVal Artist As String, ByVal Album As String)
Dim PP As String, X1 As String, X2 As String, F As String
Dim XX As String
    PP = ValidateDir(Path): XX = ""
    X1 = Trim(Artist)
    X2 = Trim(Album)
        
    If X2 <> "" Then F = FindCover(PP + X2): If F <> "" Then XX = F
    
    If X1 <> "" Then
        F = FindCover(PP + X1 + "-" + X2): If F <> "" Then XX = F
        F = FindCover(PP + X1 + " - " + X2): If F <> "" Then XX = F
    End If
    
    If XX <> "" Then
        LoadCover (XX) 'use cover from tag
    Else
        If PLCover = "" Then
            LoadCover (App.Path + "\nocover.bmp") 'use generic cover
        Else
            LoadCover (PLCover) 'use playlist cover
        End If
    End If
    
End Sub

'Display Track Info window
Private Sub ShowInfo()
    frmInfo.Visible = True
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 = ""
    iSlider(1).Visible = False
End Sub

'Display Playlist Load dialog box then load playlist加载列表
Sub PlLoad()
Dim F As String
    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
    DoEvents
 
    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 As String)
Dim FF As String, Path As String
Dim n As Integer, FIO As Integer, A As String, AA As String
Dim X As String, XX As String, B As String, Filename As String
Dim FilePath As String, i As Integer