dj_lyrics.asp

安全性好,适用于制作论坛和进行资源下载的个人和大型网站使用!

<!--#include file="mdb.asp"-->
<%
'****************************************************
' Hxcms Ver7.5       Power by Hx66.net
' Web: http://www.Hx66.net,http://www.Hx66.net/home
' Copyright (C) 2006 Hx66.net All Rights Reserved.
'****************************************************
'********* 歌 *********** 词 *********** 函 *********** 数 *********** 开 *********** 始 ********
	'Option Explicit
	Dim Music_Name, CharSet

        Music_Name =  Request("Music")

        CharSet = "GB2312"
	Response.ContentType = "application/xml"
	Response.CharSet = CharSet

	If (Trim(Music_Name) = "") Then
		Response.Write(NoExsits(Music_Name))
		Response.End
	End If

        Dim djLrc
	djLrc = GetLyrics1(Music_Name)

'************************************************************************************************
        Function GetLyrics1(Byval Music_Name)  '获取数据库歌词文件
                Dim RS,Sql
                       Set RS = Server.CreateObject("ADODB.RecordSet")
                       Sql = "Select dj_lrc From [dj] Where dj_name = '" & Music_Name & "'"
		       RS.Open Sql, Conn, 1, 1
			     If (Not RS.Eof) Then GetLyrics1 = RS("dj_lrc")
                       RS.Close
		       Set RS = Nothing
                Conn.Close
		Set Conn = Nothing
        End Function
'************************************************************************************************

        Dim Lyrics
	Lyrics = GetLyrics(djLrc)
        Dim TagArrayTxt, LrcArrayTxt, EmtyLrc

        If (Lyrics <> "") Then
                Call GetArrayTxt(Lyrics)
                Response.Write(XMLOut())
        Else
                Response.Write(NoExsits(Music_Name))
        End If
	
'************************************************************************************************
	
	Function GetLyrics(Byval djLrc)

                Dim LrcFileObject, LrcTN, LrcFile

                Set LrcFileObject = Server.CreateObject("Scripting.FileSystemObject")

                If djLrc <> "" Then
                    LrcTN = Server.MapPath("" & djLrc & "")
                Else
                    LrcTN = Server.MapPath("Hxcms_V7.1") & "\" & djLrc & ".lrc"
                End If

                If LrcFileObject.FileExists(LrcTN) Then
                    Set LrcFile = LrcFileObject.OpenTextFile(LrcTN)
                            GetLyrics = LrcFile.ReadAll
                    LrcFile.Close
                End If

	End Function

'************************************************************************************************

	Function GetInfo(Byval Prefix, Byval Postfix, Byval SearchStr)	'获取两字符串间的字符
			
		Dim PrePos, PostPos, PreLen, PostLen

		PrePos = Instr(SearchStr, Prefix)
		PostPos = Instr(PrePos + 1, SearchStr, Postfix)

		If (PrePos = 0 Or PostPos = 0) Then
			GetInfo = ""
		Else
			PreLen = Len(Prefix)
			PostLen = Len(Postfix)
			GetInfo = Mid(SearchStr, PrePos + PreLen, PostPos - PrePos - PreLen)
		End If
		
	End Function

'************************************************************************************************

	Sub GetArrayTxt(Byval Lrc)	'获取时间和歌词对应数组并排序
	
		Dim RegExp, Pattern
		Dim Match, Matches
		Dim i, MatchNum
		Dim CurTag, NextTag, CurLrc

		Set RegExp = New RegExp
		Pattern = "\[\d+:\d+(\.\d+)?\]"
		RegExp.Pattern = Pattern
		RegExp.IgnoreCase = True
		RegExp.Global = True

		Set Matches = RegExp.Execute(Lrc)
		MatchNum = Matches.Count
		For i = 1 To MatchNum
			CurTag = Matches.Item(i - 1).Value
			If (i <> MatchNum) Then
				NextTag = Matches.Item(i).Value
			Else
				NextTag = ""
			End If
			TagArrayTxt = TagArrayTxt & "|" & Tag2Num(CurTag)
			CurLrc = GetLrcTxt(CurTag, NextTag, Lrc)
			If (CurLrc <> "") Then LrcArrayTxt = LrcArrayTxt & CurLrc
		Next

		TagArrayTxt = Mid(TagArrayTxt, 2)
		LrcArrayTxt = Mid(LrcArrayTxt, 4)

		Call FormatArrayTxt()

	End Sub

