Primer 2.- Mp3 player, kreiran pomoću API funkcija :

 

Prethodna strana

 

FORMA:


 

Option Explicit

 

Public MM As New MuzickiModul

Private Sub Form_Load()

Left = (Screen.Width - Width) \ 2

Top = (Screen.Height - Height) \ 2

End Sub

 

Private Sub Form_Unload(Cancel As Integer)

MM.StopPlay

End Sub

 

Private Sub Label2_Click()

On Error Resume Next

'Ako pesma nije odabrana izlazi iz Sub-a

If List2.text = "" Then MsgBox "Odaberite pesmu, molim!", , "Error": Exit Sub

'Stop ako je neka pesma vec pokrenuta pa da ne sviraju 2 istovremeno

MM.StopPlay

'Puni ime pesme

MM.FileName = List2

 

'Pusta pesmu

MM.Play

'Puni ime pesme koja je pustena

Text1 = "Pesma  : " & List1

MM.TimeOut 0.5

'Puni trajanje u sekundama

P1.ScaleWidth = MM.DurationInSec

End Sub

 

Private Sub Label3_Click()

MM.StopPlay

End Sub

 

Private Sub Label4_Click()

With Label4

If .Caption = "Pauza" Then

.Caption = "Dalje"

MM.Pause

Else

.Caption = "Pauza"

MM.ResumePlay

End If

End With

End Sub

 

Private Sub Label5_Click()

C.Filter = "M3U Playlist (*.m3u)|*.m3u|MP3 Files (*.mp3)|*.mp3|Wave Files (*.wav)|*.wav|Midi Files (*.mid)|*.mid|All Files (*.*)|*.*"

C.ShowOpen

If C.FileName = "" Then Exit Sub

If C.FileName = " " Then Exit Sub

If LCase(Right(C.FileName, 3)) = LCase("m3u") Then

List1.Clear

List2.Clear

Call MM.OpenPlaylist(C.FileName, List2)

Call MM.ListNoChar(List1, List2)

Else

List2.AddItem C.FileName

Call MM.ListSingleNoChar(List1, List2)

End If

C.FileName = ""

End Sub

 

Private Sub Label6_Click()

C.Filter = "M3U Playlist (*.m3u)|*.m3u"

C.ShowSave

If C.FileName = "" Then Exit Sub

If C.FileName = " " Then Exit Sub

 

Call MM.SavePlaylist(C.FileName, List2)

 

C.FileName = ""

End Sub

 

Private Sub Label7_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

MM.FormMove Me

End Sub

 

Private Sub Label8_Click()

Me.WindowState = 1

End Sub

 

Private Sub Label9_Click()

Unload Me

End

End Sub

 

Private Sub List1_Click()

List2.ListIndex = List1.ListIndex

End Sub

 

Private Sub List1_DblClick()

List2.ListIndex = List1.ListIndex

Label2_Click

End Sub

 

Private Sub P1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

P1.CurrentX = x

P2.Left = P1.CurrentX

MM.ChangePosition P1.CurrentX

End Sub

 

Private Sub Timer1_Timer()

On Error Resume Next

If MM.IsPlaying = False Then Exit Sub

Label1.Caption = MM.FormatPosition & "\" & MM.FormatDuration

Label10.Caption = MM.FormatTimeRemaining & "\" & MM.FormatDuration

P1.CurrentX = MM.PositioninSec

P2.Left = P1.CurrentX

If MM.EndOfSong = True Then

If List1.ListCount = 1 Then

Exit Sub

Else

List1.ListIndex = Val(List1.ListIndex) + 1

Label2_Click

End If

End If

End Sub


 

Prethodna strana


MODUL:

 

'Api za pristup registru

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

 Const HKEY_CLASSES_ROOT = &H80000000

'Api za pomeranje forme bez statusne linije

Private Declare Sub ReleaseCapture Lib "user32" ()

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wparam As Integer, ByVal iparam As Long) As Long

'Api za slanje komandi uredjaju

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

 

Public FileName As String

 

Sub TimeOut(duration)

    StartTime = Timer

 

 

    Do While Timer - StartTime < duration

        x = DoEvents()

    Loop

End Sub

 

Public Sub Play()

On Error GoTo TrapIt

mciSendString "close " & FileName, 0, 0, 0

FileName = Chr$(34) + Trim(FileName) + Chr$(34)

 mciSendString "open " & FileName, 0, 0, 0

 mciSendString "play " & FileName, 0, 0, 0

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Sub MyAppDefault(ByVal sAppName As String, ByVal sEXE As String, ByVal sExt As String)

 

