Tự tạo chương trình nghe nhạc bằng VB 6

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 MediaPath As String * 250Name 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

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

- Nội dung:

Dim Song As MediaDim DATAfile As StringDim RecEndDim i, Filenum, Sogia As IntegerDim p

'Hàm kiểm tra sự tồn tại của 1 fileFunction FileExists(FileName) As BooleanDim Msg As StringOn Error GoTo CheckErrorFileExists = (Dir(FileName) <> "")Exit FunctionCheckError:Const mnErrDiskNotReady = 71, mnErrDeviceUnavailable = 68If (Err.Number = mnErrDiskNotReady) ThenMsg = "Put a floppy disk in the drive."If MsgBox(Msg, vbExclamation & vbOKCancel) = vbOK ThenResumeElseResume NextEnd IfElseIf Err.Number = mnErrDeviceUnavailable ThenMsg = "This drive or path does not exist: " & FileNameMsgBox Msg, vbExclamationResume NextElseMsg = "Unexpected error #" & Str(Err.Number) & " occurred: " _& Err.DescriptionMsgBox Msg, vbCriticalStopEnd IfResumeEnd FunctionPrivate Sub cmdCapNhat_Click()CapnhatEnd SubPrivate Sub Command1_Click()PopupMenu mnuSettingEnd SubPrivate Sub Capnhat()Filenum = FreeFileOpen DATAfile For Random As #Filenum Len = Len(Song)RecEnd = FileLen(DATAfile) / Len(Song)For i = 1 To RecEndGet #Filenum, i, SongList1.AddItem (Trim(Song.Name))List2.AddItem (Trim(Song.Path))Next iClose #FilenumEnd SubPrivate Sub Form_Load()Volume1.Value = 10 'Giá trị mặc định của Volume khi khởi động

'Mở file danh sáchIf Len(App.Path) > 3 ThenDATAfile = App.Path & "TMedia.lst"ElseDATAfile = App.Path & "TMedia.lst"End IfmnuRepeat.Checked = TruemnuMini.Checked = FalseOn Error Resume NextmnuMini.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")CapnhatMiniDamVolume1_ScrollEnd SubPrivate Sub SaveReg()

'Ghi cấu hình vào RegistryOn Error Resume NextSaveSetting "FastRun 1.0", "Media", "Check Mini", mnuMini.CheckedSaveSetting "FastRun 1.0", "Media", "Check Repeat", mnuRepeat.CheckedSaveSetting "FastRun 1.0", "Media", "Media Top", frmMedia.TopSaveSetting "FastRun 1.0", "Media", "Media Left", frmMedia.LeftSaveSetting "FastRun 1.0", "Media", "Volume", Volume1.ValueSaveSetting "FastRun 1.0", "Media", "Font Bold", mnuDam.CheckedSaveSetting "FastRun 1.0", "Media", "Back Color", List1.BackColorSaveSetting "FastRun 1.0", "Media", "Text Color", List1.ForeColorDeleteSetting "FastRun 1.0", "Media", "Time Song"End SubPrivate Sub KetThuc()SaveRegUnload frmMediaUnload frmAuthorUnload frmOpenEnd SubPrivate Sub Form_Unload(Cancel As Integer)KetThucEnd SubPrivate Sub List1_DblClick()If FileExists(List2.List(List1.ListIndex)) = True ThenMediaPlayer1.FileName = List2.List(List1.ListIndex)ThanhCong = TrueElseIf List1.ListIndex = List1.ListCount - 1 And ThanhCong = False ThenMsgBox "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"ElseHetBaiEnd IfEnd IfEnd Sub

Private Sub HetBai()If mnuRepeat.Checked = True And List1.ListCount > 0 ThenIf List1.ListIndex + 1 < List1.ListCount ThenList1.ListIndex = List1.ListIndex + 1ElseList1.ListIndex = 0ThanhCong = FalseEnd IfOn Error Resume NextList1_DblClickEnd IfEnd SubPrivate Sub List1_KeyPress(KeyAscii As Integer)If Keyascii = 13 ThenList1_DblClickEnd End End SubPrivate Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)If List1.ListIndex >= 0 ThenList1.ToolTipText = Left(List1.List(List1.ListIndex), Len(List1.List(List1.ListIndex)) - 3)End IfEnd SubPrivate Sub MediaPlayer1_EndOfStream(ByVal Result As Long)'Hành động khi hết một bài