'************************************************************************************************

	Function Tag2Num(Byval TagStr)	'标签转换成数值

		Dim Pos1, Pos2
		Dim mi, se, ms

		TagStr = Replace(TagStr, "[", "")
		TagStr = Replace(TagStr, "]", "")
		Pos1 = Instr(TagStr, ":")
		Pos2 = Instr(TagStr, ".")
		mi = Left(TagStr, Pos1 - 1)
		If (Pos2 > 0) Then
			se = Mid(TagStr, Pos1 + 1, Pos2 - Pos1 - 1)
			ms = Mid(TagStr, Pos2 + 1)
			If (Len(ms) = 1) Then
 				ms = ms * 100
 			ElseIf (Len(ms) = 2) Then
			    ms = ms * 10
	   		End If
			Tag2Num = (mi * 60 + se) * 1000 + ms
		Else
			se = Mid(TagStr, Pos1 + 1)
			Tag2Num = (mi * 60 + se) * 1000
		End If

	End Function

'************************************************************************************************

	Function GetLrcTxt(Byval CurTag, Byval NextTag, Byval Lrc)	'获取歌词单句
		
		Dim RegExp, Pattern
		Dim StrPre, StrPost
		Dim Match, Matches
		Dim LrcTxt, i

		Set RegExp = New RegExp
		StrPre = Replace(CurTag, "[", "\[")
		StrPre = Replace(StrPre, ".", "\.")
		StrPre = Replace(StrPre, "]", "\]")
		If (NextTag = CurTag) Then
			StrPost = ""
		Else
			StrPost = Replace(NextTag, "[", "\[")
			StrPost = Replace(StrPost, ".", "\.")
			StrPost = Replace(StrPost, "]", "\]")
		End If
		Pattern = StrPre & "(.|\n)*" & StrPost
		RegExp.Pattern = Pattern
		RegExp.IgnoreCase = True
		RegExp.Global = True
		
		Set Matches = RegExp.Execute(Lrc)
		For Each Match In Matches
			LrcTxt = LrcTxt & Match.Value
		Next

		LrcTxt = FilterStr("\[[^\:]*\:[^\]]*\]", LrcTxt)
		If (LrcTxt <> "" Or NextTag = "") Then
			LrcTxt = FilterStr("(\n|\r)+(.|\n)*", LrcTxt)
			GetLrcTxt = "[:]" & LrcTxt
			If (EmtyLrc > 0) Then
				For i = 1 To EmtyLrc
					GetLrcTxt = GetLrcTxt & "[:]" & LrcTxt
				Next
				EmtyLrc = 0
			End If
		Else
			EmtyLrc = EmtyLrc + 1
			GetLrcTxt = ""
		End If

	End Function

'************************************************************************************************

	Function FilterStr(Byval Pattern, Byval Str)	'将无效标签[*:*]过滤掉
		
		Dim RegExp
		Dim Match, Matches
		Dim MatchStr

		Set RegExp = New RegExp
		RegExp.Pattern = Pattern
		RegExp.IgnoreCase = True
		RegExp.Global = True

		Str = RegExp.Replace(Str, "")

		FilterStr = Str

	End Function

'************************************************************************************************

	Sub FormatArrayTxt()	'排序

		Dim i, j, n, TagT, LrcT
		Dim TagArray, LrcArray

		TagArray = Split(TagArrayTxt, "|")
		LrcArray = Split(LrcArrayTxt, "[:]")

		n = UBound(TagArray)

		For i = 0 To n - 1
			For j = 0 To n - i - 1
				If (TagArray(j) - TagArray(j + 1) > 0) Then
					TagT = TagArray(j)
					TagArray(j) = TagArray(j + 1)
					TagArray(j + 1) = TagT
					LrcT = LrcArray(j)
					LrcArray(j) = LrcArray(j + 1)
					LrcArray(j + 1) = LrcT
				End If
			Next
		Next

		TagArrayTxt = TagArray(0)
		LrcArrayTxt = LrcArray(0)
        For i = 1 To n
			TagArrayTxt = TagArrayTxt & "|" & TagArray(i)
            LrcArrayTxt = LrcArrayTxt & "[:]" & LrcArray(i)
		Next

	End Sub

