Primer 2.- Mp3 player, kreiran pomoću API funkcija :
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
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