Tu lam chuong trinh nghe nhac

Tự tạo chương trình nghe nhạc

bằng VB 6.0

Trần Trung

Các điều khiển của VB thật dồi dào, và vẫn liên tục phát triển, điều này giúp cho người lập trình nhanh chóng cho ra lò một sản phẩm không đến nỗi nào, mà chỉ trong một thời gian rất ngắn. Bài viết này trình bày về chương trình nghe nhạc số (MP3,WAV,MID) sử dụng điều khiển Windows Media Player, chương trình có khả năng phát tuần tự từng bài trong danh sách, save danh sách bài hát vào một file, cho phép Browse để chọn các bài hát và thêm vào danh sách, có chức năng ghi các thông tin cấu hình vào Registry để lưu giữ, khi chạy chiếm rất ít tài nguyên hệ thống, khởi động tức thì. Giao diện đơn giản dễ sử dụng, có các chức năng tối thiểu của một trình nghe nhạc, có mã nguồn hoàn chỉnh đi kèm

Chương trình này sử dụng file danh sách là một file kiểu bản ghi, điều này có lợi thế là truy xuất nhanh, thêm xoá sửa cũng dễ dàng hơn, nhưng bù lại kích thước file khá lớn.

Với chương trình này bạn đã sở hữu trong tay một máy nghe nhạc, và với một chút kiến thức lập trình bạn có thể làm cho giao diện cũng như hoạt động của nó chuyên nghiệp hơn, chương trình còn nhiều hạn chế, tôi rất mong các bạn cải tiến cho nó mạnh hơn nữa.

Giao diện chương trình

Mã nguồn của chương trình.

Tôi không liệt kê thuộc tính của các control được sử dụng trong chương trình vì đã có mã nguồn hoàn chỉnh đi kèm, bạn chỉ việc download project này về ổ cứng, giải nén và mở nó bằng Visual Basic là xong. Tôi sử dụng Visual Basic 6.0, Windows 98 SE, nếu bạn dùng các phiên bản cũ hơn có thể chương trình không chạy.

1. Tạo một Project mới

Thêm vào Project một Modul với tên là Modul1

- Nội dung:

Option Explicit
'Kiểu bản ghi của file danh sách, chỉ gồm 2 trường
Type Media
Path As String * 250
Name As String * 100
'Tên file bài hát không dài quá 250 ký tự
'Đường dẫn không dài quá 100 ký tự
End Type

2. Đặt tên cho Form hiện hành là frmMedia

- Nội dung:

Dim Song As Media
Dim DATAfile As String
Dim RecEnd
Dim i, Filenum, Sogia As Integer
Dim p

'Hàm kiểm tra sự tồn tại của 1 file
Function FileExists(FileName) As Boolean
Dim Msg As String
On Error GoTo CheckError
FileExists = (Dir(FileName) <> "")
Exit Function
CheckError:
Const mnErrDiskNotReady = 71, mnErrDeviceUnavailable = 68
If (Err.Number = mnErrDiskNotReady) Then
Msg = "Put a floppy disk in the drive."
If MsgBox(Msg, vbExclamation & vbOKCancel) = vbOK Then
Resume
Else
Resume Next
End If
ElseIf Err.Number = mnErrDeviceUnavailable Then
Msg = "This drive or path does not exist: " & FileName
MsgBox Msg, vbExclamation
Resume Next
Else
Msg = "Unexpected error #" & Str(Err.Number) & " occurred: " _
& Err.Description
MsgBox Msg, vbCritical
Stop
End If
Resume
End Function

Private Sub cmdCapNhat_Click()
Capnhat
End Sub

Private Sub Command1_Click()
PopupMenu mnuSetting
End Sub

Private Sub Capnhat()
Filenum = FreeFile
Open DATAfile For Random As #Filenum Len = Len(Song)
RecEnd = FileLen(DATAfile) / Len(Song)
For i = 1 To RecEnd
Get #Filenum, i, Song
List1.AddItem (Trim(Song.Name))
List2.AddItem (Trim(Song.Path))
Next i
Close #Filenum
End Sub

Private Sub Form_Load()
Volume1.Value = 10 'Giá trị mặc định của Volume khi khởi động

