Question

通过char检查char中单元格内文本的样式是非常低效的。有没有其他方法可以追踪它？

反映核心问题的样本：

' omitted code of a function that receives a Cell as Range
For iChar = 1 To nChars
    Set Char = rnIn.Characters(iChar, 1)
    With Char.Font
            blnNoneActive = Not .Bold And Not .Italic And Not .Underline
            Changed = trackStyle(stNone, blnNoneActive, rnIn, iChar, colActiveStyles, colToActive, colToInactive)
            Changed = Changed Or trackStyle(stBold, .Bold, rnIn, iChar, colActiveStyles, colToActive, colToInactive)
            Changed = Changed Or trackStyle(stItalics, .Italic, rnIn, iChar, colActiveStyles, colToActive, colToInactive)
            blnUnderline = Not (.Underline = xlUnderlineStyleNone)
            Changed = Changed Or trackStyle(stUnderline, blnUnderline, rnIn, iChar, colActiveStyles, colToActive, colToInactive)
    End With
    ' Omitted code
Next

修改

我在想，也许直接访问文件格式有助于获得内嵌字体格式的快捷方式。这可能吗？

Answer 1

cellRange.Value(11)与Regexp结合使用，就像Slai在问题评论中所建议的那样。

对于触发查询的情况，此解决方案的工作速度足够快。在这里分享给出一些指示。希望能帮助别人。

用法，在单元格公式中：=ToMarkdown(A1)

Option Explicit

' Pre-markdown 
Const bold_start = "_B_"
Const bold_end = "_nB_"
Const italics_start = "_I_"
Const italics_end = "_nI_"
Const under_start = "_U_"
Const under_end = "_nU_"

' Final Markdown
Const ch_bold = "**"
Const ch_italics = "_"
Const ch_u_start = "<_" ' underline start
Const ch_u_end = "_>"   ' underline end


Private pCache As Collection
Public pCachedRegexes As Object

Private Sub Class_Initialize()
 Set pCache = New Collection
End Sub

' Markdown only works when using Source as range
Public Function ToMarkdown(Source) As String
Dim rnIn As Range
Dim strXML_Source As String, strXML_Out As String
Dim strPreMarkdown As String
 On Error Resume Next

 If TypeName(Source) = "String" Then ToMarkdown = Source : Exit Function
 If Not (TypeName(Source) = "Range") Then Exit Function
 ' option only available if a Range has been provided
 Set rnIn = Source
 ToMarkdown = rnIn.Value

 ' save
 strXML_Source = rnIn.Value(11)
 strXML_Out = ReplaceXML_ByPreMarkdown(strXML_Source)

 Application.EnableEvents = False
 rnIn.Value(11) = strXML_Out
 strPreMarkdown = rnIn.Value
 ' restore
 rnIn.Value(11) = strXML_Source
 Application.EnableEvents = True

 ToMarkdown = ToFinalMarkdown(strPreMarkdown)
End Function

Private Function ReplaceXML_ByPreMarkdown(ByVal strXML As String) As String
Dim strPat As String
 On Error Resume Next

 strXML = Replace(strXML, "<B>", bold_start, Compare:=vbDatabaseCompare)
 strXML = Replace(strXML, "</B>", bold_end, Compare:=vbDatabaseCompare)
 strXML = Replace(strXML, "<I>", italics_start, Compare:=vbDatabaseCompare)
 strXML = Replace(strXML, "</I>", italics_end, Compare:=vbDatabaseCompare)
 strXML = Replace(strXML, "<U>", under_start, Compare:=vbDatabaseCompare)
 strXML = Replace(strXML, "</U>", under_end, Compare:=vbDatabaseCompare)

 ReplaceXML_ByPreMarkdown = strXML
End Function

Private Function getStyleCatchPattern(strFind As String) As String
 On Error Resume Next
 getStyleCatchPattern = "([ ]*(?:" & strFind & ")[ ]*)"
End Function

Private Function ToFinalMarkdown(strPreMarkdown) As String
Dim strOut As String, strPat As String
 On Error Resume Next
 strOut = strPreMarkdown

 ' Reorganizing blank spaces (pre-post delimiters)
 strPat = getStyleCatchPattern(bold_start)
 strOut = RxReplace(strOut, strPat, " " & bold_start)
 strPat = getStyleCatchPattern(bold_end)
 strOut = RxReplace(strOut, strPat, bold_end & " ")

 strPat = getStyleCatchPattern(italics_start)
 strOut = RxReplace(strOut, strPat, " " & italics_start)
 strPat = getStyleCatchPattern(italics_end)
 strOut = RxReplace(strOut, strPat, italics_end & " ")

 strPat = getStyleCatchPattern(under_start)
 strOut = RxReplace(strOut, strPat, " " & under_start)
 strPat = getStyleCatchPattern(under_end)
 strOut = RxReplace(strOut, strPat, under_end & " ")

 ' Final blank spaces adjustment (remove spaces between start/end delimiters)
 strPat = "(" & bold_start & "|" & italics_start & "|" & under_start & ")"
 strPat = strPat & "(\s+?)" & strPat
 strOut = RxReplace(strOut, strPat, "$1$3")
 strOut = RxReplace(strOut, strPat, "$1$3")

 strPat = "(" & bold_end & "|" & italics_end & "|" & under_end & ")"
 strPat = strPat & "(\s+?)" & strPat
 strOut = RxReplace(strOut, strPat, "$1$3")
 strOut = RxReplace(strOut, strPat, "$1$3")

 ' To Final Markdown
 strOut = Replace(strOut, bold_start, ch_bold)
 strOut = Replace(strOut, bold_end, ch_bold)
 strOut = Replace(strOut, italics_start, ch_italics)
 strOut = Replace(strOut, italics_end, ch_italics)
 strOut = Replace(strOut, under_start, ch_u_start)
 strOut = Replace(strOut, under_end, ch_u_end)

 ToFinalMarkdown = strOut
End Function

' ********** RegExp with late binding 
Private Function GetRegex(Pattern As String, Optional IgnoreCase As Boolean = True, _ 
        Optional Multiline As Boolean = True, Optional MatchGlobal As Boolean = True) As Object

    If pCachedRegexes Is Nothing Then Set pCachedRegexes = CreateObject("Scripting.Dictionary")
    ' Build the unique key for the regex (to Cache it)
    Dim rxKey As String
    rxKey = IIf(IgnoreCase, "1", "0") & _
            IIf(Multiline, "1", "0") & _
            IIf(MatchGlobal, "1", "0") & _
            Pattern

    If Not pCachedRegexes.Exists(rxKey) Then
        Dim oRegExp As Object
        Set oRegExp = CreateObject("vbscript.regexp")
        With oRegExp
            .Pattern = Pattern
            .IgnoreCase = IgnoreCase
            .Multiline = Multiline
            .Global = MatchGlobal
        End With
        Set pCachedRegexes(rxKey) = oRegExp
    End If

    ' Fetch and return the pre-compiled RegExp object
    Set GetRegex = pCachedRegexes(rxKey)
End Function

Private Function RxReplace(SourceString As String, Pattern As String, ReplacePattern As String, _
    Optional IgnoreCase As Boolean = True, Optional Multiline As Boolean = True, _
    Optional MatchGlobal As Boolean = True) As String

    RxReplace = GetRegex(Pattern, IgnoreCase, Multiline, MatchGlobal).Replace( _
        SourceString, ReplacePattern)
End Function

Range.Characters的替代方法，用于跟踪单个Cell中的Font Formats

1 个答案: