| Welcome to VITINHTHANHSON. We hope you enjoy your visit. You're currently viewing our forum as a guest. This means you are limited to certain areas of the board and there are some features you can't use. If you join our community, you'll be able to access member-only sections, and use many member-only features such as customizing your profile, sending personal messages, and voting in polls. Registration is simple, fast, and completely free. Join our community! If you're already a member please log in to your account to access all of our features: |
| Tạo chương trình nghe nhạc bằng VB 6.0 | |
|---|---|
| Tweet Topic Started: Jul 10 2006, 11:17 PM (964 Views) | |
| Dinhvanquanglk | Jul 10 2006, 11:17 PM Post #1 |
|
Tổng thư ký
![]()
|
Thêm vào Project một Modul với tên là Modul1 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 '============= ' Viết cho đối tượng 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 |
|
[size=5]Nhà 0 số-Mố Cầu Long Biên-Long Biên-Hà Nội[/size] | |
![]() |
|
| Dinhvanquanglk | Jul 10 2006, 11:18 PM Post #2 |
|
Tổng thư ký
![]()
|
|
|
[size=5]Nhà 0 số-Mố Cầu Long Biên-Long Biên-Hà Nội[/size] | |
![]() |
|
| 1 user reading this topic (1 Guest and 0 Anonymous) | |
![]() Join the millions that use us for their forum communities. Create your own forum today. Learn More · Sign-up Now |
|
| « Previous Topic · Visual Basic · Next Topic » |








3:15 PM Jul 11