'Mở file danh sách
If Len(App.Path) > 3 Then
DATAfile = App.Path & "\TMedia.lst"
Else
DATAfile = App.Path & "TMedia.lst"
End If
mnuRepeat.Checked = True
mnuMini.Checked = False
On Error Resume Next
mnuMini.Checked = GetSetting("FastRun 1.0", "Media", "Check Mini")
mnuRepeat.Checked = GetSetting("FastRun 1.0", "Media", "Check Repeat")
frmMedia.Top = GetSetting("FastRun 1.0", "Media", "Media Top")
frmMedia.Left = GetSetting("FastRun 1.0", "Media", "Media Left")
List1.BackColor = GetSetting("FastRun 1.0", "Media", "Back Color")
List1.ForeColor = GetSetting("FastRun 1.0", "Media", "Text Color")
mnuDam.Checked = GetSetting("FastRun 1.0", "Media", "Font Bold")
Hengio = GetSetting("FastRun 1.0", "Media", "Time Song")
Volume1.Value = GetSetting("FastRun 1.0", "Media", "Volume")
CheckDefaultList = GetSetting("FastRun 1.0", "Media", "DefaultList")
Capnhat
Mini
Dam
Volume1_Scroll
End Sub

Private Sub SaveReg()

'Ghi cấu hình vào Registry
On Error Resume Next
SaveSetting "FastRun 1.0", "Media", "Check Mini", mnuMini.Checked
SaveSetting "FastRun 1.0", "Media", "Check Repeat", mnuRepeat.Checked
SaveSetting "FastRun 1.0", "Media", "Media Top", frmMedia.Top
SaveSetting "FastRun 1.0", "Media", "Media Left", frmMedia.Left
SaveSetting "FastRun 1.0", "Media", "Volume", Volume1.Value
SaveSetting "FastRun 1.0", "Media", "Font Bold", mnuDam.Checked
SaveSetting "FastRun 1.0", "Media", "Back Color", List1.BackColor
SaveSetting "FastRun 1.0", "Media", "Text Color", List1.ForeColor
DeleteSetting "FastRun 1.0", "Media", "Time Song"
End Sub

Private Sub KetThuc()
SaveReg
Unload frmMedia
Unload frmAuthor
Unload frmOpen
End Sub

Private Sub Form_Unload(Cancel As Integer)
KetThuc
End Sub

Private Sub List1_DblClick()
If FileExists(List2.List(List1.ListIndex)) = True Then
MediaPlayer1.FileName = List2.List(List1.ListIndex)
ThanhCong = True
Else
If List1.ListIndex = List1.ListCount - 1 And ThanhCong = False Then
MsgBox "TÊt c¶ c¸c bµi trong danh s¸ch ®Òu sai ®êng dÉn hoÆc tªn file." + vbCrLf + "B¹n cÇn n¹p l¹i danh s¸ch !", vbCritical, "Media - Warning"
Else
HetBai
End If
End If
End Sub

Private Sub HetBai()
If mnuRepeat.Checked = True And List1.ListCount > 0 Then
If List1.ListIndex + 1 < List1.ListCount Then
List1.ListIndex = List1.ListIndex + 1
Else
List1.ListIndex = 0
ThanhCong = False
End If
On Error Resume Next
List1_DblClick
End If
End Sub

Private Sub List1_KeyPress(KeyAscii As Integer)
If Keyascii = 13 Then
List1_DblClick
End If
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If List1.ListIndex >= 0 Then
List1.ToolTipText = Left(List1.List(List1.ListIndex), Len(List1.List(List1.ListIndex)) - 3)
End If
End Sub

Private Sub MediaPlayer1_EndOfStream(ByVal Result As Long)
'Hành động khi hết một bài

HetBai
End Sub

Private Sub mnuAdd_Click()
frmOpen.Show vbModal
End Sub

Private Sub mnuAuthor_Click()
frmAuthor.Show
End Sub

Private Sub mnuDelete_Click()
frmListEdit.Show
End Sub

Private Sub mnuChu_Click()
CommonDialog1.Color = List1.ForeColor
CommonDialog1.Action = 3
List1.ForeColor = CommonDialog1.Color
End Sub

Private Sub mnuDam_Click()
If mnuDam.Checked = False Then
List1.FontBold = False
mnuDam.Checked = True
Else
List1.FontBold = True
mnuDam.Checked = False
End If
Dam
End Sub

Private Sub Dam()
If mnuDam.Checked = False Then
List1.FontBold = False
Else
List1.FontBold = True
End If
End Sub

Private Sub mnuExit_Click()
KetThuc
End Sub

Private Sub mnuMini_Click()
If mnuMini.Checked = True Then
mnuMini.Checked = False
Else
mnuMini.Checked = True
End If
Mini
End Sub

Private Sub Mini()
If mnuMini.Checked = True Then
List1.Height = 255
frmMedia.Height = 1740
List1.ListIndex = List1.ListIndex
Else
List1.Height = 2400
frmMedia.Height = 3885
End If
End Sub

Private Sub mnuNumber_Click()
If mnuNumber.Checked = True Then
mnuNumber.Checked = False
Else
mnuNumber.Checked = True
End If
End Sub

Private Sub mnuNen_Click()
CommonDialog1.Color = List1.BackColor
CommonDialog1.Action = 3
List1.BackColor = CommonDialog1.Color
End Sub

Private Sub mnuRepeat_Click()
If mnuRepeat.Checked = True Then
mnuRepeat.Checked = False
Else
mnuRepeat.Checked = True
End If
End Sub

Private Sub Text1_Click()
Text1.Text = Str(MediaPlayer1.Volume)
End Sub

Private Sub Volume1_Scroll()
Select Case Volume1.Value
Case 13: Sogia = 0
Case 12: Sogia = -40
Case 11: Sogia = -90
Case 10: Sogia = -180
Case 9: Sogia = -280
Case 8: Sogia = -410
Case 7: Sogia = -500
Case 6: Sogia = -650
Case 5: Sogia = -860
Case 4: Sogia = -1100
Case 3: Sogia = -1350
Case 2: Sogia = -1900
Case 1: Sogia = -2600
Case 0: Sogia = -9640
End Select
MediaPlayer1.Volume = Sogia
End Sub

3. Tạo một form mới đặt tên là frmOpen

-Nội dung:

Option Explicit
Dim SongOpen As Media
Dim i, CurrentSong, Filenum As Integer
Dim PathSong As String
Dim DATAfile As String
Dim RecEnd

Function FileExists(FileName) As Boolean
Dim Msg As String
On Error GoTo CheckError
FileExists = (Dir(FileName) <> "")
Exit Function
CheckError:
Const mnErrDiskNotReady = 71, mnErrDeviceUnavailable = 68
If (Err.Number = mnErrDiskNotReady) Then
Msg = "Put a floppy disk in the drive."
If MsgBox(Msg, vbExclamation & vbOKCancel) = vbOK Then
Resume
Else
Resume Next
End If
Else If Err.Number = mnErrDeviceUnavailable Then
Msg = "This drive or path does not exist: " & FileName
MsgBox Msg, vbExclamation
Resume Next
Else
Msg = "Unexpected error #" & Str(Err.Number) & " occurred: " _
& Err.Description
MsgBox Msg, vbCritical
Stop
End If
Resume
End Function

Private Sub cmdAddAll_Click()
If Len(Dir1.Path) = 3 Then
PathSong = Dir1.Path
Else
PathSong = Dir1.Path + "\"
End If
For i = 0 To File1.ListCount - 1
List1.AddItem (File1.List(i))
List2.AddItem (PathSong + File1.List(i))
Next i
If cmdClear.Enabled = False Then
cmdClear.Enabled = True
End If
KTnutClear
End Sub

Private Sub cmdCancel_Click()
Unload frmOpen
End Sub

Private Sub cmdClear_Click()
KTnutClear
If cmdClear.Enabled = True Then
If List1.ListIndex < 0 And List1.ListCount > 0 Then
List1.ListIndex = 0
End If
CurrentSong = List1.ListIndex
List1.RemoveItem (CurrentSong)
List2.RemoveItem (CurrentSong)
If List1.ListCount < 0 Then
List1.ListIndex = List1.ListCount - 1
End If
If List1.ListCount = 0 Then
cmdClear.Enabled = False
End If
End If
End Sub

