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) '检查换行符:
,/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), "
") If s1 > 0 Then Temp = Split(Subtitles(LineCount), "
") 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 "") Subtitles(LineCount) = GetXMLCodeValue(Subtitles(LineCount), ByVal "") Subtitles(LineCount) = GetXMLCodeValue(Subtitles(LineCount), ByVal "") 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), "") If LCase(SrtXMLcode) = "color=" Then p2 = InStr(1, sSrt(LineCount), "") 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), "") If LCase(SrtXMLcode) = "color=" Then j = InStr(1, sSrt(i), "") 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