'************************************************************************************************

	Function XMLOut()	'XML输出

		Dim i, n
		Dim TagArray, LrcArray
		Dim XMLStr

		TagArray = Split(TagArrayTxt, "|")
		LrcArray = Split(LrcArrayTxt, "[:]")
		XMLStr = "<?xml version=""1.0"" encoding=""" & CharSet & """ standalone=""yes""?>" & VbCrLf
		XMLStr = XMLStr & "<!DOCTYPE MUSIC [" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT MUSIC (ARTIST, TITLE, LANGUAGE, EDITER, OFFSET, LYRICS)>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT ARTIST (#PCDATA)>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT TITLE (#PCDATA)>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT ALBUM (#PCDATA)>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT LANGUAGE (#PCDATA)>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT EDITER (#PCDATA)>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT OFFSET (#PCDATA)>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT LYRICS (LRC)*>" & VbCrLf
		XMLStr = XMLStr & "	<!ELEMENT LRC (#PCDATA)>" & VbCrLf
		XMLStr = XMLStr & "	<!ATTLIST LRC" & VbCrLf
		XMLStr = XMLStr & "		TAG CDATA #REQUIRED>" & VbCrLf
		XMLStr = XMLStr & "]>" & VbCrLf
		XMLStr = XMLStr & "<MUSIC>" & VbCrLf

		n = UBound(TagArray)
		
		XMLStr = XMLStr & "	<ARTIST>" & ReplaceStr(GetInfo("[ar:", "]", Lyrics)) & "</ARTIST>" & VbCrLf
		XMLStr = XMLStr & "	<TITLE>" & ReplaceStr(GetInfo("[ti:", "]", Lyrics)) & "</TITLE>" & VbCrLf
		XMLStr = XMLStr & "	<ALBUM>" & ReplaceStr(GetInfo("[al:", "]", Lyrics)) & "</ALBUM>" & VbCrLf
		XMLStr = XMLStr & "	<LANGUAGE>" & ReplaceStr(GetInfo("[la:", "]", Lyrics)) & "</LANGUAGE>" & VbCrLf
		XMLStr = XMLStr & "	<EDITER>" & ReplaceStr(GetInfo("[by:", "]", Lyrics)) & "</EDITER>" & VbCrLf
		XMLStr = XMLStr & "	<OFFSET>" & ReplaceStr(GetInfo("[offset:", "]", Lyrics)) & "</OFFSET>" & VbCrLf
		XMLStr = XMLStr & "	<LYRICS>" & VbCrLf
		For i = 0 To n
			XMLStr = XMLStr & "		<LRC TAG=""" & TagArray(i) & """>" & ReplaceStr(LrcArray(i)) & "</LRC>" & VbCrLf
		Next
		XMLStr = XMLStr & "	</LYRICS>" & VbCrLf
		XMLStr = XMLStr & "</MUSIC>"

		XMLOut = XMLStr

	End Function

'************************************************************************************************

	Function NoExsits(Byval Music_Name)	'不存在输出

		Dim LrcNoExsitsXML

		LrcNoExsitsXML = "<?xml version=""1.0"" encoding=""" & CharSet & """ standalone=""yes""?>" & VbCrLf
		LrcNoExsitsXML = LrcNoExsitsXML & "<!DOCTYPE MUSIC [" & VbCrLf
		LrcNoExsitsXML = LrcNoExsitsXML & "	<!ELEMENT MUSIC (#PCDATA)>" & VbCrLf
		LrcNoExsitsXML = LrcNoExsitsXML & "]>" & VbCrLf
		LrcNoExsitsXML = LrcNoExsitsXML & "<MUSIC>" & VbCrLf
                LrcNoExsitsXML = LrcNoExsitsXML & "	未能找到歌词 """ & ReplaceStr(Music_Name) & """" & VbCrLf
		LrcNoExsitsXML = LrcNoExsitsXML & "</MUSIC>" & VbCrLf
		
		NoExsits = LrcNoExsitsXML
	
	End Function

'************************************************************************************************

	Function ReplaceStr(Byval Str)	'替换干扰特殊实体"&"和"<"

		Str = Replace(Str, "&", "&amp;")
		ReplaceStr = Replace(Str, "<", "&lt;")

	End Function

'*********** 歌 *********** 词 ********** 函 ********** 数 *********** 结 *********** 束 ********
'****************************************************
' Hxcms Ver7.5       Power by Hx66.net
' Web: http://www.Hx66.net,http://www.Hx66.net/home
' Copyright (C) 2006 Hx66.net All Rights Reserved.
'****************************************************
%>