VB Lrc歌词解析源码

自己写的，如果以后有需要直接复制到模块，调用MainFun就行了，代码如下：
Option Explicit

Private Type TextAndTime
Text As String '输出的数据(无标签)
Time As Single  '分+秒=秒(一秒为单位)
End Type
Public LrcType() As TextAndTime '歌词数据管理
Public LrcTypeNum As Long 'Lrc数据数量
Private Offset As Long '延迟多少毫秒
'Lrc歌词文件解析
Public Sub MainFun(ByVal LrcText As String,ByVal TimeSecond As Single,OutText() As String,NextSong As Boolean) '主调解析(直接调用)
'LrcText=Lrc文本的全部数据 -> TimeSecond=现在已经播放到多少秒了 -> OutText=要输出的文本(上一句+现在) -> 是否是下一首歌了
Dim i As Long '循环(现在要显示的)
Dim MaxTime As Long '遍历的最大的时间(不超过正在播放的时间秒数)
Dim OutMaxTime As Long '输出的数组索引
Dim ii As Long '下一句要显示的
Dim MixTime As Long '记录最小的时间(超过正在播放的时间秒数)
Dim OutNextTime As Long '下一句要显示的
Dim OutMinTime As Long '输出的数组索引
If LrcText = "" Then 'Lrc为空
    Exit Sub '退出不显示
End If
If NextSong = False Then '还是这一首song
    MaxTime = -1
    For i = 0 To UBound(LrcType) '循环遍历数组(找出小于等于当前播放时间) 上一句
        If (LrcType(i).Time < TimeSecond) And (LrcType(i).Time > MaxTime) Then
            MaxTime = LrcType(i).Time '记录这个最合适的
            OutMinTime = i
        End If
    Next i
    '此时i为当前显示最合适的
    
    MixTime = 9999999
    For ii = 0 To UBound(LrcType) '循环遍历数组(当前时间秒数最大的与第二大的) 现在
        If (LrcType(ii).Time >= TimeSecond) And (LrcType(ii).Time < MixTime) Then
            MixTime = LrcType(ii).Time '记录这个最合适的
            OutMaxTime = ii
        End If
    Next ii
    MaxTime = 9999999
    For i = 0 To UBound(LrcType) '循环遍历数组(找出小于等于当前播放时间)  下一句
        If (LrcType(i).Time > TimeSecond) And (LrcType(i).Time < MaxTime) And (LrcType(i).Time > LrcType(OutMaxTime).Time) Then
            MaxTime = LrcType(i).Time '记录这个最合适的
            OutNextTime = i
        End If
    Next i
    
    '此时ii为下一句显示最合适的
    OutText(0) = LrcType(OutMinTime).Text '输出
    OutText(1) = LrcType(OutMaxTime).Text
    OutText(2) = LrcType(OutNextTime).Text
    Exit Sub
End If

'不是这一首了
LrcTypeNum = 0
Offset = 0 '延迟为0 Ms
'ReDim OutText(1) '重定义以免空间不足或者其他错误
Erase LrcType()
ReDim LrcType(0) '没有数据
OutText(0) = ""
OutText(1) = ""
OutText(2) = ""
'正式开始解析
LrcText = Replace(LrcText,".",":") '因为疏忽以为时间标签里面.为: 特在此替换全部
Call ManyLabelsCon(LrcText) '转换多标签为单标签
Do '循环处理
    Call FindAndConLabel(LrcText) '找出要处理的标签
Loop While (LrcText <> "") 'LrcText不为空就继续处理
'处理完毕
MaxTime = -1
For i = 0 To UBound(LrcType) '循环遍历数组(找出小于等于当前播放时间)
    If (LrcType(i).Time < TimeSecond) And (LrcType(i).Time > MaxTime) Then
        MaxTime = LrcType(i).Time '记录这个最合适的
        OutMaxTime = i
    End If
Next i
'此时i为当前显示最合适的
MixTime = 9999999
For ii = 0 To UBound(LrcType) '循环遍历数组(当前时间秒数最大的与第二大的)
    If (LrcType(ii).Time > TimeSecond) And (LrcType(ii).Time < MixTime) Then
        MixTime = LrcType(ii).Time '记录这个最合适的
        OutMinTime = ii
    End If
Next ii
'nexttime=
For i = 0 To UBound(LrcType) '循环遍历数组(找出小于等于当前播放时间)  现在
    If (LrcType(i).Time > TimeSecond) And (LrcType(i).Time < MaxTime) Then
        MaxTime = LrcType(i).Time '记录这个最合适的
        OutNextTime = i
    End If