HetBaiEnd SubPrivate Sub mnuAdd_Click()frmOpen.Show vbModalEnd SubPrivate Sub mnuAuthor_Click()frmAuthor.ShowEnd SubPrivate Sub mnuDelete_Click()frmListEdit.ShowEnd SubPrivate Sub mnuChu_Click()CommonDialog1.Color = List1.ForeColorCommonDialog1.Action = 3List1.ForeColor = CommonDialog1.ColorEnd SubPrivate Sub mnuDam_Click()If mnuDam.Checked = False ThenList1.FontBold = FalsemnuDam.Checked = TrueElseList1.FontBold = TruemnuDam.Checked = FalseEnd IfDamEnd SubPrivate Sub Dam()If mnuDam.Checked = False ThenList1.FontBold = FalseElseList1.FontBold = TrueEnd IfEnd SubPrivate Sub mnuExit_Click()KetThucEnd SubPrivate Sub mnuMini_Click()If mnuMini.Checked = True ThenmnuMini.Checked = FalseElsemnuMini.Checked = TrueEnd IfMiniEnd SubPrivate Sub Mini()If mnuMini.Checked = True ThenList1.Height = 255frmMedia.Height = 1740List1.ListIndex = List1.ListIndexElseList1.Height = 2400frmMedia.Height = 3885End IfEnd SubPrivate Sub mnuNumber_Click()If mnuNumber.Checked = True ThenmnuNumber.Checked = FalseElsemnuNumber.Checked = TrueEnd IfEnd SubPrivate Sub mnuNen_Click()CommonDialog1.Color = List1.BackColorCommonDialog1.Action = 3List1.BackColor = CommonDialog1.ColorEnd SubPrivate Sub mnuRepeat_Click()If mnuRepeat.Checked = True ThenmnuRepeat.Checked = FalseElsemnuRepeat.Checked = TrueEnd IfEnd SubPrivate Sub Text1_Click()Text1.Text = Str(MediaPlayer1.Volume)End SubPrivate Sub Volume1_Scroll()Select Case Volume1.ValueCase 13: Sogia = 0Case 12: Sogia = -40Case 11: Sogia = -90Case 10: Sogia = -180Case 9: Sogia = -280Case 8: Sogia = -410Case 7: Sogia = -500Case 6: Sogia = -650Case 5: Sogia = -860Case 4: Sogia = -1100Case 3: Sogia = -1350Case 2: Sogia = -1900Case 1: Sogia = -2600Case 0: Sogia = -9640End SelectMediaPlayer1.Volume = SogiaEnd Sub

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

-Nội dung:

