没事写了个MEDIAPLAYER播放列表生成器,现将代码贴出

[trendvb]

近来用MEDIAPLAYER播放媒体文件时,觉得它的播放列表功能太软了.

就写了个小程序,并贴出代码,请大家帮着顶一下.
ociq:48403849
email:[e-mail]
编译后的下载地址:www.freewebs.com/aaron_ts/wma_list.zip

Option Explicit
Dim FN As String, isSaved As Boolean
Private Sub cmdAdd_Click()
On Error GoTo openerr
With CDL
.CancelError = True
.Filter = "所以文件(*.*)|*.*|WMA文件(*.WMA)|*.WMA|RM文件(*.RM)|*.RM"
.ShowOpen
List1.AddItem """" & .Filename & """"

End With
isSaved = False
Exit Sub
openerr:

End Sub

Private Sub cmdDel_Click()
If List1.SelCount = 0 Then Exit Sub
List1.RemoveItem List1.ListIndex
isSaved = False
End Sub

Private Sub cmdDown_Click()
Dim curInd%, curTxt$
If List1.SelCount = 0 Then Exit Sub
curInd = List1.ListIndex + 1
curTxt = List1.Text
If List1.ListIndex + 1 = List1.ListCount Then
Exit Sub
End If
List1.RemoveItem List1.ListIndex
List1.AddItem curTxt, curInd
List1.Selected(curInd) = True
isSaved = False
End Sub

Private Sub cmdHelp_Click()
Dim MSG As String
Dim TMP As String
TMP = Chr(13) & Chr(10)
MSG = "**本程序弥补了Media Player不能方便创建播放列表的功能缺陷" & TMP & _
"**Media Player播放软件支持的文件为*.WMA(或其它媒体文件),其播放列表文件为*.asx" & TMP & _
"选择不同目录的媒体文件后,可保存为*.asx文件至你的硬盘,直接双击即可运行" & TMP & _
"**运行环境:WINXP,WIN2K下可直接运行,WIN98以下版本需要VB6运行库支持才能使用" & TMP & _
"**快速使用:点击'添加文件'按钮或右键单击鼠标添加媒体文件" & TMP & _
TMP & "=== BY:张小辉 Email:[e-mail] ==="

MsgBox MSG
End Sub

Private Sub cmdOpen_Click()
Dim lFile As Long
Dim sLine As String
Dim nX1 As Integer, nX2 As Integer
Dim sTmp As String
Dim Filename As String

lFile = FreeFile
On Error GoTo err_get
With CDL
.CancelError = True
.Filter = "Media Player列表文件(*.asx)|*.asx|"
.ShowOpen
End With
Filename = CDL.Filename
If Filename <> "" Then
List1.Clear
Open Filename For Input As #lFile
While Not EOF(lFile)
Line Input #lFile, sLine

If InStr(sLine, "<Ref") <> 0 Then
nX1 = InStr(sLine, ":") - 2
nX2 = InStr(sLine, "/")
sTmp = Mid(sLine, nX1, nX2 - nX1)
List1.AddItem sTmp
End If

Wend
Close #lFile
FN = Filename

cmdplay.Enabled = True
End If
Exit Sub
err_get:

End Sub

Private Sub cmdplay_Click()
On Error GoTo err
Dim TMP$
If isSaved = False Then
MsgBox "列表文件尚未保存,请先保存后再选择播放", vbExclamation
Exit Sub
End If
If FN = "" Then Exit Sub
TMP = InputBox("播放软件(Media Player)路径是否正确?如不正确,请自行更改", , "C:\Program Files\Windows Media Player\wmplayer.exe")
Shell TMP & " " & FN
cmdplay.Enabled = False
Exit Sub
err:
MsgBox "请确认宿主文件及生成文件路径是否正确"
End Sub

Private Sub cmdSave_Click()
Dim i%
Dim sEnter As String
Dim sName As String
Dim lFile As Long
Dim sAll As String

sEnter = Chr(13) & Chr(10)
lFile = FreeFile

sAll = sAll & "<Asx Version = 3.0 >" & sEnter
If List1.ListCount = 0 Then
MsgBox "播放列表为空,不能保存文件!", vbExclamation
Exit Sub
End If
For i = 0 To List1.ListCount - 1
List1.Selected(i) = True

sAll = sAll & "<Entry>" & sEnter & _
"<Title>" & List1.Text & "</Title>" & sEnter _
& "<Author>艺术家:AARON,呵呵</Author>" & sEnter _
& "<Ref href=" & List1.Text & "/>" & sEnter & "</Entry>" & sEnter
Next i
sAll = sAll & "</Asx>"
Text1.Text = sAll
On Error GoTo err_save
With CDL
.CancelError = True
.Filter = "Media Player列表文件(*.asx)|*.asx"
.Filename = "MusicNow"
.ShowSave
End With
FN = CDL.Filename
If FN <> "" Then
Open FN For Output As #lFile
Print #lFile, Text1.Text
Close #lFile
MsgBox "列表文件生成成功!", vbInformation
cmdplay.Enabled = True
isSaved = True
End If
Exit Sub
err_save:

End Sub

Private Sub cmdUp_Click()
Dim curInd%, curTxt$
If List1.SelCount = 0 Then Exit Sub
curInd = List1.ListIndex - 1
If curInd < 0 Then
curInd = 0
End If
curTxt = List1.Text
List1.RemoveItem List1.ListIndex
List1.AddItem curTxt, curInd
List1.Selected(curInd) = True
isSaved = False
End Sub

Private Sub Form_Load()
isSaved = True
Me.BackColor = List1.BackColor
End Sub

Private Sub Form_Resize()
On Error Resume Next
With Picture1
.Left = 0
.Top = 0
.Width = Me.ScaleWidth
End With
With List1
.Left = 0
.Top = Picture1.Height + 5
.Width = Me.ScaleWidth
.Height = Me.ScaleHeight - Picture1.Height + 5
End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim result
If isSaved = False Then
result = MsgBox("列表文件尚未保存,您确实要退出吗", vbQuestion + vbYesNo)
If result = vbNo Then
Cancel = True
Call cmdSave_Click
End If
End If
End Sub



Private Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
PopupMenu mnusss
End If
End Sub

Private Sub mnuadd_Click()
Call cmdAdd_Click
End Sub

Private Sub mnudel_Click()
Call cmdDel_Click
End Sub

Private Sub mnudown_Click()
Call cmdDown_Click
End Sub

Private Sub mnuexit_Click()
Unload Me
End Sub

Private Sub mnusetcolor_Click()
On Error GoTo err
With CDL
.CancelError = True
.ShowColor
List1.BackColor = .Color
Me.BackColor = .Color
End With
Exit Sub
err:

End Sub

Private Sub mnusetforecolor_Click()
On Error GoTo err
With CDL
.CancelError = True
.ShowColor
List1.ForeColor = .Color
End With
Exit Sub
err:

End Sub

Private Sub mnusss_Click()
If List1.ListCount = 0 Then
mnuup.Enabled = False
mnudown.Enabled = False
mnudel.Enabled = False
mnusetforecolor.Enabled = False
Else
mnuup.Enabled = True
mnudown.Enabled = True
mnudel.Enabled = True
mnusetforecolor.Enabled = True
End If
End Sub

Private Sub mnuup_Click()
Call cmdUp_Click
End Sub