Next i
'此时ii为下一句显示最合适的
OutText(0) = LrcType(OutMaxTime).Text '输出(上 中 下)
OutText(1) = LrcType(OutMinTime).Text
OutText(2) = LrcType(OutNextTime).Text
NextSong = False '现在是这一首了
End Sub

Private Sub FindAndConLabel(LrcText As String) '寻找和处理标签(包括多标签)
On Error Resume Next
'LrcText=Lrc文本的全部数据
Dim ConLabel As String '要处理的标签String([*.*]XXX)
Dim ConText As String '要处理的标签后面的Text(歌词)
'Call ManyLabelsCon(LrcText)  '处理多标签
ConLabel = "[" & MidEx(LrcText,"[","]") & "]"  '取出标签
If InStr(InStr(1,LrcText,vbTextCompare) + 1,vbTextCompare) = 0 Then '已经是最后一个标签了
    ConText = Right(LrcText,Len(LrcText) - InStr(1,"]",vbTextCompare))
    LrcText = ""
Else '还有标签
    ConText = MidEx(LrcText,"[") '取出歌词
End If
Call LabelCon(ConLabel & ConText) '解析标签
LrcText = Right(LrcText,Len(LrcText) - Len("[" & MidEx(LrcText,"["))) '将处理掉的歌词从处理列队中删除
End Sub

Private Sub LabelCon(ByVal LabelAndText As String)  '解析标签
On Error Resume Next
'LabelAndText=标签与标签后的文本
LrcTypeNum = LrcTypeNum + 1 '处理的标签数量+1
ReDim Preserve LrcType(LrcTypeNum) '加宽数据数组
'解析[]
Dim MidLabel As String '[]里面的(不含[])
MidLabel = MidEx(LabelAndText,"]") '取出Label里面的
If LabelAndText = "" Then '错误的标签
    Exit Sub
End If
'注释标签
If MidLabel = ":" Then '注释标签
    Exit Sub '退出过程
End If
'其他标签
If LCase(Left(MidLabel,6)) = "offset" Then '如果是延迟
    '取出并且设置延迟
    Offset = Val(Right(MidLabel,Len(MidLabel) - InStr(1,MidLabel,":",vbTextCompare)))
End If
If LCase(Left(MidLabel,2)) = "ti" Then '歌词标题
    
    Exit Sub
End If
If LCase(Left(MidLabel,2)) = "ar" Then '艺术家
    
    Exit Sub
End If
If LCase(Left(MidLabel,2)) = "al" Then '歌曲类型
    
    Exit Sub
End If
If LCase(Left(MidLabel,2)) = "by" Then '歌曲类型
    
    Exit Sub
End If
'时间标签=[mm:ss]/[mm:ss:ms]
'判断是哪一种
Dim TimeType() As String
TimeType = Split(MidLabel,vbTextCompare)
If UBound(TimeType) = 1 Then '第一种[mm:ss]
    LrcType(LrcTypeNum).Time = (Val(TimeType(0)) * 60) + (Val(TimeType(1))) + Val(Offset / 1000) 'mm*60+ss(+offset/1000)=ss
Else '第二种[mm:ss:ms]
    LrcType(LrcTypeNum).Time = Val((Val(TimeType(0)) * 60) + (Val(TimeType(1))) + (Val(TimeType(2)) / 1000) + Val(Offset / 1000)) 'mm*60+ss+ms/1000(+offset/1000)=ss
End If
LrcType(LrcTypeNum).Time = Format(LrcType(LrcTypeNum).Time,"0.000")
LrcType(LrcTypeNum).Text = Right(LabelAndText,Len(LabelAndText) - InStr(1,LabelAndText,vbTextCompare)) '获取歌词
End Sub

