frmvbamp.frm

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

Sub LoadCover(A$)
    Static LastCover$
    
    If A$ = LastCover$ Then Exit Sub 'don't reload cover!
    C$ = ""
    If InStr(A$, ".") = 0 Then
        'filename without extension, so try different types
        Ext$ = ".BMP": GoSub TestIt
        Ext$ = ".GIF": GoSub TestIt
        Ext$ = ".JPG": GoSub TestIt
    Else
        C$ = A$ 'full filename, so just use it
    End If
  
    If Exists(C$) = True Then
        iCover.Picture = LoadPicture(C$)
        If iCover.Visible = False Then
            frmAlbum.Cover = LoadPicture(C$)
            frmAlbum.Visible = True
        End If
        LastCover = C$
    Else
        iCover.Picture = Nothing
        frmAlbum.Cover = Nothing
        frmAlbum.Visible = False
        LastCover = ""
    End If
    Exit Sub
  
TestIt:
    If Exists(A$ + Ext$) = True Then C$ = A$ + Ext$
    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()

    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()

    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$)
ErrHandler1:

End Sub

'Load the skin file
Private Sub LoadSkin(ByVal F$)
    Dim NumPoints As Integer, NumPoly As Integer, Dum As Integer
    Dim K As Single, Multi As Boolean, SkinErr As Boolean
    
    Static LastPath$
    
    Multi = False: SkinErr = False
    
    SetWindowRgn Me.hWnd, 0, True 'clear previous region
            
    p$ = ValidateDir$(OptSkinPath)
    If p$ = "" Then
        If LastPath$ <> "" Then p$ = LastPath$ Else p$ = App.Path
    End If
    
    If InStr(F$, ":") = 0 Then
        PP$ = p$ & F$
    Else
        PP$ = F$
    End If
    
    
    If Exists(PP$) = False Then
        'Check in same directory as application
        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
        End If
    End If
    
    OptSkinName = PP$
    Path$ = GetPath$(PP$): LastPath$ = Path$
           
    FIO = FreeFile
    Open PP$ For Input As FIO
    Input #FIO, A$: If A$ <> "VB-Amp Skin" Then Close FIO: MsgBox "Invallid Skin!": Exit Sub
        
    Line Input #FIO, A$: SkinInfo = A$
    
    'Hide all the elements (move indicators off screen)
    For J = 1 To 50: Btn(J).Visible = False: Next
    For J = 1 To 20: Lbl(J).Visible = False: Next
    For J = 1 To 1:  Btn(J).Visible = False: Next
    For J = 1 To 1:  Img(J).Visible = False: Next
    For J = 1 To 16: Ind(J).Visible = False: Ind(J).Move -10, -10, 5, 5: Next
    For J = 1 To 5:  Dig(J).Visible = False: Next
    For J = 1 To 4:  iSlider(J).Visible = False: Sli(J).W = 0: Sli(J).H = 0: Next
    
    PlNames.Visible = False
    iCover.Visible = False
        
    NumPoints = 0: C = 0
    
    'Read the form size values
    For J = 0 To 2
        Input #FIO, X, Y
        FSize(J).X = X * TwipX: FSize(J).Y = Y * TwipY
    Next
    Me.Width = FSize(0).X
    Me.Height = FSize(0).Y
    
    'Read the skin options
    Input #FIO, B1$, B2$
    Input #FIO, CoolFlag, ScnPos, Dum, Dum, Dum, Dum, Dum, Dum
        
    'Set the window position
    W = Screen.Width: H = Screen.Height
    W2 = Me.Width: H2 = Me.Height
        
    Select Case ScnPos '0=no change
        Case 1: Me.Move 0, 0 'top left
        Case 2: Me.Move W - W2, 0 'top right
        Case 3: Me.Move W - W2, H - H2 'bottom right
        Case 4: Me.Move 0, H - H2 'bottom left
        Case 5: Me.Move (W - W2) / 2, (H - H2) / 2 'centred
    End Select
    
    'Make sure form is entirely on screen (if possible)
    X = Me.Left: If X + W2 > W Then X = W - W2: If X < 0 Then X = 0
    Y = Me.Top: If Y + H2 > H Then Y = H - H2: If Y < 0 Then Y = 0
    Me.Move X, Y
    
    
    'Load the background and down-button pictures
    F$ = Path$ + B1$: If Exists(F$) = True Then Me.Picture = LoadPicture(F$) Else MsgBox "Main bitmap not found: " & F$
    F$ = Path$ + B2$
    If F$ <> "" Then
        If Exists(F$) = True Then ResBmp.Picture = LoadPicture(F$) Else MsgBox "Resource bitmap not found: " & F$
    End If
        
    'Read the rest of the skin file
    Do While Not EOF(FIO)
        Input #FIO, Z$
        ZZ$ = Left$(Z$, 1): n = Val(Mid$(Z$, 2))
        
        Select Case ZZ$
            Case "B": GoSub SetBtn
            Case "L": GoSub SetLbl
            Case "I": GoSub SetInd
            Case "S": GoSub SetSlider
            Case "D": GoSub SetDig
            Case "C": GoSub SetPic
            Case "X": GoSub SetExtra
            Case "N": NumPoints = n: ReDim PolyPt(NumPoints + 1) As Coord
            Case "M": GoSub MultiRegion
            Case "P"
                If C < NumPoints Then
                    Input #FIO, Y
                    PolyPt(C).X = n: PolyPt(C).Y = Y: C = C + 1
                End If
            Case ";": GoSub Comment
            Case "/": GoSub SkinComment
            Case "E": Exit Do
        End Select
    Loop
    Close FIO
        
    'This makes sure there are the right number of points for the
    'region(s) then calls the API to create it.
    If (NumPoints > 0) And (C = NumPoints) Then
        If Multi = False Then
            PolyPt(C).X = PolyPt(0).X
            PolyPt(C).Y = PolyPt(0).Y
            SetWindowRgn Me.hWnd, CreatePolygonRgn(PolyPt(0), NumPoints, 0), True
        Else
            SetWindowRgn Me.hWnd, CreatePolyPolygonRgn(PolyPt(0), PolyNum(0), NumPoly, 1), True
        End If
    End If
    
    Small = 0: HFlag = 0 'reset the form to normal size
    Call Form_Paint 're-draw the digital displays
    Call ShowLights 're-draw the status indicators
    DoEvents
    If SkinErr = True Then
        MsgBox "Error in skin file!" & Chr$(13) & "The skin file contains references to the following elements that do not exist!:" & Chr$(13) & SkE$
    End If
    Exit Sub