Option ExplicitDim SongOpen As MediaDim i, CurrentSong, Filenum As IntegerDim PathSong As StringDim DATAfile As StringDim RecEndFunction FileExists(FileName) As BooleanDim Msg As StringOn Error GoTo CheckErrorFileExists = (Dir(FileName) <> "")Exit FunctionCheckError:Const mnErrDiskNotReady = 71, mnErrDeviceUnavailable = 68If (Err.Number = mnErrDiskNotReady) ThenMsg = "Put a floppy disk in the drive."If MsgBox(Msg, vbExclamation & vbOKCancel) = vbOK ThenResumeElseResume NextEnd IfElse If Err.Number = mnErrDeviceUnavailable ThenMsg = "This drive or path does not exist: " & FileNameMsgBox Msg, vbExclamationResume NextElseMsg = "Unexpected error #" & Str(Err.Number) & " occurred: " _& Err.DescriptionMsgBox Msg, vbCriticalStopEnd IfResumeEnd FunctionPrivate Sub cmdAddAll_Click()If Len(Dir1.Path) = 3 ThenPathSong = Dir1.PathElsePathSong = Dir1.Path + ""End IfFor i = 0 To File1.ListCount - 1List1.AddItem (File1.List(i))List2.AddItem (PathSong + File1.List(i))Next iIf cmdClear.Enabled = False ThencmdClear.Enabled = TrueEnd IfKTnutClearEnd SubPrivate Sub cmdCancel_Click()Unload frmOpenEnd SubPrivate Sub cmdClear_Click()KTnutClearIf cmdClear.Enabled = True ThenIf List1.ListIndex < 0 And List1.ListCount > 0 ThenList1.ListIndex = 0End IfCurrentSong = List1.ListIndexList1.RemoveItem (CurrentSong)List2.RemoveItem (CurrentSong)If List1.ListCount < 0 ThenList1.ListIndex = List1.ListCount - 1End IfIf List1.ListCount = 0 ThencmdClear.Enabled = FalseEnd IfEnd IfEnd SubPrivate Sub cmdClearAll_Click()KTnutClearIf cmdClearAll.Enabled = True ThenList1.ClearList2.ClearEnd IfEnd SubPrivate Sub cmdOK_Click()'save in fileIf Len(App.Path) > 3 ThenDATAfile = App.Path + "TMedia.lst"ElseDATAfile = App.Path + "TMedia.lst"End IfIf FileExists(DATAfile) = True ThenKill DATAfileEnd IffrmMedia.List1.ClearfrmMedia.List2.ClearIf List1.ListCount > 0 ThenFilenum = FreeFileOpen DATAfile For Random As #Filenum Len = Len(SongOpen)If List1.ListCount > 0 ThenFor i = 0 To List1.ListCount - 1SongOpen.Name = List1.List(i)SongOpen.Path = List2.List(i)Put #Filenum, i + 1, SongOpenNext iEnd IfClose #FilenumfrmMedia.cmdCapNhat.Value = TrueEnd IfUnload frmOpenfrmMedia.SetFocusEnd SubPrivate Sub Combo1_Click()File1.Pattern = Combo1.TextIf Combo1.ListIndex = 1 ThencmdAddAll.Enabled = FalseMsgBox " 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"ElsecmdAddAll.Enabled = TrueEnd IfEnd SubPrivate Sub Dir1_Change()File1.Path = Dir1.PathKTnutAddAllEnd SubPrivate Sub Dir1_KeyPress(KeyAscii As Integer)If KeyAscii = 13 ThenDir1.Path = Dir1.List(Dir1.ListIndex)'File1_DblClickEnd IfEnd SubPrivate Sub Drive1_Change()On Error Resume NextDir1.Path = Drive1.DriveIf Err ThenMsgBox "Kh«ng t×m thÊy ®Üa", vbCritical, "Media - Warning"Drive1.Drive = Dir1.PathEnd IfEnd SubPrivate Sub File1_DblClick()If File1.Pattern <> "*.*" ThenIf Len(Dir1.Path) = 3 ThenPathSong = Dir1.Path + File1.FileNameElsePathSong = Dir1.Path + "" + File1.FileNameEnd IfList1.AddItem (File1.FileName)List2.AddItem (PathSong)If cmdClear.Enabled = False ThencmdClear.Enabled = TrueEnd IfKTnutClearElseMsgBox "B¹n cÇn ®Æt kiÓu file trong hép Pattern lµ '*.mp3;*.wav;*.mid'", vbCritical, "Media - Warning"End IfEnd SubPrivate Sub File1_KeyPress(KeyAscii As Integer)If KeyAscii = 13 ThenFile1_DblClickEnd IfEnd SubPrivate Sub Form_Load()For i = 0 To frmMedia.List1.ListCount - 1List1.AddItem (frmMedia.List1.List(i))List2.AddItem (frmMedia.List2.List(i))Next iKTnutAddAllKTnutClearCombo1.ListIndex = 0File1.Pattern = Combo1.TextFile1.Hidden = TrueFile1.ReadOnly = TrueFile1.System = TrueEnd SubPrivate Sub KTnutAddAll()If File1.ListCount > 0 And File1.Pattern <> "*.*" ThencmdAddAll.Enabled = TrueElsecmdAddAll.Enabled = FalseEnd IfEnd SubPrivate Sub KTnutClear()If List1.ListCount > 0 ThencmdClear.Enabled = TruecmdClearAll.Enabled = TrueElsecmdClear.Enabled = FalsecmdClearAll.Enabled = FalseEnd IfEnd Sub