Private Sub cmdClearAll_Click()
KTnutClear
If cmdClearAll.Enabled = True Then
List1.Clear
List2.Clear
End If
End Sub

Private Sub cmdOK_Click()
'save in file
If Len(App.Path) > 3 Then
DATAfile = App.Path + "\TMedia.lst"
Else
DATAfile = App.Path + "TMedia.lst"
End If
If FileExists(DATAfile) = True Then
Kill DATAfile
End If
frmMedia.List1.Clear
frmMedia.List2.Clear
If List1.ListCount > 0 Then
Filenum = FreeFile
Open DATAfile For Random As #Filenum Len = Len(SongOpen)
If List1.ListCount > 0 Then
For i = 0 To List1.ListCount - 1
SongOpen.Name = List1.List(i)
SongOpen.Path = List2.List(i)
Put #Filenum, i + 1, SongOpen
Next i
End If
Close #Filenum
frmMedia.cmdCapNhat.Value = True
End If
Unload frmOpen
frmMedia.SetFocus
End Sub

Private Sub Combo1_Click()
File1.Pattern = Combo1.Text
If Combo1.ListIndex = 1 Then
cmdAddAll.Enabled = False
MsgBox "NÕu b¹n chän kiÓu file lµ '' *.* '', b¹n sÏ kh«ng thªm ®îc file vµo danh s¸ch", vbCritical, "Warning"
Else
cmdAddAll.Enabled = True
End If
End Sub

Private Sub Dir1_Change()
File1.Path = Dir1.Path
KTnutAddAll
End Sub

Private Sub Dir1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Dir1.Path = Dir1.List(Dir1.ListIndex)
'File1_DblClick
End If
End Sub

Private Sub Drive1_Change()
On Error Resume Next
Dir1.Path = Drive1.Drive
If Err Then
MsgBox "Kh«ng t×m thÊy ®Üa", vbCritical, "Media - Warning"
Drive1.Drive = Dir1.Path
End If
End Sub

Private Sub File1_DblClick()
If File1.Pattern <> "*.*" Then
If Len(Dir1.Path) = 3 Then
PathSong = Dir1.Path + File1.FileName
Else
PathSong = Dir1.Path + "\" + File1.FileName
End If
List1.AddItem (File1.FileName)
List2.AddItem (PathSong)
If cmdClear.Enabled = False Then
cmdClear.Enabled = True
End If
KTnutClear
Else
MsgBox "B¹n cÇn ®Æt kiÓu file trong hép Pattern lµ ''*.mp3;*.wav;*.mid''", vbCritical, "Media - Warning"
End If
End Sub

Private Sub File1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
File1_DblClick
End If
End Sub

Private Sub Form_Load()
For i = 0 To frmMedia.List1.ListCount - 1
List1.AddItem (frmMedia.List1.List(i))
List2.AddItem (frmMedia.List2.List(i))
Next i
KTnutAddAll
KTnutClear
Combo1.ListIndex = 0
File1.Pattern = Combo1.Text
File1.Hidden = True
File1.ReadOnly = True
File1.System = True
End Sub

Private Sub KTnutAddAll()
If File1.ListCount > 0 And File1.Pattern <> "*.*" Then
cmdAddAll.Enabled = True
Else
cmdAddAll.Enabled = False
End If
End Sub

Private Sub KTnutClear()
If List1.ListCount > 0 Then
cmdClear.Enabled = True
cmdClearAll.Enabled = True
Else
cmdClear.Enabled = False
cmdClearAll.Enabled = False
End If
End Sub

4.Tạo thêm một form đặt tên là frmAuthor

-Nội dung:

Đây là form ghi thông tin về tác giả chương trình, tuỳ ý bạn

Chúc bạn thành công, nếu có gì thắc mắc xin liên hệ với tôi, nếu bạn không biết lập trình thì hãy download file EXE của chương trình này.

PcLeHoan 1996 - 2002
Mirror : http://www.pclehoan.com
Mirror : http://www.lehoanpc.net
Mirror : http://www.ktlehoan.com