20190411wdVBA_排版
Sub LayoutForExamPaper()
Dim StartTime As Variant
Dim UsedTime As Variant
StartTime = VBA.Timer
Application.ScreenUpdating = False
Dim oneP As Paragraph
Dim rng As Range
Call ClearParagraphFill
Call ConvertNoToText '项目编号转为文本
Call ConvertShape '图形转为inlineShape
Call DivideInLineShape '图文分段
Call ReplaceABCD '统一选项字母为半角字母
Call ZeroIndent '0缩进
'删除所有空行
ActiveDocument.Content.Find.Execute "^13[ ^t" & ChrW(160) & "^11^13]{1,}", , , 2, , , , , , "^13", 2
'替换所有空白
ActiveDocument.Content.Find.Execute "^w", , , 0, , , , , , "^s", 2
'替换手动换行符
ActiveDocument.Content.Find.Execute "^l", , , 0, , , , , , "^13", 2
'插入空白段落
ActiveDocument.Range(0, 0).InsertBefore vbCrLf
'删除段首空白
ActiveDocument.Content.Find.Execute "^13@^s@([!^s]@)", , , 1, , , , , , "^13\1", 2
'删除事先插入的空白段落
ActiveDocument.Paragraphs(1).Range = ""
'删除ABCD及题号尾随空白
ActiveDocument.Content.Find.Execute "([A-D0-9]@)[.、．]^s@([!^s]@)", , , 1, , , , , , "\1．\2", 2
'ABCD选项独立为行
ActiveDocument.Content.Find.Execute "[!^13]([B-D]．)", , , 1, , , , , , "^13\1", 2
'删除题干和选项段尾空白
ActiveDocument.Content.Find.Execute "(^13[A-D0-9]@．[!^s]@)^s@(^13)", , , 1, , , , , , "\1\2", 2
'选项中间的空白替换为顿号 一个选项多个部分组成的情况
For n = 1 To 5 '最多支持一个选项有5个部分构成 有疑问 括号内多处顿号的问题
ActiveDocument.Content.Find.Execute "(^13[A-D]．[! ^s\(（]@)^s@([!^s\)）]@)", , , 1, , , , , , "\1、\2", 2
Next n
Debug.Print " "
'删除题干中的空白
For n = 1 To 5 '最多支持一个题干有5处部分构成
ActiveDocument.Content.Find.Execute "(^13[0-9]@．[!^s\(（]@)^s@([!^s\)）]@)", , , 1, , , , , , "\1\2", 2
Next n
'统一括号内为四个空白字符 如 12.该岛屿孤猴集中分布区的自然景观是（ ）
ActiveDocument.Content.Find.Execute "^13([0-9]@．[!^s]@)[\(（]^s@[\)）]^13", , , 1, , , , , , "^13\1( )^13", 2
'假回车转硬回车
ActiveDocument.Content.Find.Execute "^13", , , 0, , , , , , "^p", 2
'删除分页符
ActiveDocument.Content.Find.Execute "^m", , , 0, , , , , , "", 2
Call ModifyFont '根据行首行尾字符判断 修改字体格式
Call AddTabStopForOptions '根据选项长度添加制表位
Call InsertPageNo '插入页码
Call PageSetUpB5 '设置纸张
Application.ScreenUpdating = True
UsedTime = VBA.Timer - StartTime
Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
'MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
End Sub Private Sub ZeroIndent()
'清除缩进
With ActiveDocument.Paragraphs.Format
.TabStops.ClearAll
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
'以上三句必须在前面 而以下三句必须在后面才能生效
.FirstLineIndent = CentimetersToPoints(0)
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
End With
End Sub Private Sub ClearParagraphFill()
With ActiveDocument.Paragraphs.Format
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = False
End With
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth050pt
.DefaultBorderColor = wdColorAutomatic
End With
End Sub Private Sub ConvertNoToText()
Dim oneList As List
For Each oneList In ActiveDocument.Lists
oneList.ConvertNumbersToText
Next
End Sub Private Sub ModifyFont()
Dim rng As Range
For Each oneP In ActiveDocument.Paragraphs
n = n + 1
Set rng = oneP.Range
If Not rng.Information(wdWithInTable) Then
Count = Len(rng.Text)
'题干和选项、综合题小题等 字体设置
If rng.MoveStartWhile("(（）)0123456789０１２３４５６７８９ＡＢＣＤABCD①②③④⑤⑥⑦⑧⑨⑩.、．分", wdForward) >= 1 Then
With oneP.Range.Font
.Name = "宋体"
.Size = 10.5
.ColorIndex = wdBlack
.Bold = False
.Italic = False
End With
Else
'题型字体设置
If rng.MoveStartWhile("第一二三部分.、．非选择综合题", wdForward) > 1 Then
With oneP.Range.Font
.Name = "宋体"
.Size = 12
.Bold = True
.Italic = False
.ColorIndex = wdBlack
End With
Else
'引言字体设置
If rng.MoveEndWhile("1234567890~-据此完成回答下列各题.。(（）)分结合材料下面小" & Chr(13) & Chr(11), wdBackward) < -2 Then 'dasdasd
With oneP.Range.Font
.Name = "楷体"
.Size = 10.5
.ColorIndex = wdBlack
.Bold = False
.Italic = False
End With
End If
End If
End If
End If
Next
End Sub Private Sub AddTabStopForOptions()
'处理选项和制表位
Dim rng As Range
Dim ap As Paragraph, bp As Paragraph, cp As Paragraph, dp As Paragraph
lenth = ActiveDocument.PageSetup.CharsLine
For i = ActiveDocument.Paragraphs.Count To 4 Step -1
Set oneP = ActiveDocument.Paragraphs(i)
Set rng = oneP.Range
If Not rng.Information(wdWithInTable) Then
movestep = rng.MoveStartWhile("D．.", 10)
If movestep >= 2 Then
Set dp = ActiveDocument.Paragraphs(i)
Set cp = ActiveDocument.Paragraphs(i - 1)
Set bp = ActiveDocument.Paragraphs(i - 2)
Set ap = ActiveDocument.Paragraphs(i - 3)
If dp.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 And _
cp.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 And _
bp.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 And _
ap.Range.ComputeStatistics(wdStatisticCharacters) < lenth / 4 - 1 Then '一行足够
ap.Range.Text = vbTab & Replace(ap.Range.Text, Chr(13), vbTab) & Replace(bp.Range.Text, Chr(13), vbTab) & Replace(cp.Range.Text, Chr(13), vbTab) & dp.Range.Text
bp.Range.Text = ""
cp.Range.Text = ""
dp.Range.Text = ""
AddTabStopInRange ActiveDocument.Paragraphs(i - 3).Range, 4
'Debug.Print "一行"
Else
If dp.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Or _
cp.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Or _
bp.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Or _
ap.Range.ComputeStatistics(wdStatisticCharacters) > lenth / 2 - 2 Then '分四行好看
dp.Range.Text = vbTab & dp.Range.Text
cp.Range.Text = vbTab & cp.Range.Text
bp.Range.Text = vbTab & bp.Range.Text
ap.Range.Text = vbTab & ap.Range.Text
AddTabStopInRange ActiveDocument.Paragraphs(i - 3).Range, 1
AddTabStopInRange ActiveDocument.Paragraphs(i - 2).Range, 1
AddTabStopInRange ActiveDocument.Paragraphs(i - 1).Range, 1
AddTabStopInRange ActiveDocument.Paragraphs(i).Range, 1
'Debug.Print "四行"
Else '分两行
ap.Range.Text = vbTab & Replace(ap.Range.Text, Chr(13), vbTab) & bp.Range.Text
bp.Range.Text = vbTab & Replace(cp.Range.Text, Chr(13), vbTab) & dp.Range.Text
cp.Range.Text = ""
dp.Range.Text = ""
AddTabStopInRange ActiveDocument.Paragraphs(i - 3).Range, 2
AddTabStopInRange ActiveDocument.Paragraphs(i - 2).Range, 2
End If
End If
End If
End If
Next i
End Sub Private Sub AddTabStopInRange(ByVal rng As Range, ByVal tabStopCount As Integer)
Dim pgWidth As Double, pgLeftMargin As Double, opWidth As Integer
Dim chrLine As Integer, i As Integer
With ActiveDocument.PageSetup
pgLeftMargin = .LeftMargin
pgWidth = .PageWidth - .LeftMargin - .RightMargin
End With
opWidth = Int(pgWidth / tabStopCount) '计算选项宽度
chrLine = ActiveDocument.PageSetup.CharsLine '获取每行字符数
rng.ParagraphFormat.TabStops.ClearAll '清除原有制表位
'新增制表位
For i = 1 To tabStopCount
rng.ParagraphFormat.TabStops.Add Position:=20 + (i - 1) * opWidth, _
Leader:=wdTabLeaderSpaces, Alignment:=wdAlignTabLeft
Next i
End Sub Private Sub ConvertShape()
'转换图形
Dim shp As Shape
Dim inshp As InlineShape
ConvertTime = 0
Do While ActiveDocument.Shapes.Count > 0
ConvertTime = ConvertTime + 1
For Each shp In ActiveDocument.Shapes
shp.ConvertToInlineShape
Next shp
If ConvertTime > 20 Then Exit Do
Loop
End Sub Private Sub DivideInLineShape()
Dim p As Paragraph
Dim rng As Range
For i = ActiveDocument.Paragraphs.Count To 1 Step -1
Set p = ActiveDocument.Paragraphs(i)
If p.Range.InlineShapes.Count > 0 Then
pic = 0
'不断向后查找段落中inlineshape的位置 并插入回车
lenth = Len(p.Range.Text)
Set rng = p.Range
hasMove = rng.MoveStartUntil(Chr(47), lenth)
m = 0
Do While hasMove > 0
If rng.Characters.First.Previous <> Chr(13) Then
rng.InsertBefore vbCrLf
End If
rng.Start = rng.Start + 1
If rng.Characters.First.Next <> Chr(13) Then
rng.InsertBefore vbCrLf
End If
lenth = Len(rng.Text)
hasMove = rng.MoveStartUntil(Chr(47), lenth)
m = m + 1
If m = 20 Then Exit Do
Loop
End If
Next i
End Sub Private Sub ReplaceABCD()
Const qjzm As String = "ＡＢＣＤ"
Const bjzm As String = "ABCD"
Dim idx As Integer
For idx = 1 To 4
ActiveDocument.Content.Find.Execute Mid(qjzm, idx, 1), , , 0, , , , , , Mid(bjzm, idx, 1), 2
Next idx
End Sub Private Sub InsertPageNo()
Dim rng As Range
With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)
Set rng = .Range
rng.Font.Size = 11
rng.Font.Name = "Times New Roman"
ActiveDocument.Fields.Add rng, wdFieldEmpty, "Page"
.Range.Fields.Update
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
'ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
'Selection.WholeStory
'Selection.Delete
'With Selection.ParagraphFormat
With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
.Delete '删除段落
With .ParagraphFormat
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = False
End With
End With
End With
With Options
.DefaultBorderLineStyle = wdLineStyleSingle
.DefaultBorderLineWidth = wdLineWidth075pt
.DefaultBorderColor = wdColorAutomatic
End With
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub Private Sub PageSetUpB5()
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(1.5)
.BottomMargin = CentimetersToPoints(1.5)
.LeftMargin = CentimetersToPoints(1.5)
.RightMargin = CentimetersToPoints(1.5)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.5)
.FooterDistance = CentimetersToPoints(1.5)
.PageWidth = CentimetersToPoints(18.2)
.PageHeight = CentimetersToPoints(25.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
.LayoutMode = wdLayoutModeLineGrid
End With
End Sub
20190411wdVBA_排版的更多相关文章
- android textview 自动换行 整齐排版
一.问题在哪里? textview显示长文字时会进行自动折行,如果遇到一些特殊情况,自动折行会杯具成这个样子: 上述特殊情况包括: 1)全角/半角符号混排(一般是数字.字母.汉字混排) 2)全角/半角 ...
- 网页万能排版布局插件，web视图定位布局创意技术演示页
html万能排版布局插件,是不是感觉很强大,原理其实很简单,不过功能很强大哈哈,大量节省排版布局时间啊! test.html <!doctype html> <html> &l ...
- 用EmEditor实现PDF转Word后的对齐排版
Redraw = false//禁止重绘(类似于VBA中的: Application.screenupdating=FALSE),以提高运行效率 //去除所有空行和只由空白字符构成的行 documen ...
- bootstrap学习笔记--bootstrap排版类的使用
标题 Bootstrap 中定义了所有的 HTML 标题(h1 到 h6)的样式,这个和一般的html没啥区别.请看下面的实例: <h1>测试1 h1</h1> <h2& ...
- Windows下LATEX排版论文攻略—CTeX、JabRef使用介绍
Windows下LATEX排版论文攻略—CTeX.JabRef使用介绍 一.工具介绍 TeX是一个很好排版工具,在学术界十分流行,特别是数学.物理学和计算机科学界. CTeX是TeX中的一个版本,指的 ...
- eclipse自动排版JSP问题
eclipse自动排版JSP非常难看,标签每行显示不完整,开发时很难受,下面设置一下这个就好多了: window-->preferences-->Web-->HTML Files-- ...
- html学习第二天—— 第九、十章——CSS的继承、层叠和特殊性+CSS格式化排版
继承CSS的某些样式是具有继承性的,那么什么是继承呢?继承是一种规则,它允许样式不仅应用于某个特定html标签元素,而且应用于其后代.比如下面代码:如某种颜色应用于p标签,这个颜色设置不仅应用p标签, ...
- bootstrap之排版类
bootstrap之排版类
- 测试 MathJax 排版功效
这是第一篇博文,用于检测博客园提供的数学排版功能,下面是一些数学公式. \[ \text{sgn}(\mathbf{w}^T\phi(\mathbf{x})+b) = \text{sgn}\left( ...
随机推荐
- #WEB安全基础 : HTTP协议 | 0x13 不安全的HTTP
HTTP作为一个大规模使用的网络协议就真的安全了吗? 我们知道互联网为什么叫互联网,你可以在任何地方都可以与之相连,所以在这些可以连接的点上都可以获取互联网的部分信息. 那么HTTP通信时有什么缺点吗 ...
- git之reset图解
https://blog.csdn.net/longintchar/article/details/81843048 1.三棵树. 此时如果我们运行 git status,会发现没有任何改动,因为现在 ...
- Unity3D判断当前所在平台
Unity3D是一个跨平台的开发工具,支持的平台五花八门,常常开发一款游戏要发布到不同的平台,在不同的平台上会使用不同的代码,难道要我们各平台分别使用一套代码,单独编译一次吗?当然不用了,呵呵. ...
- GALV_maptravel研究分析（2）
本节地图:Gov's Mansion,Campsite,Yourmansion ++++++++++++++++++++华丽丽的分割线+++++++++++++++++++++++++++++++++ ...
- conn.encoders[SafeBytes] = conn.encoders[bytes] KeyError: <class 'bytes'>
问题描述:Django连接mysql数据库,修改了setting.py文件后,启动服务器报错 错误截图如下: 解决方法: 1.pip install pymsql 2.在setting.py同目录下的 ...
- 从json-lib转成jackson的遇到的问题
从json-lib转成jackson的遇到的问题 问题一:json 字符串,再经过Jackson序列化之后就变成原生字符串了.而json-lib经过再序列化之后,还是json格式的串. 针对这种情况, ...
- 微信扫描二维码安卓弹出默认浏览器（苹果打开App Store）打开下载链接
使用微信推广的用户经常都会遇到推广链接被拦截导致无法下载app的情况,此时用户在微信中打开会提示“ 已停止访问该网页 ”.这对于使用微信营销的商家来说就很不友好且损失非常大,因为用户是不知道为什么打不 ...
- JS 画框操作
Js中,我们有时候需要对图片进行操作,包括画框,其实对于UI前端来说挺简单的,没有网上说的那样复杂,这里说明一下 <div style="width:80%;height:300px; ...
- es6转es5 在线转换工具
es6转es5 在线转换工具 Babeljs es6console
- 用JavaScript写一个简单的计算器
本文使用js实现了一个简单的加.减.乘.除计算器. 以下是css部分代码: *{ padding:0; margin:0; color: #424242; } .outer{ width:300px; ...