Private Sub ManyLabelsCon(LrcText As String) '将所有多标签替换为单标签
On Error Resume Next
'判断是否为多标签:判断]后面跟的是不是[就能判断是否为多标签
Dim LabelAndTextArg() As String '多标签+文本分割
Dim LabelCount As Long '标签数量
Dim LabelAndText As String '多标签+文本
Dim StartPlace,EndPlace,IfStartPlace As Long '多标签+文本开始位置([的位置) 结束位置(文本最后一个字符) 走到哪里
Dim i As Long
StartPlace = 1 '变量初始化
LabelCount = 1 '重置标签总数(设想下一个为单标签)
IfStartPlace = 1
EndPlace = 0
'LabelCount = 1 '至少有一个标签
'判断是否为多标签
StartPlace = InStr(StartPlace,vbTextCompare) '找到第一个[
IfStartPlace = StartPlace
Do
    If InStr(InStr(IfStartPlace,vbTextCompare) - IfStartPlace - (InStr(IfStartPlace,vbTextCompare) - IfStartPlace) = 1 Then  ']后面为[则为多标签
        LabelCount = LabelCount + 1 '标签总数+1
        If InStr(IfStartPlace + 1,vbTextCompare) <> 0 Then '再往后能找到]
            IfStartPlace = InStr(IfStartPlace + 1,vbTextCompare) '赋值
        Else '找不到]
            Exit Do '不find了
        End If
    Else ']后面不是[说明不是单标签或多标签结束
        If LabelCount <= 1 Then '单标签
            LabelCount = 1 '重置标签总数(设想下一个为单标签)
            StartPlace = InStr(StartPlace + 1,vbTextCompare) '跳过这个单标签 找到下一个[标签
            If StartPlace = 0 Then '没有标签了
                Exit Sub
            End If
            IfStartPlace = StartPlace
        Else '多标签(添加到数据管理里面并从LrcText中删除)
            EndPlace = InStr(IfStartPlace + 1,vbTextCompare) - 1 '最后一个字符为下一个标签的前一个字符
            If EndPlace = -1 - StartPlace Then '没有找到下面的标签(没有标签了)
                EndPlace = Len(LrcText)
            End If
            If EndPlace = -1 Then '没有找到下面的标签(没有标签了)
                EndPlace = Len(LrcText)
            End If
            '截取[XXX][XXX]...Text并储存
            LabelAndText = Mid(LrcText,StartPlace,EndPlace + 1 - StartPlace)  '取出标签
            '分解
            LabelAndTextArg() = Split(LabelAndText,vbTextCompare)
            For i = 0 To UBound(LabelAndTextArg) - 1 '遍历所有标签(此处-1表示不包括Text)
                LabelAndTextArg(i) = LabelAndTextArg(i) & "]" '补上丢失的]
                LabelAndTextArg(i) = MidEx(LabelAndTextArg(i),"]") '取出[]里面的
                If Left(LCase(LabelAndTextArg(i)),6) = "offset" Then '偏移
                    Offset = Val(Right(LabelAndTextArg(i),Len(LabelAndTextArg(i)) - InStr(1,LabelAndTextArg(i),vbTextCompare)))
                End If
                LrcTypeNum = LrcTypeNum + 1 '处理的标签数量+1
                ReDim Preserve LrcType(LrcTypeNum) '加宽数据数组
                Dim TimeType() As String
                TimeType = Split(LabelAndTextArg(i),vbTextCompare) '类型
                If UBound(TimeType) = 1 Then '第一种[mm:ss]
                    LrcType(LrcTypeNum).Time = (Val(TimeType(0)) * 60) + (Val(TimeType(1))) + Val(Offset / 1000) 'mm*60+ss(+offset/1000)=ss
                Else '第二种[mm:ss:ms]
                    LrcType(LrcTypeNum).Time = (Val(TimeType(0)) * 60) + (Val(TimeType(1))) + (Val(TimeType(2)) / 1000) + Val(Offset / 1000) 'mm*60+ss+ms/1000(+offset/1000)=ss
                End If
                LrcType(LrcTypeNum).Text = LabelAndTextArg(UBound(LabelAndTextArg)) '取出文本
            Next i
            '删除这个多标签
            LrcText = Left(LrcText,StartPlace - 1) & Right(LrcText,Len(LrcText) - EndPlace)
            '重置 向下查找其他多标签
            StartPlace = InStr(StartPlace,vbTextCompare) '重新找到第一个[
            IfStartPlace = StartPlace
            LabelCount = 1 '至少有一个标签
        End If
    End If
Loop While Not (InStr(IfStartPlace,vbTextCompare) = 0) '找不到最后的]就退出循环
End Sub

Private Function MidEx(ByVal LabelAndText As String,ByVal FirString As String,ByVal SecString As String) As String '取出指定文本
On Error Resume Next
Dim a As Long
a = InStr(1,FirString,vbTextCompare) + 1
MidEx = Mid(LabelAndText,a,InStr(a,SecString,vbTextCompare) - a)
End Function
原文链接：https://www.f2er.com/vb/258473.html
VB Lrc歌词解析源码

猜你在找的VB相关文章
