playmp3.frm

一个mp3播放器的源码

        bOpenFileFlag = False
    Else
        ErrorLabel.Caption = Error
    End If
        
    Resume Next
   
End Sub

Private Sub Picture1_DragDrop(Source As Control, X As Single, Y As Single)
    Dim nLen As Single
    
    If bOpenFileFlag = True And nRepeatTime = 0 Then
        If X + 30 >= Picture1.Width Then '已到文件尾
            X = Picture1.Width - 30
        Else
            If X - 30 <= 0 Then '已到文件首
                X = 30
            End If
        End If
    
        Label6.Move X, 750
        Line5.X2 = X + 15
    End If
    
    If nRepeatTime = 0 Then
        nLen = Format(X / Picture1.Width, "###0.00")
        nFrameCount = nLen * Mp3Play.FrameCount
        nRepeatTime = 8888
        If bPlayFileFlag = False Then
            Image1_Click (2)
        End If
        Mp3Play.Seek nFrameCount
        Timer4.Enabled = True
    End If
End Sub

Private Sub Picture2_Click()
        bShowTimeFlag = Not bShowTimeFlag
        If bShowTimeFlag = True Then
            Picture2.ForeColor = 16711680
        Else
            Picture2.ForeColor = 0
        End If
End Sub

Private Sub PopMenu_Click(Index As Integer)
    Select Case Index
        Case 1
            bMinimizeFlag = False
            Shell_NotifyIcon NIM_DELETE, nid
            'Me.Show
            Bubble2 PlayMp3
        Case 3
            Image1_Click (10)
        Case 5
            Image1_Click (0)
        Case 6
            Image1_Click (2)
        Case 7
            Image1_Click (1)
        Case 9
            Image1_Click (3)
        Case 10
            Image1_Click (4)
        Case 12
            Image1_Click (5)
        Case 13
            Image1_Click (6)
        Case 15
            Image1_Click (11)
        Case 17
            Shell_NotifyIcon NIM_DELETE, nid
            End
    End Select
End Sub

Private Sub Timer1_Timer()
    Line_Move 0, False
    Timer1.Enabled = False
End Sub

Private Sub Timer2_Timer()  '控制按钮按下时的时间
    Line_Click False
    Timer2.Enabled = False
End Sub

Private Sub Timer3_Timer()
    Dim nVolume As Integer
        
    Dim bLabelFlag As Boolean
    
    If Len(Trim(Label5.Caption)) <= 0 Then
        bLabelFlag = True
    Else
        If Label5.Left >= ErrorLabel.Left And Len(Trim(ErrorLabel.Caption)) > 0 Then
            bLabelFlag = True
        Else
            bLabelFlag = False
        End If
    End If
    
    If bLabelFlag = True Then
        If Len(Trim(ErrorLabel.Caption)) <= 0 Then
            ErrorLabel.Left = Picture1.Width
        Else
            If ErrorLabel.Left + ErrorLabel.Width > 0 Then
                ErrorLabel.Left = ErrorLabel.Left - 15
                Label5.Left = ErrorLabel.Left + ErrorLabel.Width + 15 * 40
            Else
                ErrorLabel.Left = Picture1.Width
            End If
        End If
    Else
        If Len(Trim(Label5.Caption)) <= 0 Then
            Label5.Left = Picture1.Width
        Else
            If Label5.Left + Label5.Width > 0 Then
                Label5.Left = Label5.Left - 15
                ErrorLabel.Left = Label5.Left + Label5.Width + 15 * 40
            Else
                Label5.Left = Picture1.Width
            End If
        End If
    End If
        
'    On Error GoTo error_handle
        
    nVolume = Int(GetVolume(volCtrl) / (volCtrl.lMaximum / 100))
    
    nRightVolume = nVolume
    
    Image5.Width = nVolume * 9
    
    Exit Sub
error_handle:
    If Trim(Error) = "Unable to read MPEG-Header" Then
        ErrorLabel.Caption = "ccccc此文件不存在或不是标准格式 ！"
        bOpenFileFlag = False
    Else
        ErrorLabel.Caption = Error
    End If
    
    Resume Next
    
End Sub

Private Sub Timer4_Timer()
    nRepeatTime = 0
    Timer4.Enabled = False
End Sub