MultiRegion:
    NumPoints = n
    ReDim PolyPt(NumPoints + 1) As Coord 'set aside total points
    Input #FIO, NumPoly
    ReDim PolyNum(NumPoly) As Long 'set size of array containing number of points in each region
    
    For J = 0 To NumPoly - 1: Input #FIO, PolyNum(J): Next 'read sizes of each region
    Multi = True
    Return
    
SetBtn:
    Input #FIO, X, Y, W, H, X2, Y2, Z$, TT$
    If n = 0 Then Return
    If n = 49 Then Input #FIO, SkinLink1
    If n = 50 Then Input #FIO, SkinLink2
    If n > 50 Then SkinErr = True: Return
    
    If W < 1 Or H < 1 Then Return
    Btn(n).Move X, Y, W, H
    Btn(n).ToolTipText = TT$
    Btn(n).Tag = Str$(X2) + "," + Str$(Y2)
    Btn(n).Visible = True
    Kbd(n) = Z$
    If X2 + Y2 = 0 Then
        cx(n) = X: cy(n) = Y
    Else
        cx(n) = X2: cy(n) = Y2
    End If
    Return

MkColor:
    CV& = (Fb * 65536) + (Fg * 256&) + (Fr)
    BV& = (Bb * 65536) + (Bg * 256&) + (Br)
    Return

SetLbl:
    Input #FIO, X, Y, W, H, Fr, Fg, Fb, Pt, F$, TT$
    If n = 0 Then Return
    If W < 1 Or H < 1 Then Return
    If n > 20 Then GoSub SkinErr: Return
    
    GoSub MkColor
    Lbl(n).Move X, Y, W, H
    Lbl(n).ToolTipText = SetTip$(TT$)
    Lbl(n).ForeColor = CV&
    Lbl(n).FontName = F$
    Lbl(n).FontSize = Pt
    Lbl(n).FontBold = False
    Lbl(n).Visible = True
    Return
    
SetDig:
    Input #FIO, X, Y, X2, Y2, W, H, W2, S, F, TT$
    If n = 0 Then Return
    If n > 5 Then GoSub SkinErr: Return
    
    Select Case F
      Case 0: WW = W * 4 + W2
      Case Else: WW = W * F
    End Select
    If n = 3 Then WW = W * 4 + W2
    
    'Save additional parameters
    Di(n).X = X2: Di(n).Y = Y2
    Di(n).W = W: Di(n).H = H
    Di(n).W2 = W2
    Di(n).S = S: Di(n).F = F
    
    'Set the elements
    Dig(n).Move X, Y, WW, H
    Dig(n).ToolTipText = TT$
    Dig(n).Visible = True
    Return
    
