|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 weiyingde 于 2017-4-24 12:12 编辑
一、鸣谢：
在本坛duquancai、jiminyanya、dafanshu1、loquat等多位大侠、朋友的启蒙、指教和帮助下，完成了本程序，没有他们的帮助，就没有这些代码。所以，本程序可以说是他们的原创，我只不过是，把他们的智慧综合一下。对他们帮助和指教表示衷心的感谢！！
二、申明：
（1）、由于初学word，基础不牢（可以说还未启蒙），代码免不了冗余啰嗦、不够条理，所以运行缓慢，不流畅等等毛病，希望这些朋友，继续援手，共同完善。
（2）、特别是结尾部分添加或修改整理日期，更是毛病百出。
（3）、特别希望大侠增加它更多的功能，优化提速代码，使之更有效率。
（4）、说是万能那是出发点和最终的目标，而并非眼前的实际功能。
三、本程序功能作用：
1、可做试卷的母版，隐藏或显示答案。
2、整理网上下载的带乱码的文档，删去多余的空格；
3、格式化文档：改变字体、颜色、并且做到加粗标题等。
更多的功能，期待你的加入和添加。
Public 次数 As Integer
Sub 一键万能格式整理()
Dim pars As Paragraphs
次数 = 次数 + 1
k = 次数 Mod 2 + 1
Dim bl As Boolean
mStr = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Randomize
z1 = Int(Rnd * 3 + 1)
z2 = Int(Rnd * 4 + 1)
'On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕刷新
Dim par As Paragraph
Set rg = ActiveDocument.Paragraphs(1).Range
sr = rg.Text
If Left(Right(sr, 2), 1) <> "。" Then
rg.MoveEnd , -1
rg.InsertAfter vbCr
bl = False
Else
bl = True
End If
If bl = False Then rg.Text = Left(sr, rg.Characters.Count - 1) & "。"
With ActiveDocument.Content '以下处理空格（包括全角、半角）、断行、空行等
.Font.ColorIndex = wdBlack
With .Find
.Execute "^l", , , 1, , , , , , "^p", 2
.Execute "^13^32{1,}", , , 1, , , , , , "^p", 2
.Execute "^t", , , 1, , , , , , "", 2
.Execute "([一-隝]@)([ ]{1,})([一-隝]@)", , , 1, , , , , , "\1\3", 2
.Execute "([一-隝]@)(^32{1,})([一-隝]@)", , , 1, , , , , , "\1\3", 2
.Execute "([!。：……？！）])^13{1,}", , , 1, , , , , , "\1", 2
.Execute "^s", , , , , , , , , "", 2
End With
End With
With ActiveDocument.Content '以下处理各种特殊格式
With .Find '处理中文字体
.Replacement.Font.NameFarEast = Choose(z2, "楷体", "华文楷体", "方正启体简体", "黑体")
.Execute "([一-隝]@)", , , 1, , , , , , "^&", 2
End With
With .Find '处理西文字体
.Replacement.Font.NameAscii = Choose(z2, "方正姚体", "Arial Black", "Arial Narrow", "Impact", "Franklin Gothic Medium Cond")
.Execute "([A-Za-z]@)", , , 1, , , , , , "^&", 2
End With
With .Find '处理“一、二……十"这样的项目
With .Replacement.Font
.NameFarEast = "华文新魏"
.ColorIndex = wdDarkBlue
.Size = 18
End With
.Execute "([一二三四五六七八九十]@[、,]*^13)", , , 1, , , , , , "^&", 2
End With
With .Find '处理“(一)、(二)……(十)"这样的项目
.Replacement.Font.NameFarEast = "方正康体简体"
.Replacement.Font.ColorIndex = wdDarkBlue
.Replacement.Font.Size = 15
.Execute "([\(（\[【][一二三四五六七八九十甲乙丙丁]@[\)）\]】][、,]*^13)", , , 1, , , , , , "^&", 2
End With
With .Find '处理答案，包括（ABCD)形式的答案，再就是答：这种形式的答案。
Do While .Execute("[\(（\[【][A-D]@[\)）\]】]", , , 1) '1, , , , , , "^&", 2
With .Parent
.Start = .Start + 1: .End = .End - 1
.Font.Name = "Arial Black"
.Font.ColorIndex = Choose(k, 8, 2)
.Font.Size = 18
.Collapse 0
End With
Loop
End With
With ActiveDocument.Content.Find
.Replacement.Font.ColorIndex = Choose(k, 8, 2)
.Replacement.Font.Underline = wdUnderlineWavy
.Replacement.Font.UnderlineColor = wdColorDarkBlue
.Execute "(^13答：*^13)", , , 1, , , , , , "\1", 2 '隐藏答案
End With
With ActiveDocument.Content.Find
.Replacement.Font.ColorIndex = 1
.Execute "答：", , , 1, , , , , , , 2, 2 '显示"答案"二字。
End With
End With
With ActiveDocument.Paragraphs(1) '处理第一段格式
.Format.Alignment = wdAlignParagraphCenter
With .Range.Font
.Bold = True
.ColorIndex = Choose(z1, wdDarkBlue, wdBlack, wdBlue, wdViolet)
.NameFarEast = Choose(z1, "腾祥范笑歌楷书简", "华文隶书", "华文新魏")
End With
End With
For i = 2 To ActiveDocument.Paragraphs.Count ' 处理其他各段行距，体体大小
With ActiveDocument.Paragraphs(i)
.LineSpacingRule = wdLineSpaceAtLeast
.LineSpacing = 14
.Format.CharacterUnitFirstLineIndent = 2
.Range.Font.Size = 10.5
End With
Next
Set rg = ActiveDocument.Paragraphs(1).Range '删除第一段（文章标题）的句号,恢复其本来内容
sr = ActiveDocument.Paragraphs(1).Range.Text
If Left(Right(sr, 2), 1) = "。" Then rg.MoveEnd , -1: rg.InsertAfter vbCr
With ActiveDocument.Paragraphs(1)
If Left(Right(sr, 2), 1) = "。" Then .Range = Left(sr, Len(sr) - 2)
.Range.Font.Size = 22
End With
With ActiveDocument '在最后一段修改或添加整理日期。
With .Content.Find
If .Found = True Then
.Execute "([0-9]{4}年[0-9]月{2}[0-9]{2}日)", , , 1, , , , , , "^&", 1
.Replacement.Text = Format(Date, "yyyy年mm月dd日")
Else
With ActiveDocument.Paragraphs
Set rng = ActiveDocument.Paragraphs(.Count).Range
rng.MoveEnd , -1: rng.InsertAfter vbCr
ActiveDocument.Paragraphs(.Count).Range = Format(Date, "yyyy年mm月dd日整理")
ActiveDocument.Paragraphs(.Count).Format.Alignment = wdAlignParagraphRight
End With
End If
End With
End With
ActiveDocument.Content.ParagraphFormat.DisableLineHeightGrid = -1
Application.ScreenUpdating = True '开启屏幕刷新
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2017-4-11 20:48
楼主