Function GetCommandLine()
    
    Dim i As Integer, nLen As Integer
    Dim cLine As String, C As String
    Dim cString As String
    
    cLine = Trim(Command())
    nLen = Len(cLine)
    
    If nLen > 3 And InStr(1, Trim(cLine), ".mp", 1) > 0 Then
        For i = 1 To nLen
            C = Mid(cLine, i, 1)
            If (C <> " " And C <> vbTab) Then
                cString = cString & C
            Else
                Exit For
            End If
        Next i
        GetCommandLine = Trim(cString)
    Else
        GetCommandLine = ""
    End If
    
End Function

Function CreateAssociation()

   Dim sPath As String
   
   sPath = App.Path & "\" & App.EXEName & ".EXE %1"
   
   CreateNewKey ".mp3", HKEY_CLASSES_ROOT
   SetKeyValue ".mp3", "", "SuperMp3_File1", REG_SZ
   
   CreateNewKey "SuperMp3_File1\DefaultIcon", HKEY_CLASSES_ROOT
   SetKeyValue "SuperMp3_File1\DefaultIcon", "", App.Path & "\" & App.EXEName & ".EXE,0", REG_SZ
   
   CreateNewKey "SuperMp3_File1\shell\播放\command", HKEY_CLASSES_ROOT
   SetKeyValue "SuperMp3_File1\shell\播放\command", "", sPath, REG_SZ
   
   
   CreateNewKey ".mp2", HKEY_CLASSES_ROOT
   SetKeyValue ".mp2", "", "SuperMp3_File2", REG_SZ
   
   CreateNewKey "SuperMp3_File2\DefaultIcon", HKEY_CLASSES_ROOT
   SetKeyValue "SuperMp3_File2\DefaultIcon", "", App.Path & "\" & App.EXEName & ".EXE,0", REG_SZ
   
   CreateNewKey "SuperMp3_File2\shell\播放\command", HKEY_CLASSES_ROOT
   SetKeyValue "SuperMp3_File2\shell\播放\command", "", sPath, REG_SZ
   
End Function

Function FormLoaded(frm As Form) As Boolean
  Dim i As Integer

  FormLoaded = False

  For i = 0 To Forms.Count - 1
    If Forms(i) Is frm Then
      FormLoaded = True
      Exit Function
    End If
  Next

End Function

Sub Bubble1(frm As Form)
   Dim a As Integer
   Dim b As Integer
   Dim C As Integer
   Dim d As Integer
   Dim e As Integer
   Dim f As Integer
   Dim w As Integer
   Dim X As Integer
   Dim Y As Integer
   Dim z As Integer
   Dim current As Double
   
   Call frm.Move(Screen.Width / 2 - frm.Width / 2 - 93 * 15, Screen.Height / 2 - frm.Height / 2 - 93 * 15)
   w = frm.Height: X = frm.Width: Y = frm.Top: z = frm.Left
   a = 0: b = 0: C = w: d = X: e = Y: f = z
   Do While a < frm.Height / 15 Or b < frm.Width / 15
      a = a + 13
      b = b + 13
      e = e + 36
      f = f + 36
      If a > frm.Height / 15 Then a = a - 12
      If b > frm.Width / 15 Then b = b - 12
      Call frm.Move(f, e)
      current = Timer
      Do While Timer - current < 0.01
         DoEvents
      Loop
      Call SetWindowRgn(frm.hwnd, CreateEllipticRgn(0, 0, b, a), True)
      frm.Show
   Loop
   
'   X = 0: Y = 0
'   Do While X > -80 And Y > -40
'    X = X - 6
'    Y = Y - 3
'      current = Timer
'      Do While Timer - current < 0.01
'         DoEvents
'      Loop
   'Call SetWindowRgn(frm.Hwnd, CreateEllipticRgn(-80, -40, 600, 186), True)
'    Call SetWindowRgn(frm.hwnd, CreateEllipticRgn(X, Y, b, a), True)
'    Loop
    
'    Do While b < 600 And a < 186
'        b = b + 5
'        a = a + 4
       
'        current = Timer
'        Do While Timer - current < 0.01
'            DoEvents
'        Loop
'        Call SetWindowRgn(frm.hwnd, CreateEllipticRgn(X, Y, b, a), True)
'    Loop
'        Do While Timer - current < 0.01
'            DoEvents
'        Loop
        Call SetWindowRgn(frm.hwnd, CreateEllipticRgn(0, 0, 0, 0), True)

