VB解析SRT、SSA、ASS字幕文件，以实现视频外挂字幕

上篇文章《VB编写程序实现视频外挂SRT字幕》(http://blog.csdn.net/chenjl1031/archive/2010/03/01/5337289.aspx)，只写了解决SRT字幕文件。这次把三种格式（SRT，SSA，ASS）都柔和在一起，没有分别编写，在上篇文章基础上直接改的。SSA和ASS特效代码有很多相同的地方，其中ASS特效代码80%与SSA相同，只提取VB能够处理的基本信息，其余的特效代码VB不好办，全部扔掉。在试验中发现有的字幕文件编码是Uncode格式，有的是UTF-8编码格式，有的是Ansi编码格式，在这方面作了识别，以便VB能够正确处理。下面是解析这三种字幕文件的全部程序：

Option Explicit
Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const UTF8FT As Long = 65001 '代码页

'SRT,SSA,ASS字幕提取，SubtitlesFilesName为字幕文件名
Public Function SubtitlesFileAnalysis(ByVal SubtitlesFilesName As String) As Long

Dim GetFileExtendName As String '取得文件的扩展名
Dim FileByte() As Byte '存放字幕文件字节
Dim strBuffer As String, UTF8Size As Long, BufferSize As Long, UTF8Result As Long
Dim LineCount As Long, FileNumber As Long, TimeLenth As Long, TimeNumber As Long
Dim Stitle As String, TimeLabel(1 To 2) As String, St As String, StC As String
Dim Fbyte() As Byte, Temp() As String, sTime() As String, TT() As String, sTT() As String '临时数组
Dim tStyle() As String, sStyle() As String '缺省的字幕信息和自定义字幕信息
Dim V4StyleFormat As String, EventsFormat As String '缺省的字幕格式和对话事件格式
Dim sName As String, sFontname As String, sFontsize As String, sPrimaryColour As String, sBold As String, sItalic As String, sUnderline As String '从V4+Styles中取出的字体信息
Dim DefaultFontIfo As String '缺省的字体信息
Dim StartPosition As Long ', EndPo As Long, StylePo As Long, TextPo As Long '记录开始时间，结束时间，样式，字幕文本起始位置
Dim sHour As Long, sMunite As Long, sSecond As Long, s1 As Long, s2 As Long, s3 As Long, s4 As Long
Dim GotTime As Boolean

On Error Resume Next

'缺省的字体信息:fn字体类型，fs字体大小，fc字体颜色，fp字体位置，fi斜体，fu下划线，fb粗体
DefaultFontIfo = "[fn=黑体][fs=24][fc=&HFFFFFF][fp=2][fi=0][fu=0][fb=0] "
sUnderline = "0"
If Dir(SubtitlesFilesName) = "" Or FileLen(SubtitlesFilesName) = 0 Then SubtitlesFileAnalysis = 0: Exit Function '字幕不存在即退出
GetFileExtendName = Mid$(SubtitlesFilesName, 1 + InStrRev(SubtitlesFilesName, "."), Len(SubtitlesFilesName) - InStrRev(SubtitlesFilesName, "."))
Debug.Print GetFileExtendName
'确定字幕文件编码格式，并将字幕文本导入到临时数组TT中
FileNumber = FreeFile
Open SubtitlesFilesName For Binary As #FileNumber
ReDim FileByte(LOF(FileNumber) - 1), Fbyte(LOF(FileNumber) - 1)
Get #FileNumber, , FileByte
Close #FileNumber
If (Hex$(FileByte(0)) = "FF" And Hex$(FileByte(1)) = "FE") Or (Hex$(FileByte(0)) = "FE" And Hex$(FileByte(1)) = "FF") Then
If Hex$(FileByte(0)) = "FF" Then
'字幕文件为Unicode（Little Endian）编码
Stitle = StrConv(FileByte, vbNarrow)
End If
If Hex$(FileByte(0)) = "FE" Then
'字幕文件为Unicode Big Endian编码
For s1 = 0 To UBound(FileByte)
If s1 Mod 2 = 0 Then
Fbyte(s1) = FileByte(s1 + 1)
Else
Fbyte(s1) = FileByte(s1 - 1)
End If
Next
Stitle = StrConv(Fbyte, vbNarrow)
End If
Mid$(Stitle, 1, 1) = " ": Stitle = Trim(Stitle)
Else
If (Hex$(FileByte(0)) = "EF" And Hex$(FileByte(1)) = "BB" And Hex$(FileByte(2)) = "BF") Then
'字幕文件为UTF-8编码
UTF8Size = UBound(FileByte) + 1
BufferSize = MultiByteToWideChar(UTF8FT, 0&, FileByte(0), UTF8Size, 0&, 0&)
strBuffer = String$(BufferSize, vbNullChar)
UTF8Result = MultiByteToWideChar(UTF8FT, 0&, FileByte(0), UTF8Size, StrPtr(strBuffer), BufferSize)
If UTF8Result > 0 Then
Stitle = Left$(strBuffer, UTF8Result)
Mid$(Stitle, 1, 1) = " ": Stitle = Trim(Stitle)
Else
Exit Function
End If
Else
'字幕文件为Ansi编码，或其它非Unicode、UTF-8编码格式
Stitle = StrConv(FileByte, vbUnicode)
End If
End If
Erase FileByte, Fbyte '释放动态数组所使用的内存
Temp = Split(Stitle, vbCrLf) '导出的全部字幕文本

'扫描对话字幕个数并定义字幕数组
LineCount = 1: s2 = 0
'srt字幕
If LCase(GetFileExtendName) = "srt" Then
For s1 = 0 To UBound(Temp)
If InStr(1, Temp(s1), "-->") > 0 Then LineCount = LineCount + 1
Next
SubtitlesFileAnalysis = LineCount - 1 '确定srt字幕个数
ReDim Subtitles(1 To LineCount - 1) '定义srt字幕数组
End If
'ssa,ass字幕
If LCase(GetFileExtendName) = "ssa" Or LCase(GetFileExtendName) = "ass" Then
For s1 = 0 To UBound(Temp)
If InStr(1, Temp(s1), "Dialogue:") > 0 Then LineCount = LineCount + 1
If InStr(1, Temp(s1), "Style:") > 0 Then s2 = s2 + 1
If InStr(1, Temp(s1), "Format:") > 0 Then
If InStr(1, Temp(s1), "Encoding") > 0 Then
V4StyleFormat = Trim(Replace(Temp(s1), "Format:", Space(7)))
End If
If InStr(1, Temp(s1), "Marked") > 0 Or InStr(1, Temp(s1), "Layer") > 0 Then
EventsFormat = Temp(s1)
End If
End If
Next
SubtitlesFileAnalysis = LineCount - 1 '确定ssa,ass字幕个数
ReDim Subtitles(1 To LineCount - 1) '定义ssa,ass字幕数组
ReDim sStyle(1 To s2)  '定义style预设样式的个数
ReDim tStyle(1 To LineCount - 1) '字幕中使用的预设样式名
End If

If SubtitlesFileAnalysis = 0 Then Exit Function

'取得ssa,ass字幕预设样式
s2 = 0
If LCase(GetFileExtendName) = "ssa" Or LCase(GetFileExtendName) = "ass" Then
For s1 = 0 To UBound(Temp)
If InStr(1, Temp(s1), "Style:") > 0 Then s2 = s2 + 1: sStyle(s2) = Trim(Replace(Temp(s1), "Style:", Space(6)))
If InStr(1, Temp(s1), "[Events]") > 0 Then Exit For
Next
End If

'提取srt对话字幕和显示时间
If LCase(GetFileExtendName) = "srt" Then
LineCount = 1: GotTime = False
For s1 = 0 To UBound(Temp)
Stitle = Trim(Temp(s1)) '提取srt字幕标签
If GotTime Then '取到一个时间标签后，记录当前时间标签下的所有字幕文本
If Len(Stitle) = 0 Or IsNumeric(Stitle) = True Then '碰到一空行或代表字幕个数的数字时
'进入下一个字幕之前，记录当前字幕
GotTime = False '已经提取完第LineCount个字幕
If Len(St) = 0 Then St = Space(10) ': Debug.Print Stitle
Subtitles(LineCount) = TimeLabel(1) & " [StartTime] " & TimeLabel(2) & " [EndTime] " & St '加上时间标签头
Subtitles(LineCount) = Trim(Left(Subtitles(LineCount), Len(Subtitles(LineCount)) - 6)) '去掉最后一个“-CRLF-”
St = "": LineCount = LineCount + 1 '记录字幕序号
Else
If Len(Stitle) <> 0 Then St = St & (Stitle & "-CRLF-") 'CRLF回车换行
End If
End If

'判断并提取时间标签
TimeLenth = InStr(1, Stitle, "-->")
If TimeLenth > 0 Then
TT = Split(Stitle, "-->")
TimeLabel(1) = TT(0) '字幕显示开始时间
sTime = Split(TimeLabel(1), ":")
sHour = CLng(sTime(0)) * 3600000
sMunite = CLng(sTime(1)) * 60000
sSecond = CLng(sTime(2))
TimeLabel(1) = CStr(sHour + sMunite + sSecond)

TimeLabel(2) = TT(1) '字幕显示结束时间
sTime = Split(TimeLabel(2), ":")
sHour = CLng(sTime(0)) * 3600000
sMunite = CLng(sTime(1)) * 60000
sSecond = CLng(sTime(2))
TimeLabel(2) = CStr(sHour + sMunite + sSecond)

GotTime = True '已经取到一个时间标签
End If
'DoEvents
Next
'提取最后一个字幕
Subtitles(LineCount) = TimeLabel(1) & " [StartTime] " & TimeLabel(2) & " [EndTime] " & Subtitles(LineCount) & St '加上时间标签头
Subtitles(LineCount) = Trim(Left(Subtitles(LineCount), Len(Subtitles(LineCount)) - 6))
End If

'提取ssa,ass对话字幕和显示时间
If LCase(GetFileExtendName) = "ssa" Or LCase(GetFileExtendName) = "ass" Then
TT = Split(EventsFormat, ",")
LineCount = 0
For s1 = 0 To UBound(Temp)
If InStr(1, Temp(s1), "Dialogue:") > 0 Then
LineCount = LineCount + 1
sTT = Split(Temp(s1), ",")
For s2 = 0 To UBound(TT)
If Trim(TT(s2)) = "Start" Then
TimeLabel(1) = Trim(sTT(s2)) '字幕显示开始时间
sTime = Split(TimeLabel(1), ":")
sHour = CLng(sTime(0)) * 3600000
sMunite = CLng(sTime(1)) * 60000
sSecond = CLng(Val(sTime(2)) * 1000)
TimeLabel(1) = CStr(sHour + sMunite + sSecond)
End If
If Trim(TT(s2)) = "End" Then
TimeLabel(2) = Trim(sTT(s2)) '字幕显示结束时间
sTime = Split(TimeLabel(2), ":")
sHour = CLng(sTime(0)) * 3600000
sMunite = CLng(sTime(1)) * 60000
sSecond = CLng(Val(sTime(2)) * 1000)
TimeLabel(2) = CStr(sHour + sMunite + sSecond)
End If
If Trim(TT(s2)) = "Style" Then
tStyle(LineCount) = Trim(sTT(s2)) '字幕预设样式
End If
If Trim(TT(s2)) = "Text" Then
St = Temp(s1)
Mid$(St, 1, InStr(1, Temp(s1), sTT(s2)) - 1) = Space(InStr(1, Temp(s1), sTT(s2)) - 1)
St = Trim(St)
End If
Next
Subtitles(LineCount) = tStyle(LineCount) & " [Style] " & TimeLabel(1) & " [StartTime] " & TimeLabel(2) & " [EndTime] " & St '加上时间标签头
End If
Next
End If
Erase Temp, sTime, TT, sTT, tStyle '释放动态数组所使用的内存

'检查SRT,SSA,ASS字幕特效代码
For LineCount = 1 To UBound(Subtitles)
'检查换行符:<br>,/N；空格符：/n,/h。这样的符号一行字幕可能有多个。
St = ""
s1 = InStr(1, Subtitles(LineCount), "/N")
If s1 > 0 Then
Temp = Split(Subtitles(LineCount), "/N")
For s2 = 0 To UBound(Temp)
If Len(Trim(Temp(s2))) <> 0 Then St = St & (Temp(s2) & "-CRLF-")
Next
Subtitles(LineCount) = St
Subtitles(LineCount) = Trim(Left(Subtitles(LineCount), Len(Subtitles(LineCount)) - 6)) '去掉最后一个“-CRLF-”
End If
St = ""
s1 = InStr(1, Subtitles(LineCount), "<br>")
If s1 > 0 Then
Temp = Split(Subtitles(LineCount), "<br>")
For s2 = 0 To UBound(Temp)
If Len(Trim(Temp(s2))) <> 0 Then St = St & (Temp(s2) & "-CRLF-")
Next
Subtitles(LineCount) = St
Subtitles(LineCount) = Trim(Left(Subtitles(LineCount), Len(Subtitles(LineCount)) - 6)) '去掉最后一个“-CRLF-”
End If
St = ""
s1 = InStr(1, Subtitles(LineCount), "/n")
If s1 > 0 Then
Temp = Split(Subtitles(LineCount), "/n")
For s2 = 0 To UBound(Temp)
If Len(Trim(Temp(s2))) <> 0 Then St = St & Temp(s2)
Next
Subtitles(LineCount) = Trim(St)
End If
St = ""
s1 = InStr(1, Subtitles(LineCount), "/h")
If s1 > 0 Then
Temp = Split(Subtitles(LineCount), "/h")
For s2 = 0 To UBound(Temp)
If Len(Trim(Temp(s2))) <> 0 Then St = St & Temp(s2)
Next
Subtitles(LineCount) = Trim(St)
End If
Erase Temp '释放动态数组所使用的内存

'初始化缺省的字体信息DefaultFontIfo,其余特效代码一律扔掉。
If InStr(1, Subtitles(LineCount), "-CRLF-") > 0 Then
Temp = Split(Subtitles(LineCount), "-CRLF-")
s2 = InStr(1, Temp(0), "[EndTime]")
St = Left$(Temp(0), s2 + 8) & DefaultFontIfo & Right$(Temp(0), Len(Temp(0)) - s2 - 8)
For s1 = 1 To UBound(Temp)
St = St & (" -CRLF- " & DefaultFontIfo & Temp(s1)) '& " -CRLF- ")
Next
Else
s2 = InStr(1, Subtitles(LineCount), "[EndTime]")
If Len(Subtitles(LineCount)) - s2 - 8 >= 0 Then
St = Left$(Subtitles(LineCount), s2 + 8) & DefaultFontIfo & Right$(Subtitles(LineCount), Len(Subtitles(LineCount)) - s2 - 8)
End If
End If
Subtitles(LineCount) = St: Erase Temp '初始化完毕Subtitles(LineCount)，'释放动态数组Temp所使用的内存
If LCase(GetFileExtendName) = "ssa" Or LCase(GetFileExtendName) = "ass" Then
TT = Split(V4StyleFormat, ",")
For s1 = 1 To UBound(sStyle)
sTT = Split(sStyle(s1), ",")
For s2 = 0 To UBound(TT)
If Trim(TT(s2)) = "Name" Then sName = Trim(sTT(s2)) '取出样式名称
If Trim(TT(s2)) = "Fontname" Then sFontname = Trim(sTT(s2)) '取出字体名称
If Trim(TT(s2)) = "Fontsize" Then sFontsize = Trim(sTT(s2)) '取出字体大小
If Trim(TT(s2)) = "PrimaryColour" Then sPrimaryColour = "&H" & Hex$(CLng(sTT(s2))) '取出主体字体颜色
If Trim(TT(s2)) = "Bold" Then sBold = CStr(Abs(sTT(s2))) '取出字体粗体设置
If Trim(TT(s2)) = "Italic" Then sItalic = CStr(Abs(sTT(s2))) '取出字体斜体设置
If Trim(TT(s2)) = "Underline" Then sUnderline = CStr(Abs(sTT(s2)))  '取出字体下划线设置
Next
StartPosition = InStr(1, Subtitles(LineCount), "[Style]")
St = Mid$(Subtitles(LineCount), 1, StartPosition - 1)
If (sName Like St) = True Or (InStr(1, St, sName) > 0) Then
Subtitles(LineCount) = Inifontifo(Subtitles(LineCount), DefaultFontIfo, "[fn=", sFontname)
Subtitles(LineCount) = Inifontifo(Subtitles(LineCount), DefaultFontIfo, "[fs=", sFontsize)
Subtitles(LineCount) = Inifontifo(Subtitles(LineCount), DefaultFontIfo, "[fc=", sPrimaryColour)
Subtitles(LineCount) = Inifontifo(Subtitles(LineCount), DefaultFontIfo, "[fb=", sBold)
Subtitles(LineCount) = Inifontifo(Subtitles(LineCount), DefaultFontIfo, "[fi=", sItalic)
Subtitles(LineCount) = Inifontifo(Subtitles(LineCount), DefaultFontIfo, "[fu=", sUnderline)
Mid$(Subtitles(LineCount), 1, StartPosition + 7) = Space(StartPosition + 7)
'Debug.Print "Subtitles(" & LineCount & ") =" & Trim(Subtitles(LineCount))
End If
Next
End If
Next

'检查所用字体、字号、颜色、位置等信息
For LineCount = 1 To UBound(Subtitles)
If InStr(1, Subtitles(LineCount), "-CRLF-") > 0 Then
'以下是多行字幕情形
Temp = Split(Subtitles(LineCount), "-CRLF-")
For s1 = 0 To UBound(Temp)
St = "/fn": StC = "[fn="
Temp(s1) = Insert_String(Temp(s1), St, StC, 5)

St = "/fs": StC = "[fs="
Temp(s1) = Insert_String(Temp(s1), St, StC, 5)

St = "/c": StC = "[fc="
Temp(s1) = Insert_String(Temp(s1), St, StC, 11)

St = "/a": StC = "[fp="
Temp(s1) = Insert_String(Temp(s1), St, StC, 4)

St = "/i": StC = "[fi="
Temp(s1) = Insert_String(Temp(s1), St, StC, 4)

St = "/u": StC = "[fu="
Temp(s1) = Insert_String(Temp(s1), St, StC, 4)

St = "/b": StC = "[fb="
Temp(s1) = Insert_String(Temp(s1), St, StC, 4)
Next
For s1 = 0 To UBound(Temp)
St = Temp(0)
For s3 = 1 To UBound(Temp) '合并字幕
St = St & (" -CRLF- " & Temp(s3))
Next
Subtitles(LineCount) = St
Next
Else
'以下是单行字幕情形
St = "/fn": StC = "[fn="
Subtitles(LineCount) = Insert_String(Subtitles(LineCount), St, StC, 5)

St = "/fs": StC = "[fs="
Subtitles(LineCount) = Insert_String(Subtitles(LineCount), St, StC, 5)

St = "/c": StC = "[fc="
Subtitles(LineCount) = Insert_String(Subtitles(LineCount), St, StC, 11)

St = "/a": StC = "[fp="
Subtitles(LineCount) = Insert_String(Subtitles(LineCount), St, StC, 4)

St = "/i": StC = "[fi="
Subtitles(LineCount) = Insert_String(Subtitles(LineCount), St, StC, 4)

St = "/u": StC = "[fu="
Subtitles(LineCount) = Insert_String(Subtitles(LineCount), St, StC, 4)

St = "/b": StC = "[fb="
Subtitles(LineCount) = Insert_String(Subtitles(LineCount), St, StC, 4)

End If
Erase Temp '释放动态数组所使用的内存
Subtitles(LineCount) = GetXMLCodeValue(Subtitles(LineCount), ByVal "<i>")
Subtitles(LineCount) = GetXMLCodeValue(Subtitles(LineCount), ByVal "<u>")
Subtitles(LineCount) = GetXMLCodeValue(Subtitles(LineCount), ByVal "<b>")
Subtitles(LineCount) = GetXMLCodeValue(Subtitles(LineCount), ByVal "color=")
Subtitles(LineCount) = DeleEffectCode(Subtitles(LineCount), ByVal "<", ByVal ">")
Subtitles(LineCount) = DeleEffectCode(Subtitles(LineCount), ByVal "{", ByVal "}")
Form1.List1.AddItem "Subtitles(" & LineCount & ")=" & Subtitles(LineCount)
'DoEvents
Next

'Form1.Text1.Text = "用时:" & Format$((CDbl(t2 - t1) / 1000), "0.000") & "秒"
End Function

'初始化字体信息
Private Function Inifontifo(ByVal TitleText As String, ByVal DefaultFontIfo As String, ByVal Font1 As String, ByVal Font2 As String) As String

'TitleText:传入的字幕文本;DefaultFontIfo:传入的自定义缺省字体信息
'Font1:传入的自定义符号;Font2:传入从V4+Styles中读取的字体信息
Dim i As Long, p1 As Long, p2 As Long, St As String, Temp() As String
If Len(TitleText) = 0 Then Inifontifo = "": Exit Function
p1 = InStr(1, DefaultFontIfo, Font1): p2 = InStr(p1 + 1, DefaultFontIfo, "]")
St = Mid$(DefaultFontIfo, p1, p2 - p1 + 1)
Temp = Split(TitleText, St): Inifontifo = ""
For i = 0 To UBound(Temp)
If i <> UBound(Temp) Then
Inifontifo = Inifontifo & (Temp(i) & Font1 & Font2 & "]")
Else
Inifontifo = Inifontifo & Temp(i)
End If
Next
End Function

'取出字符串中SRT、SSA、ASS特效字符串，插入自定义特效字符串
Private Function Insert_String(ByVal SourceSubtitles As String, ByVal SrtEffectCode As String, ByVal SrtCode As String, ByVal LEffect As Long) As String
Dim s1 As Long, s2 As Long, s3 As Long, St As String, S As String, Temp() As String
Dim p1 As Long, p2 As Long
If Len(Trim(SourceSubtitles)) = 0 Then Insert_String = Space(10): Exit Function
s1 = 0
On Error Resume Next
Cjl:
s1 = InStr(s1 + 1, SourceSubtitles, SrtEffectCode)
If SrtEffectCode = "/b" And s1 > 0 Then
'不处理边角模糊、字体加宽
If Mid$(SourceSubtitles, s1, 3) = "/be" Or Mid$(SourceSubtitles, s1, 5) = "/bord" Then GoTo Cjl
End If
If SrtEffectCode = "/fs" And s1 > 0 Then
'不处理字体缩放、字间距
If Mid$(SourceSubtitles, s1, 4) = "/fsc" Or Mid$(SourceSubtitles, s1, 4) = "/fsp" Then GoTo Cjl
End If
If SrtEffectCode = "/a" And s1 > 0 Then
'不处理alpha透明度
If Mid$(SourceSubtitles, s1, 6) = "/alpha" Then GoTo Cjl
End If
s3 = Len(SrtEffectCode)
If s1 > 0 Then
s2 = InStr(s1 + 1, SourceSubtitles, "/") 's2是紧接SrtEffectCode下一个"/"的位置
If s2 > 0 Then
St = Mid$(SourceSubtitles, s1 + s3, s2 - s1 - s3)
If InStr(1, St, "{") > 0 Then Mid$(St, InStr(1, St, "{"), 1) = " "
If InStr(1, St, "}") > 0 Then Mid$(St, InStr(1, St, "}"), 1) = " "
St = Trim(St)
Else
s2 = InStr(s1 + 1, SourceSubtitles, "}")
If s2 > 0 Then
St = Mid$(SourceSubtitles, s1 + s3, s2 - s1 - s3)
End If
End If
p1 = InStr(1, SourceSubtitles, SrtCode)
p2 = InStr(p1 + 1, SourceSubtitles, "]")
S = Mid$(SourceSubtitles, p1, p2 - p1 + 1)
Temp = Split(SourceSubtitles, S)
Insert_String = Temp(0) & SrtCode & St & "]" & Temp(1)
Else
Insert_String = SourceSubtitles
End If
End Function

'取得字幕中类似XML代码的值，srt字幕中常见，ssa,ass字幕中不常见
Private Function GetXMLCodeValue(ByVal SourceSubtitles As String, ByVal SrtXMLcode As String) As String
Dim LineCount As Long, sSrt() As String
Dim p1 As Long, p2 As Long, P3 As Long, CO As String, St As String
Dim Pc1 As Long, Pc2 As Long
Dim i As Long, j As Long, K As Long

On Error Resume Next

If InStr(1, SourceSubtitles, "-CRLF-") > 0 Then
If InStr(1, SourceSubtitles, SrtXMLcode) > 0 Then
sSrt = Split(SourceSubtitles, "-CRLF-")
'ReDim sSrt_1(UBound(sSrt))
For LineCount = 0 To UBound(sSrt)
p1 = InStr(1, sSrt(LineCount), SrtXMLcode)
St = Mid$(LCase(SrtXMLcode), 2, 1): p2 = InStr(1, sSrt(LineCount), "</" & St & ">")
If LCase(SrtXMLcode) = "color=" Then
p2 = InStr(1, sSrt(LineCount), "</font>")
If InStr(1, sSrt(LineCount), "color=") > 0 Then
Pc1 = InStr(1, sSrt(LineCount), "color="): Pc2 = InStr(Pc1 + 6, sSrt(LineCount), ">")
CO = Mid$(sSrt(LineCount), Pc1 + 6, Pc2 - Pc1 - 6)
If InStr(1, CO, Chr$(34)) > 0 Then CO = "&H" & Mid$(CO, 2, Len(CO) - 2)
If InStr(1, CO, "#") > 0 Then CO = "&H" & Right$(CO, Len(CO) - InStr(1, CO, "#"))
End If
End If
K = LineCount
If p1 > 0 Then
St = Mid$(LCase(SrtXMLcode), 2, 1): P3 = InStr(1, sSrt(K), "f" & St & "="): Mid$(sSrt(K), P3 + 3, 1) = "1"
If LCase(SrtXMLcode) = "color=" Then
Pc1 = InStr(1, sSrt(K), "fc="): Pc2 = InStr(1, sSrt(K), "][fp")
sSrt(K) = Left$(sSrt(K), Pc1 + 2) & CO & Right$(sSrt(K), Len(sSrt(K)) - Pc2 + 1)
End If
If p2 > 0 Then
GoTo Cjl
Else
For i = LineCount + 1 To UBound(sSrt)
St = Mid$(LCase(SrtXMLcode), 2, 1): j = InStr(1, sSrt(i), "</" & St & ">")
If LCase(SrtXMLcode) = "color=" Then j = InStr(1, sSrt(i), "</font>")
K = i
St = Mid$(LCase(SrtXMLcode), 2, 1): P3 = InStr(1, sSrt(K), "f" & St & "="): Mid$(sSrt(K), P3 + 3, 1) = "1"
If LCase(SrtXMLcode) = "color=" Then
Pc1 = InStr(1, sSrt(K), "fc="): Pc2 = InStr(1, sSrt(K), "][fp")
sSrt(K) = Left$(sSrt(K), Pc1 + 2) & CO & Right$(sSrt(K), Len(sSrt(K)) - Pc2 + 1)
End If
If j > 0 Then Exit For
Next
End If
End If
Cjl:          '执行下一次循环
Next

St = sSrt(0)
For i = 1 To UBound(sSrt) '合并字幕
St = St & (" -CRLF- " & sSrt(i))
Next
Erase sSrt
GetXMLCodeValue = St
Else
GetXMLCodeValue = SourceSubtitles
End If

Else
If InStr(1, SourceSubtitles, SrtXMLcode) > 0 Then
St = Mid$(LCase(SrtXMLcode), 2, 1): p1 = InStr(1, SourceSubtitles, "f" & St & "="): Mid$(SourceSubtitles, p1 + 3, 1) = "1"
If LCase(SrtXMLcode) = "color=" Then
p1 = InStr(1, SourceSubtitles, "color="): p2 = InStr(p1 + 6, SourceSubtitles, ">")
CO = Mid$(SourceSubtitles, p1 + 6, p2 - p1 - 6)
If InStr(1, CO, Chr$(34)) > 0 Then CO = "&H" & Mid$(CO, 2, Len(CO) - 2)
If InStr(1, CO, "#") > 0 Then CO = "&H" & Right$(CO, Len(CO) - InStr(1, CO, "#"))
p1 = InStr(1, SourceSubtitles, "fc="): p2 = InStr(1, SourceSubtitles, "][fp")
SourceSubtitles = Left$(SourceSubtitles, p1 + 2) & CO & Right$(SourceSubtitles, Len(SourceSubtitles) - p2 + 1)
End If
GetXMLCodeValue = SourceSubtitles
Else
GetXMLCodeValue = SourceSubtitles
End If
End If

End Function

'去掉所有SRT、SSA、ASS字幕特效代码
Private Function DeleEffectCode(ByVal SourceSubtitles As String, ByVal StartCh As String, ByVal EndCh As String) As String

Dim p1 As Long, p2 As Long, PS As Long
Dim S As String, St As String, L As Long, aTT() As String
On Error Resume Next

PS = 1
Do While InStr(PS, SourceSubtitles, StartCh) > 0
p1 = InStr(PS, SourceSubtitles, StartCh)
p2 = InStr(p1 + 1, SourceSubtitles, EndCh)
Mid$(SourceSubtitles, p1, p2 - p1 + 1) = String(p2 - p1 + 1, "^")
PS = p2 + 1
'DoEvents
Loop
aTT = Split(SourceSubtitles, "^")
For L = 0 To UBound(aTT)
If Len(Trim(aTT(L))) <> 0 Then St = St & aTT(L)
Next
DeleEffectCode = Trim(St)

End Function