QQ聊天记录格式化的word宏第二版

2019独角兽企业重金招聘Python工程师标准>>>

第二版功能更强大，可以设置多个人为不同颜色

Sub QQ聊天记录格式整理v2()
'QQ2010版聊天记录处理
'根据各自发言 的QQ名，并根据文档开头的发言人名称颜色，设置文档为相应的颜色
Dim ps As Paragraph
Dim s As Paragraph
Dim allps As Paragraphs
Set allps = ActiveDocument.Paragraphs
 
Dim sample As Paragraph

Dim users()
Dim colors()

Dim color
color = wdColorBlack
index = 1
'遍历文档开头各人QQ名，保存各人发言颜色
For Each ps In allps
    If Left(ps.Range.text, 3) = "===" Then
        index = index + 1
        Exit For
    End If
    Dim t As String
    t = ActiveDocument.Paragraphs(index).Range.text
    ReDim Preserve users(index)
    ReDim Preserve colors(index)
    users(index) = Left(t, Len(t) - 1)
    colors(index) = ActiveDocument.Paragraphs(index).Range.Font.color
    index = index + 1
Next

'Call 删除所有qq号
'1：整体变换网页换行^1与word中回车^p
'Call 网页换行改成回车

'2：老师姓名加红
i = 1
For Each ps In allps
    If i < index Then
        i = i + 1
    Else
        i = i + 1
        '没有时间，则表示为QQ发言人行
        ps_len = Len(ps.Range.text)
        If ps_len > 8 Then
            text = Mid(ps.Range.text, ps_len - 7, 7)
        Else
            text = Left(ps.Range.text, ps_len - 1)
        End If
        If text Like "#:##:##" Then
            '这里判断为发言人、时间的特殊行
            For color_index = 1 To UBound(users)
                If Left(ps.Range.text, Len(users(color_index))) = users(color_index) Then
                    color = colors(color_index)
                    Exit For
                End If
            Next
        End If
        ps.Range.Font.color = color
        
    End If
    
    
Next

End Sub

Sub QQ聊天记录格式整理_老师发言红色()
'QQ2010版聊天记录处理

Dim ps As Paragraph
Dim s As Paragraph
Dim allps As Paragraphs
Set allps = ActiveDocument.Paragraphs
 

Call 删除所有qq号

'1：整体变换网页换行^1与word中回车^p
Call 网页换行改成回车

'2：老师姓名加红

'老师为发言人段标识符
Dim isTeacher
isTeacher = False
'道友为发言人标识符
Dim isSayer
isSayer = False
'普通段落标识符
Dim isParag
isParag = True

For Each ps In allps
    With ps.Range.Find
        .text = "<[0-9]{1,2}:[0-9]{2}:[0-9]{2}>"
        .Forward = True
        .MatchWildcards = True
        .Execute
        
        If .Found = True Then
            '这种格式为发言人格式段落
            isSayer = True
            isTeacher = False
            isParag = False
            '以12:23:56这样的时间格式结尾
            ps.Range.Select
            
            If Left(ps.Range.text, Len(t)) = t Then
                '老师为发言人
                isTeacher = True
            End If
        Else
            '普通段落
            isSayer = False
            isParag = True
        End If
    End With '查找12:23:56这样的时间格式结尾
    
    If isTeacher = True Then
        ps.Range.Font.color = wdColorRed
    ElseIf isSayer = True Then
        ps.Range.Font.color = wdColorBlue
    End If
Next

'3：时间字体变灰
Call 时间字体变成灰色
End Sub

Sub 网页换行改成回车()
'
' 第一步
' 网页换行改成回车
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .text = "^l"
        .Replacement.text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub 时间字体变成灰色()
'
' 时间字体变成灰色 Macro
' 12:26:36是时间格式，通配符为<[0-9]{2}:[0-9]{2}:[0-9]{2}>，字体颜色改成灰色
'
    ActiveWindow.ActivePane.VerticalPercentScrolled = 35
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .text = "<[0-9]{1,2}:[0-9]{2}:[0-9]{2}>"
        .Replacement.Font.color = wdColorGray50
        
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub 删除所有qq号()
    ActiveWindow.ActivePane.VerticalPercentScrolled = 35
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .text = "\([0-9]{5,10}\)"
        .Replacement.Font.color = wdColorGray50
        
        .Replacement.text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

'word宏结束

转载于:https://my.oschina.net/jianhui1980/blog/173969