Dim lRegKey As Long

Call RegCreateKey(HKEY_CLASSES_ROOT, sExt, lRegKey)

Call RegSetValueEx(lRegKey, "", 0&, 1, ByVal sAppName, Len(sAppName))

Call RegCloseKey(lRegKey)

Call RegCreateKey(HKEY_CLASSES_ROOT, sAppName & "\Shell\Open\Command", lRegKey)

Call RegSetValueEx(lRegKey, "", 0&, 1, ByVal sEXE, Len(sEXE))

Call RegCloseKey(lRegKey)

End Sub

 

Public Function EndOfSong() As Boolean

On Error GoTo TrapIt

Dim ThePos As Long

Dim TheDur As Long

ThePos = PositioninSec

TheDur = DurationInSec

If ThePos = 0 Or TheDur = 0 Then Exit Function

If ThePos = TheDur Then

EndOfSong = True

Else

EndOfSong = False

End If

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function

 

Public Sub FormMove(Frm As Form)

    ReleaseCapture

    Call SendMessage(Frm.hWnd, &HA1, 2, 0&)

End Sub

 

Public Sub OpenPlaylist(TheList As String, Listbox As Control)

On Error GoTo TrapIt

Dim test As String

If TheList = "" Then Exit Sub

Open TheList For Input As 1

While Not EOF(1)

Line Input #1, test

Listbox.AddItem RTrim(test)

Wend

Close 1

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Function TimeRemaininginMS() As Long

On Error GoTo TrapIt

TimeRemaininginMS = DurationInMS - PositioninMS

Exit Function

TrapIt:      MsgBox Err.Description, , " Error"

End Function

 

Public Function TimeRemaininginSec() As Long

On Error GoTo TrapIt

TimeRemaininginSec = DurationInSec - PositioninSec

Exit Function

TrapIt:      MsgBox Err.Description, , " Error"

End Function

 

Public Function FormatTimeRemaining() As String

On Error GoTo TrapIt

   FormatTimeRemaining = GetThisTime(TimeRemaininginMS)

Exit Function

TrapIt:      MsgBox Err.Description, , " Error"

End Function

 

Private Function GetLastBackSlash(text As String) As String