End Sub

Sub Bubble2(frm As Form)
   Dim a As Integer
   Dim b As Integer
   Dim C As Integer
   Dim d As Integer
   Dim e As Integer
   Dim f As Integer
   Dim w As Integer
   Dim X As Integer
   Dim Y As Integer
   Dim z As Integer
   Dim current As Double
   
   w = frm.Height: X = frm.Width: Y = frm.Top: z = frm.Left
   a = 0: b = 0: C = w: d = X: e = Y: f = z
   Do While a < frm.Height / 15 Or b < frm.Width / 15
      a = a + 25
      b = b + 25
      e = e + 70
      f = f + 70
      If a > frm.Height / 15 Then a = a - 24
      If b > frm.Width / 15 Then b = b - 24
      current = Timer
      Do While Timer - current < 0.01
         DoEvents
      Loop
      Call SetWindowRgn(frm.hwnd, CreateEllipticRgn(0, 0, b, a), True)
      frm.Show
   Loop
   
    Do While Timer - current < 0.01
        DoEvents
    Loop
    Call SetWindowRgn(frm.hwnd, CreateEllipticRgn(0, 0, 0, 0), True)

End Sub

Function PhaseOutForm(pType As Integer, oForm As Object)
Dim lMyHandle As Long
Dim lMyRgn As Long
Dim l As Long
Dim X1 As Long, Y1 As Long, X2 As Long, Y2 As Long
Dim iTime As Long
Dim nStepX As Integer
Dim nStepY As Integer

nStepX = 10
nStepY = 4

iTime = 30
lMyHandle = oForm.hwnd

X1 = 0
Y1 = 0
X2 = oForm.ScaleX(oForm.Width, vbTwips, vbPixels)
Y2 = oForm.ScaleX(oForm.Height, vbTwips, vbPixels)
Do
    If (pType = 1) Then
        lMyRgn = CreateEllipticRgn(X1, Y1, X2, Y2)
    Else
        lMyRgn = CreateRectRgn(X1, Y1, X2, Y2)
    End If

    l = SetWindowRgn(lMyHandle, lMyRgn, True)
    DoEvents
    Sleep (iTime)
    X1 = X1 + nStepX
    Y1 = Y1 + nStepY
    X2 = X2 - nStepX
    Y2 = Y2 - nStepY
Loop Until Y2 - Y1 < 0

'MsgBox X1 & ":" & Y1 & ":" & X2 & ":" & Y2
End Function

Function PhaseInForm(oForm As Object)
Dim lMyHandle As Long
Dim lMyRgn As Long
Dim l As Long
Dim X1 As Long, Y1 As Long, X2 As Long, Y2 As Long
Dim iTime As Long

Dim nStepX As Integer
Dim nStepY As Integer

nStepX = 10
nStepY = 4

iTime = 30
lMyHandle = oForm.hwnd

X1 = 130
Y1 = 50
X2 = 370
Y2 = 48

Me.Show

Do
    lMyRgn = CreateRectRgn(X1, Y1, X2, Y2)

    l = SetWindowRgn(lMyHandle, lMyRgn, True)
    DoEvents
    Sleep (iTime)
    X1 = IIf(X1 < 0, 0, X1 - nStepX)
    Y1 = IIf(Y1 < 0, 0, Y1 - nStepY)
    X2 = IIf(X2 > 500, 500, X2 + nStepX)
    Y2 = IIf(Y2 > 100, 100, Y2 + nStepY)
Loop Until Y2 - Y1 > 110

End Function

Private Sub Timer5_Timer()
    Dim nVolume As Long
    
    If nLeftVolume = -1000 Then
        nVolume = GetVolume(volCtrl)
        nVolume = nVolume - volCtrl.lMaximum / 100
        
        If nVolume < volCtrl.lMinimum Then
            SetVolume hmixer, volCtrl, volCtrl.lMinimum
        Else
            SetVolume hmixer, volCtrl, nVolume
        End If
    ElseIf nLeftVolume = 1000 Then
        nVolume = GetVolume(volCtrl)
        nVolume = nVolume + volCtrl.lMaximum / 100
        
        If nVolume > volCtrl.lMaximum Then
            SetVolume hmixer, volCtrl, volCtrl.lMaximum
        Else
            SetVolume hmixer, volCtrl, nVolume
        End If
    End If
End Sub