SetSlider:
    Input #FIO, X, Y, W, H, X2, Y2, W2, H2, TT$
    If n = 0 Then Return
    If n > 4 Then GoSub SkinErr: Return
    
    With Sli(n)
        .X = X
        .Y = Y
        .W = W
        .H = H
        .X2 = X2
        .Y2 = Y2
        .W2 = W2
        .H2 = H2
        .F = 0 ' used as flag for last position
    End With
    
    iSlider(n).ToolTipText = SetTip$(TT$)
    iSlider(n).Width = W2
    iSlider(n).Height = H2
    iSlider(n).Move X, Y, W2, H2
    iSlider(n).Visible = True: DoEvents
    iSlider(n).PaintPicture ResBmp.Picture, 0, 0, W2, H2, X2, Y2, W2, H2
    Return

SetInd:
    Input #FIO, X, Y, W, H, Fr, Fg, Fb, Sh, TT$
    If n = 0 Then Return
    If W < 1 Or H < 1 Then Return
    If n > 16 Then GoSub SkinErr: Return
    GoSub MkColor
    Ind(n).Move X, Y, W, H
    Ind(n).FillColor = CV&
    Ind(n).Shape = Sh
    'Ind(n).Visible = True  'don't display yet (let ShowLights routine do it)
    Return
    
SetExtra:
    Input #FIO, X, Y, W, H, Fr, Fg, Fb, Br, Bg, Bb, Pt, F$, TT$
    If n = 0 Then Return
    If n > 1 Then GoSub SkinErr: Return
    If W < 1 Or H < 1 Then Return
    GoSub MkColor
    PlNames.Move X, Y, W, H
    PlNames.ToolTipText = SetTip$(TT$)
    PlNames.ForeColor = CV&
    PlNames.BackColor = BV&
    PlNames.FontName = F$
    PlNames.FontBold = False
    PlNames.FontSize = Pt
    PlNames.Visible = True
    Return

SetPic:
    Input #FIO, X, Y, W, H, TT$
    If n = 0 Or n > 1 Then Return
    If W < 1 Or H < 1 Then Return
    iCover.Move X, Y, W, H
    iCover.ToolTipText = SetTip$(TT$)
    iCover.Visible = True
    Return

Comment:
    Line Input #FIO, TT$
    Return
    
SkinComment:
    Line Input #FIO, TT$
    SkinInfo = SkinInfo & Chr$(13) & TT$
    Return

SkinErr:
    SkE$ = SkE$ & " " & Z$: SkinErr = True: Return
    
End Sub

'Set status lights
Sub ShowLights()
    
    Ind(1).Visible = Stereo
    Ind(2).Visible = Not Playing
    Ind(3).Visible = Paused
    Ind(4).Visible = Playing
    Ind(5).Visible = Intro:     Ind(11).Visible = Not Intro
    Ind(6).Visible = STP:       Ind(12).Visible = Not STP
    Ind(7).Visible = Repeat:    Ind(13).Visible = Not Repeat
    Ind(8).Visible = (RptB > 0): Ind(14).Visible = (RptB = 0)
    Ind(9).Visible = Random:    Ind(15).Visible = Not Random
    Ind(10).Visible = Shuffle:  Ind(16).Visible = Not Shuffle
    
End Sub

'Set Date/Day variables
Public Sub MakeDayStr()
    DOW = WeekDay(Now): DD = Day(Now): MM = Month(Now): YY = Year(Now)
    TD$ = Format$(YY, "00") + Format$(MM, "00") + Format$(DD, "00")
    DWS$ = RTrim$(Mid$("Sunday   Monday   Tuesday  WednesdayThursday Friday   Saturday ", DOW * 9 - 8, 9))
    MMS$ = Mid$("January  February March    April    May      June     July     August   SeptemberOctober  November December ", MM * 9 - 8, 9)
    Today$ = DWS$ + " " + RTrim$(MMS$) + " " + Str$(DD) + "," + Str$(YY)
    Lbl(6).Caption = Today$
    Lbl(7).Caption = Left$(DWS$, 3)
    DowS$ = Mid$("UMTWRFS", DOW, 1)
End Sub

'Set ToolTip to string unless first character is "~"
Private Function SetTip$(Tip$)
    SetTip$ = ""
    If Left$(Tip$, 1) <> "~" Then SetTip$ = Tip$
End Function