On Error GoTo TrapIt

    Dim i, pos As Integer

    Dim lastslash As Integer

    For i = 1 To Len(text)

        pos = InStr(i, text, "\", vbTextCompare)

        If pos <> 0 Then lastslash = pos

    Next i

    GetLastBackSlash = Right(text, Len(text) - lastslash)

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function

 

Private Function RightLeft(source As String, token As String) As String

On Error GoTo TrapIt

Dim i As Long

RightLeft = ""

For i = Len(source) To 1 Step -1

If Mid(source, i, 1) = token Then

RightLeft = Left(source, i - 1)

Exit Function

End If

Next i

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function

 

Public Sub ListNoChar(List1 As Listbox, List2 As Control)

On Error GoTo TrapIt

Dim x As Long

Dim NoChar As String

Dim NoEnd As String

For x = 0 To List2.ListCount - 1

NoChar = GetLastBackSlash(List2.List(x))

NoEnd = RightLeft(NoChar, ".")

List1.AddItem NoEnd

Next x

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Sub ListSingleNoChar(List1, List2)

On Error GoTo TrapIt

Dim x As String

Dim NoChar As String

Dim NoEnd As String

x = List2.ListCount - 1

List2.ListIndex = x

x = List2.text

NoChar = GetLastBackSlash(x)

NoEnd = RightLeft(NoChar, ".")

List1.AddItem NoEnd

MsgBox x

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Private Function NoEndChar(List1 As Listbox, List2 As Listbox) As String

On Error GoTo TrapIt

Dim n As Long

For n = 0 To List2.ListCount - 1

NoEndChar = Left(List2.List(n), 1)

Next n

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function

 

Public Sub SavePlaylist(TheList As String, Listbox As Control)

On Error GoTo TrapIt

Dim i As Integer

Dim a As String

Open TheList For Output As #1

For i = 0 To Listbox.ListCount - 1

a$ = Listbox.List(i)

Print #1, a$

Next

Close 1

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Function PositioninMS() As Long

On Error GoTo TrapIt

Static s As String * 30

mciSendString "set " & FileName & " time format milliseconds", 0, 0, 0

mciSendString "status " & FileName & " position", s, Len(s), 0

PositioninMS = Val(s)

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function

 

Public Function PositioninSec() As Long

On Error GoTo TrapIt

PositioninSec = Val(PositioninMS \ 1000)

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function

 

Public Function FormatPosition() As String

On Error GoTo TrapIt

Dim Sec As Long

Dim mins As Long

Static s As String * 30

    mciSendString "set " & FileName & " time format milliseconds", 0, 0, 0

    mciSendString "status " & FileName & " position", s, Len(s), 0

    Sec = PositioninSec

    If Sec < 60 Then FormatPosition = "0:" & Format(Sec, "00")

    If Sec > 59 Then

        mins = Int(Sec / 60)

        Sec = Sec - (mins * 60)

        FormatPosition = Format(mins, "0") & ":" & Format(Sec, "00")

    End If

Exit Function

TrapIt:      MsgBox Err.Description, , " Error"

End Function

 

Public Sub ChangePosition(TheSecond As Long)

On Error GoTo TrapIt

TheSecond = TheSecond * 1000

If IsPlaying = True Then mciSendString "play " & FileName & " from " & TheSecond, 0, 0, 0

If IsPlaying = False Then mciSendString "seek " & FileName & " to " & TheSecond, 0, 0, 0

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Sub StopPlay()

On Error GoTo TrapIt

mciSendString "close " & FileName, 0, 0, 0

 

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Sub Pause()

On Error GoTo TrapIt

mciSendString "stop " & FileName, 0, 0, 0

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Function DurationInMS() As Long

On Error GoTo TrapIt

Dim TotalTime As String * 128

    mciSendString "status " & FileName & " length", TotalTime, 128, 0&

    DurationInMS = Val(TotalTime)

Exit Function

TrapIt:      MsgBox Err.Description, , " Error"

End Function

 

Public Function FormatDuration() As String

On Error GoTo TrapIt

Dim TotalTime As String * 128

Dim T As String

Dim lTotalTime As Long

 

    mciSendString "set " & FileName & " time format ms", TotalTime, 128, 0&

    mciSendString "status " & FileName & " length", TotalTime, 128, 0&

 

    mciSendString "set " & FileName & " time format frames", 0&, 0&, 0&

   

    lTotalTime = Val(TotalTime)

   T = GetThisTime(lTotalTime)

    FormatDuration = T

Exit Function

TrapIt:      MsgBox Err.Description, , " Error"

End Function

 

Private Function GetThisTime(ByVal timein As Long) As String

    On Error GoTo TrapIt

    Dim conH As Integer

    Dim conM As Integer

    Dim conS As Integer

    Dim remTime As Long

    Dim strRetTime As String

    remTime = timein / 1000

    conH = Int(remTime / 3600)

    remTime = remTime Mod 3600

    conM = Int(remTime / 60)

    remTime = remTime Mod 60

    conS = remTime

   

    If conH > 0 Then

        strRetTime = Trim(Str(conH)) & ":"

    Else

        strRetTime = ""

    End If

    

    If conM >= 10 Then

        strRetTime = strRetTime & Trim(Str(conM))

    ElseIf conM > 0 Then

        strRetTime = strRetTime & Trim(Str(conM))

    Else

        strRetTime = strRetTime & "0"

    End If

   

    strRetTime = strRetTime & ":"

   

    If conS >= 10 Then

        strRetTime = strRetTime & Trim(Str(conS))

    ElseIf conS > 0 Then

        strRetTime = strRetTime & "0" & Trim(Str(conS))

    Else

        strRetTime = strRetTime & "00"

    End If

   

    GetThisTime = strRetTime

Exit Function

TrapIt:      MsgBox Err.Description, , " Error"

End Function

 

Public Function DurationInSec() As Long

On Error GoTo TrapIt

DurationInSec = DurationInMS \ 1000

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function

 

Public Sub ResumePlay()

On Error GoTo TrapIt

mciSendString "play " & FileName, 0, 0, 0

Exit Sub

TrapIt:  MsgBox Err.Description, , " Error"

End Sub

 

Public Function IsPlaying() As Boolean

On Error GoTo TrapIt

Dim a As Long

a = mciSendString("status " & FileName & " mode", 0, 0, 0)

If a = "0" Then

IsPlaying = True

Else

IsPlaying = False

End If

Exit Function

TrapIt:  MsgBox Err.Description, , " Error"

End Function


Prethodna strana