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

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宏结束