Word宏代碼集錦
Word宏代碼集錦
一,、
修改word格式:
1,、' 智能清除選區(qū)軟回車(換行符)
2,、' 清除選區(qū)多余空段
3,、' 合并選區(qū)中“,,”結(jié)束的多余分段
4,、' 清除選區(qū)單字節(jié)空格
5,、' 清除選區(qū)單字節(jié)空格
6,、' 清除選區(qū)1字空格
7、' 清除選區(qū)段首2字空格
8,、' 清除選區(qū)Tab
9,、' 增加選區(qū)空格
10、' 選區(qū)段首縮進0字
11,、' 選區(qū)段首縮進:2字
12,、' 選區(qū)段首縮進轉(zhuǎn)空格—已完美
13、' 選區(qū)段后間距1行
14,、' 選區(qū)段后間距1行
15,、' 選區(qū)段后間距1行
16、' 清除選區(qū)圖片
17,、' 選區(qū)硬回車轉(zhuǎn)軟回車
18,、' 清除選區(qū)軟回車
19' 合并選區(qū)段落
20、' 選區(qū)空格轉(zhuǎn)硬回車
21,、' 選區(qū)標點半角轉(zhuǎn)全角
22,、' 選區(qū)標點全角轉(zhuǎn)半角
23、' 選區(qū)中文句號轉(zhuǎn)半角
24,、’把文檔第一段設(shè)置為標題1的格式
25,、選中的文本橫向居中
26、縮小字距
27,、增大字距
28,、縮小行距
29、增大行距
30,、等高變寬
31,、等高變窄
32、字表間距
33,、縱向16開
34,、插入頁碼
35、小寫金額轉(zhuǎn)大寫金額
二,、
其它
1.調(diào)整圖片大小
2.轉(zhuǎn)字體
3.轉(zhuǎn)文件格式
4,、文件加密
5、字符替換
6,、替換引號
7,、打印為PDF格式文件
8,、朗讀文本
9. 文獻標號上標化
10. 箭頭上方加文字
11 添加參考文獻格式一,參考文獻在文檔末尾以1. 2. 3. 格式排列
12. 添加參考文獻格式二,,參考文獻在文檔末尾以[1] [2] [3]
格式排列,,修改自格式一的代碼
13. 返回正文
14. 再次引用已有參考文獻
15. 查找被刪參考文獻遺留引用,
16,、統(tǒng)計修訂的字數(shù)
17,、快速提取腳注內(nèi)容
18、從任意頁面編排頁碼
19,、批量實現(xiàn)縮放打印
20,、對文檔內(nèi)容進行順序排列
21、替換Word文檔插圖的超鏈接
22,、為文檔的每頁添加固定內(nèi)容
23,、批量實現(xiàn)圖片的等比例縮
一、
修改word格式:
1,、' 智能清除選區(qū)軟回車(換行符)
Sub
智能清除選區(qū)軟回車()
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
With
Selection.Find
.Text = "^1^l"
.Replacement.Text = "^&^p"
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^l"
.Replacement.Text = ""
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
2,、' 清除選區(qū)多余空段
Sub
清除選區(qū)多余空段()
With
Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards
= False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p "
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
3、' 合并選區(qū)中“,,”結(jié)束的多余分段
Sub
合并選區(qū)多余分段()
With
Selection.Find
.Text = ",,^p"
.Replacement.Text = ","
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = ",、^p"
.Replacement.Text
= ",、"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
4、' 清除選區(qū)單字節(jié)空格
Sub
清除選區(qū)單字節(jié)空格()
With
Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
5,、' 清除選區(qū)單字節(jié)空格
Sub
清除選區(qū)2單字節(jié)空格()
With
Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
6,、' 清除選區(qū)1字空格
Sub
清除選區(qū)1字空格()
With
Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
7、' 清除選區(qū)段首2字空格
Sub
清除選區(qū)段首2字空格()
With
Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
8,、' 清除選區(qū)Tab
Sub
清除選區(qū)Tab()
With
Selection.Find
.Text = vbTab
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
9,、' 增加選區(qū)空格
Sub
增加選區(qū)空格()
With
Selection.Find
.Text = " "
.Replacement.Text = " "
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
10、' 選區(qū)段首縮進0字
Sub
選區(qū)段首無縮進()
With
Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.ParagraphFormat
.LeftIndent =
CentimetersToPoints(0)
'左縮進0字符
.RightIndent =
CentimetersToPoints(0)
'右縮進0字符
.FirstLineIndent =
CentimetersToPoints(0)
'首行縮進點0公分
.CharacterUnitLeftIndent =
0
'左縮進單位0字符
.CharacterUnitRightIndent =
0
'右縮進單位0字符
.CharacterUnitFirstLineIndent = 0
End
With
With
Selection.ParagraphFormat
.LeftIndent =
CentimetersToPoints(0)
'左縮進1字符
.RightIndent =
CentimetersToPoints(0)
'右縮進2字符
.FirstLineIndent =
CentimetersToPoints(0)
'首行縮進點0.35公分
.CharacterUnitLeftIndent =
0
'左縮進單位0字符
.CharacterUnitRightIndent =
0
'右縮進單位0字符
.CharacterUnitFirstLineIndent = 0
End
With
End
Sub
11,、' 選區(qū)段首縮進:2字
Sub
選區(qū)段首縮進2字()
With
Selection.ParagraphFormat
.LeftIndent =
CentimetersToPoints(0)
'左縮進1字符
.RightIndent =
CentimetersToPoints(0)
'右縮進2字符
.FirstLineIndent =
CentimetersToPoints(0.35)
'首行縮進點單位公分
.CharacterUnitLeftIndent =
0
'左縮進單位0字符
.CharacterUnitRightIndent =
0
'右縮進單位0字符
.CharacterUnitFirstLineIndent = 2
End
With
End
Sub
12,、' 選區(qū)段首縮進轉(zhuǎn)空格—已完美
Sub
選區(qū)段首縮進轉(zhuǎn)空格()
Selection.InsertParagraphBefore
Call 選區(qū)段首無縮進
With
Selection.Find
.Text = "^p"
.Replacement.Text = "^p "
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Delete
With
Selection.Find
.Text = " ^p"
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
13、' 選區(qū)段后間距1行
Sub
選區(qū)段后間距1行()
Selection.ParagraphFormat.FirstLineIndent =
CentimetersToPoints(0)
Selection.ParagraphFormat.LineUnitAfter = 1
End
Sub
14,、' 選區(qū)段后間距1行
Sub
選區(qū)段前段后間距半行()
Selection.ParagraphFormat.FirstLineIndent =
CentimetersToPoints(0)
Selection.ParagraphFormat.LineUnitBefore = 0.5
Selection.ParagraphFormat.LineUnitAfter = 0.5
End
Sub
15,、' 選區(qū)段后間距1行
Sub
選區(qū)段前段后無間距()
Selection.ParagraphFormat.FirstLineIndent =
CentimetersToPoints(0)
Selection.ParagraphFormat.LineUnitBefore = 0
Selection.ParagraphFormat.LineUnitAfter = 0
End
Sub
16、' 清除選區(qū)圖片
Sub
清除選區(qū)圖片()
With
Selection.Find
.Text = "^1"
.Replacement.Text = ""
.MatchWildcards = True
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
17,、' 選區(qū)硬回車轉(zhuǎn)軟回車
Sub
選區(qū)硬回車轉(zhuǎn)軟回車()
With
Selection.Find
.Text = "^p"
.Replacement.Text = "^l"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
18,、' 清除選區(qū)軟回車
Sub
清除選區(qū)軟回車()
' With
Selection.Find
.Text = "^l"
.Replacement.Text = ""
.MatchWildcards = True
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
19' 合并選區(qū)段落
Sub
合并選區(qū)段落()
With
Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^p"
.Replacement.Text = "^l"
.MatchWildcards =
False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "^l"
.Replacement.Text = ""
.MatchWildcards = True
End
With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Paragraphs.Add
'添加段落符號
End Sub
20、' 選區(qū)空格轉(zhuǎn)硬回車
Sub
選區(qū)空格轉(zhuǎn)硬回車()
With
Selection.Find
.Text = " "
.Replacement.Text = "^p"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
21、' 選區(qū)標點半角轉(zhuǎn)全角
Sub
選區(qū)標點半角轉(zhuǎn)全角()
With
Selection.Find
.Text = ","
.Replacement.Text = ",,"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = ";"
.Replacement.Text = ",;"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = ":"
.Replacement.Text = ":"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "?"
.Replacement.Text = "?"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text
= "!"
.Replacement.Text = ",!"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "......"
.Replacement.Text = "……"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "."
.Replacement.Text = ",。"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
22、' 選區(qū)標點全角轉(zhuǎn)半角
Sub 選區(qū)標點全角轉(zhuǎn)半角()
With
Selection.Find
.Text = ",,"
.Replacement.Text = ","
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = ",;"
.Replacement.Text
= ";"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = ":"
.Replacement.Text = ":"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "?"
.Replacement.Text = "?"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = ",!"
.Replacement.Text = "!"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "……"
.Replacement.Text = "......"
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.Find
.Text = "。"
.Replacement.Text = "."
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
23,、' 選區(qū)中文句號轉(zhuǎn)半角
Sub
選區(qū)中文句號轉(zhuǎn)半角()
With
Selection.Find
.Text = ",。"
.Replacement.Text = "."
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
End
Sub
24、’把文檔第一段設(shè)置為標題1的格式
Sub
標題1()
ActiveDocument.Paragraphs(1).Style =
ActiveDocument.Styles("標題 1")
Selection.ParagraphFormat.Alignment =
wdAlignParagraphCenter
End
Sub
25,、選中的文本橫向居中
Sub
橫向居中()
With
Selection.Find
.Text = " "
.Replacement.Text = ""
.MatchWildcards = False
End
With
Selection.Find.Execute Replace:=wdReplaceAll
With
Selection.ParagraphFormat
.LeftIndent =
CentimetersToPoints(0)
'左縮進0字符
.RightIndent =
CentimetersToPoints(0)
'右縮進0字符
.FirstLineIndent =
CentimetersToPoints(0)
'首行縮進點0公分
.CharacterUnitLeftIndent =
0
'左縮進單位0字符
.CharacterUnitRightIndent =
0
'右縮進單位0字符
.CharacterUnitFirstLineIndent = 0
End
With
With
Selection.ParagraphFormat
.LeftIndent =
CentimetersToPoints(0)
'左縮進1字符
.RightIndent =
CentimetersToPoints(0)
'右縮進2字符
.FirstLineIndent =
CentimetersToPoints(0)
'首行縮進點0.35公分
.CharacterUnitLeftIndent =
0
'左縮進單位0字符
.CharacterUnitRightIndent =
0
'右縮進單位0字符
.CharacterUnitFirstLineIndent = 0
End
With
Selection.ParagraphFormat.Alignment =
wdAlignParagraphCenter
End
Sub
26,、縮小字距
Sub
縮小字距()
Dim
b
On
Error Resume Next
ActiveDocument.Compatibility(wdSpacingInWholePoints) =
False
'不按點陣縮放字距
If
Selection.Font.Spacing = 9999999
Then
'當字距不等時,此值為9999999
For b = 1 To Selection.Characters.Count '得到所選字符總數(shù)
Selection.Characters(b).Font.Spacing =
Selection.Characters(b).Font.Spacing - 0.1 '為每個字符更改字距
Next b
Else
Selection.Font.Spacing = Selection.Font.Spacing - 0.1
End
If
End
Sub
27、增大字距
Sub
增大字距()
On
Error Resume Next
ActiveDocument.Compatibility(wdSpacingInWholePoints) =
False
'不按點陣縮放字距
Dim
b
If
Selection.Font.Spacing = 9999999
Then
'當字距不等時,此值為9999999
For b = 1 To Selection.Characters.Count '得到所選字符總數(shù)
Selection.Characters(b).Font.Spacing =
Selection.Characters(b).Font.Spacing + 0.1 '為每個字符更改字距
Next
b
Else
Selection.Font.Spacing = Selection.Font.Spacing + 0.1
End
If
End
Sub
28,、縮小行距
Sub
縮小行距()
Dim
b
On
Error Resume Next
StatusBar = "老劉鄭重提示:
該命令會取消行自動對齊到行網(wǎng)格,!"
With
Selection.ParagraphFormat
.AutoAdjustRightIndent =
False
'不自動調(diào)整右縮進
.DisableLineHeightGrid =
True
'不自動對齊行網(wǎng)格
End
With
If
Selection.ParagraphFormat.LineSpacing = 9999999 Then
For b = 1 To Selection.Paragraphs.Count
Selection.Paragraphs(b).LineSpacing =
Selection.Paragraphs(b).LineSpacing * 0.95
Next b
Else
Selection.ParagraphFormat.LineSpacing =
Selection.ParagraphFormat.LineSpacing * 0.95
End
If
End
Sub
29、增大行距
Sub
增大行距()
Dim
b
On
Error Resume Next
StatusBar = "老劉鄭重提示:
該命令會取消行自動對齊到行網(wǎng)格,!"
With
Selection.ParagraphFormat
.AutoAdjustRightIndent =
False
'不自動調(diào)整右縮進
.DisableLineHeightGrid =
True
'不自動對齊行網(wǎng)格
End
With
If
Selection.ParagraphFormat.LineSpacing = 9999999
Then '當段落間距不等時,此值為9999999
For b = 1 To
Selection.Paragraphs.Count
'得到所選段落總數(shù)
Selection.Paragraphs(b).LineSpacing =
Selection.Paragraphs(b).LineSpacing * 1.05
Next b
Else
Selection.ParagraphFormat.LineSpacing =
Selection.ParagraphFormat.LineSpacing * 1.05
End
If
End
Sub
30,、等高變寬
Sub
等高變寬()
On
Error Resume Next
Selection.Font.Scaling = Selection.Font.Scaling + 1
End
Sub
31、等高變窄
Sub
等高變窄()
On
Error Resume Next
Selection.Font.Scaling = Selection.Font.Scaling - 1
End
Sub
32,、字表間距
Sub
字表間距()
On
Error Resume Next
ActiveDocument.Compatibility(wdAlignTablesRowByRow) =
False
Selection.Tables(1).Select
With
Selection.Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End
With
With
Selection.Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End
With
With
Selection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End
With
With
Selection.Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End
With
On
Error GoTo a:
Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
Selection.Cells.VerticalAlignment =
wdCellAlignVerticalCenter
Selection.Rows.SpaceBetweenColumns = 0
Selection.Tables(1).AllowAutoFit = False
a:
If
Err = 4605 Then
MsgBox "當前位置不在表格中,請重新定義,。", vbInformation, "劉厚彬現(xiàn)在輕輕地告訴你"
End
If
End
Sub
33、縱向16開
Sub
縱向16開()
' With
ActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument.
_
Content.End).PageSetup
'插入點之后
'With
ActiveDocument.PageSetup
'整篇文檔
With
Selection.PageSetup
'本節(jié)
.Orientation =
wdOrientPortrait
'縱向
.TopMargin = MillimetersToPoints(24)
.BottomMargin = MillimetersToPoints(25)
.LeftMargin = MillimetersToPoints(28)
.RightMargin = MillimetersToPoints(25)
.FooterDistance = MillimetersToPoints(21)
.PageWidth = MillimetersToPoints(196)
.PageHeight = MillimetersToPoints(270)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
End
With
End
Sub
34,、插入頁碼
Sub
插入頁碼()
Dim
fstpg As Byte
Dim
mydialog As Dialog
Dim
a As String
On
Error Resume Next
fstpg = 1
ActiveWindow.View.ShowFieldCodes = False '隱藏窗口域代碼
Set
mydialog = Dialogs(wdDialogInsertPageNumbers)
If
mydialog.Display = -1
Then
'-2關(guān)閉,;-1確定;0取消,;1第一個按鈕,,2第二個按鈕,以此類推,。
If mydialog.firstpage = False
Then
'判斷首頁是否打印頁碼
mydialog.firstpage = True
fstpg = False
End If
mydialog.Execute
ActiveWindow.ActivePane.View.SeekView =
wdSeekCurrentPageFooter
'切換到頁腳
Selection.SetRange Start:=0,
End:=4
'選定前3個字符文本
If VBA.Mid$(Selection.text, 1, 1) <> "—" Then
Selection.EndKey Unit:=wdLine
Selection.TypeText text:=" —"
Selection.MoveLeft Unit:=wdCharacter, Count:=5
Selection.TypeText text:="— "
Selection.ParagraphFormat.CharacterUnitRightIndent =
0.75
Selection.ParagraphFormat.CharacterUnitFirstLineIndent =
1.19
End If
If fstpg = False Then
mydialog.firstpage = False
mydialog.Execute
'首頁不顯示頁碼
End If
ActiveWindow.ActivePane.View.SeekView =
wdSeekMainDocument
End
If
End
Sub
35,、小寫金額轉(zhuǎn)大寫金額
Sub
大寫金額()
Dim
BigNum, snum, i, mydata As DataObject
On Error
GoTo e
Set mydata
= New DataObject
BigNum =
""
snum =
Selection.text
If
IsNumeric(snum) = False Then
mydata.GetFromClipboard
'從剪切板取值
snum
= mydata.GetText(1)
End
If
snum =
VBA.Trim(VBA.str(Int(Round(snum, 2) * 100)))
If snum
< 0 Then snum = -snum: BigNum = "負"
If snum =
0 Then
BigNum = "零元整"
Else
Const cNum = "零壹貳叁肆伍陸柒捌玖-萬仟佰拾億仟佰拾萬仟佰拾元角分"
Const cCha = "零仟零佰零拾零零零零零億零萬零元億萬零角零分零整-零零零零零億萬元億零整整"
For i = 1 To Len(snum) '逐位轉(zhuǎn)換
BigNum = BigNum + VBA.Mid(cNum, (VBA.Mid(snum, i, 1)) + 1, 1) +
VBA.Mid(cNum, 26 - Len(snum) + i, 1)
Next i
BigNum = Replace(BigNum, "零億",
"億零")
BigNum = Replace(BigNum, "零萬",
"萬零")
BigNum = Replace(BigNum, "零元",
"元零")
For i = 0 To 11 '去掉多余的零
BigNum = Replace(BigNum, VBA.Mid(cCha, i * 2 + 1, 2), VBA.Mid(cCha,
i + 26, 1))
Next i
End If
Selection.MoveRight
Selection.TypeText
text:=BigNum
End
e:
MsgBox
"你輸入數(shù)字錯誤或太大!請重新輸入。", vbExclamation + vbOKOnly, "提示"
End
Sub
36,、’去掉空白行
Sub
去掉空白行()
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With
Selection.Find
.Text = "[^11^13]{2,}"
.Replacement.Text = "^13"
.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
Application.GoBack
End
Sub
37,、查找替換
Sub
查找替換()
With
ActiveDocument.Content.Find
.ClearFormatting
'清除格式設(shè)置
.Font.Name = "新宋體"
'查找的字體格式
With
.Replacement
'替換條件
.ClearFormatting
'清除格式設(shè)置
.Font.Name = "黑體"
'替換成黑體
End With
.Execute findtext:="", ReplaceWith:="", Format:=True, _
Replace:=wdReplaceAll
'是格式替換,全部替換
End
With
End
Sub
38、總結(jié):word自動化排版宏
Sub 格式設(shè)置()
'
' 格式設(shè)置 Macro
Application.ScreenUpdating = False
'更改所有硬回車為軟回車
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 = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'去除所有空行
Dim i As Paragraph, n As Integer
Application.ScreenUpdating = False
For Each i In ActiveDocument.Paragraphs
If Len(i.Range) = 1 Then
i.Range.Delete
n = n + 1
End If
Next
Application.ScreenUpdating = True
'去除半角空格
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'去除全角空格
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'替換非標準引號為標準引號
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = """(*)"""
.Replacement.Text = ChrW(8220) & "\1" & ChrW(8221)
.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
'字母數(shù)字符號全角轉(zhuǎn)半角 Macro
Dim qjsz, bjsz As String, iii As Integer '定義qjsz(全角數(shù)字),、bjsz(半角數(shù)字)為字符串型,,iii為整數(shù)型
qjsz = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ,./<>?;’:[]{}\|=-+_)(
bjsz = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ,,。/《》,?;':【】{}\|=-+_)(
Selection.WholeStory
For iii = 1 To 95 '循環(huán)10次
With Selection.Find
.Text = Mid(qjsz, iii, 1) 'mid函數(shù):返回文本字符串中從指定位置開始的特定數(shù)目的字符,,每次取一個數(shù)字
.Replacement.Text = Mid(bjsz, iii, 1) '將用于替換的相應(yīng)位置的半角數(shù)字
.Format = False '保留替換前的字符格式
.MatchWildcards = False
.Execute Replace:=wdReplaceAll '用半角符號替換全角符號
End With
Next iii
'修改小數(shù)點錯誤
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([0-9]),。([0-9])"
.Replacement.Text = "\1.\2"
.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
'設(shè)置字號
Selection.WholeStory '全選
Selection.ClearFormatting '清除全文格式
Selection.Font.Size = 14 '設(shè)置字號為14號
'設(shè)置行距
Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
Selection.ParagraphFormat.LineSpacing = 25
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify '設(shè)置文本為兩端對齊
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2 '設(shè)置段首縮進2字符
Selection.HomeKey Unit:=wdStory '移至文首
Selection.EndKey Unit:=wdLine, Extend:=wdExtend '選中首行
Selection.ClearFormatting '清除首行格式
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '設(shè)置首行居中對齊
Selection.ParagraphFormat.LineUnitBefore = 1 '設(shè)置首行段前間距1行
Selection.ParagraphFormat.LineUnitAfter = 1 '設(shè)置首行段后間距1行
Selection.Font.Name = "微軟雅黑" '設(shè)置首行字體為“微軟雅黑”
Selection.Font.Size = 18 '設(shè)置首行字號為18號
Selection.Font.Bold = wdToggle '設(shè)置首行字形為加粗
Application.ScreenUpdating = True
End Sub
二、
其它
1.調(diào)整圖片大小
Sub setpicsize()
'設(shè)置圖片大小
Dim n
'圖片個數(shù)
On Error Resume
Next '忽略錯誤
For n = 1 To
ActiveDocument.InlineShapes.Count 'InlineShapes類型圖片
ActiveDocument.InlineShapes(n).Height = 400
'設(shè)置圖片高度為
400px
ActiveDocument.InlineShapes(n).Width = 300
'設(shè)置圖片寬度
300px
Next
n
For n = 1 To
ActiveDocument.Shapes.Count 'Shapes類型圖片
ActiveDocument.Shapes(n).Height = 400 '設(shè)置圖片高度為 400px
ActiveDocument.Shapes(n).Width = 300 '設(shè)置圖片寬度 300px
Next
n
End
Sub
2.轉(zhuǎn)字體
Sub
批量設(shè)置小5號字體() '此代碼為指定文件夾中所有選取的WORD文件的進行格式設(shè)置
Dim MyDialog As
FileDialog, vrtSelectedItem As Variant, Doc As Document
' On Error
Resume Next '忽略錯誤
'定義一個文件夾選取對話框
Set MyDialog =
Application.FileDialog(msoFileDialogFilePicker)
With
MyDialog
.Title =
"請選擇要處理的文檔(可多選)"
.Filters.Clear
'清除所有文件篩選器中的項目
.Filters.Add
"所有WORD 文件", "*.doc", 1 '增加篩選器的項目為所有WORD文件
.AllowMultiSelect = True '允許多項選擇
If .Show = -1
Then '確定
Application.ScreenUpdating = False
For Each
vrtSelectedItem In .SelectedItems '在所有選取項目中循環(huán)
Set Doc =
Documents.Open(FileName:=vrtSelectedItem,
Visible:=False)
With
Doc
With
.Content
With
.Font
' .NameFarEast =
"宋體" '中文字體,,已禁用
' .NameAscii =
"Times New Roman" '英文字體,,已禁用
.Size =
9
End
With
End
With
.Close
True
End
With
Next
Application.ScreenUpdating = True
End
If
End
With
MsgBox
"批量設(shè)置完畢!", vbInformation
End
Sub
3.轉(zhuǎn)文件格式
Sub
Macro1()
' Macro1
Macro
'
宏在 01-10-31錄制
'
Dim
name As
String
'文件名
name
= "01"
ChangeFileOpenDirectory "E:\VB_SOUCE\lib"
For
i = 1 To
2124
'文件數(shù)2124
Documents.Open filename:=name & ".txt",
ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="",
PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="",
WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
ActiveDocument.SaveAs filename:=name & ".txt", FileFormat:=
_
wdFormatTextLineBreaks, LockComments:=False, Password:="",
_
AddToRecentFiles:=True,
WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False,
SaveFormsData _
:=False, SaveAsAOCELetter:=False
ActiveWindow.Close
name = name + 1
If name < 10 Then name = "0" & name
Next
i
End
Sub
4、文件加密
sub
mima()
with
activedocument
.password="123"
.writepassword="456"
end with
end
sub
‘要注意的方面:第三行是打開權(quán)限,、第四行是修改權(quán)限,。
5、字符替換
Sub
字符替換()
'宏名稱,,可修改為其他字符
With ActiveDocument.Content.Find
'在當前文檔中進行查找
.Text = "其它"
'被替換的字符
.Replacement.Text = "其他"
'替換的字符
.Execute Replace:=wdReplaceAll, Forward:=True
'替換全部
End With
End
Sub
6,、替換引號
Sub
替換引號()
Dim Countx
As Integer, i As Integer, Sh As Byte '聲明變量
'以下代碼統(tǒng)計出文中的引號數(shù)目(包括""“”)
Countx =
0
On Error
Resume Next
With
ActiveDocument.Content.Find
Do While
.Execute(FindText:="""", Forward:=True, Format:=True) =
True
Countx =
Countx + 1
Loop
'以下代碼判斷引號是否配對出現(xiàn)
Sh =
Countx Mod 2
If Sh
<> 0 Then
MsgBox
"引號不配對!"
Exit Sub
'如果引號不配對,,則退出宏
End
If
End
With
For i = 1
To Countx
Sh = i Mod
2 '求i值除以2的余數(shù)
If Sh
<> 0 Then '如果余數(shù)不等于0(即為奇數(shù)),,則將相應(yīng)的引號替'換為“前z”
With
ActiveDocument.Content.Find
.Text =
""""
.Replacement.Text = "前z"
.Execute
Replace:=wdReplaceOne, Forward:=True
End
With
Else
With
ActiveDocument.Content.Find '反之則將相應(yīng)的引號替換為“后z”
.Text =
""""
.Replacement.Text = "后z"
.Execute
Replace:=wdReplaceOne, Forward:=True
End
With
End
If
Next
'進行下一對引號的替換
With
ActiveDocument.Content.Find
'以下代碼將所有的“前z”替換為左引號
.Text =
"前z"
.Replacement.Text = "“"
.Execute
Replace:=wdReplaceAll, Forward:=True
'以下代碼將所有的“后z”替換為右引號
.Text =
"后z"
.Replacement.Text = "”"
.Execute
Replace:=wdReplaceAll, Forward:=True
End
With
End
Sub
7、打印為PDF格式文件
Sub
打印為PDF格式文件()
On Error
GoTo c:
Dim a As
Balloon
Dim b As
String
b =
ActivePrinter
Options.PrintDrawingObjects = True '打印圖形對象
ActivePrinter = "Acrobat PDFWriter"
ActiveDocument.PrintOut
c:
ActivePrinter = b
End
Sub
8,、朗讀文本
Sub
朗讀文本()
On
Error Resume Next
StatusBar = "老劉鄭重提示:
執(zhí)行該命令后文本如果未朗讀完將不能進行其他操作,!"
Excel.Application.Speech.Speak (ActiveWindow.Selection)
End
Sub
9.
文獻標號上標化
Sub
文獻標號上標化()
'
'
參考文獻上標化 Macro
'
宏在 2006-11-3 由 *****
創(chuàng)建
'
Selection.HomeKey Unit:=wdStory
Selection.Find.Replacement.ClearFormatting
With
Selection.Find.Replacement.Font
.Superscript = True
End
With
With
Selection.Find
.Text = "\[[0-9,0-9,~~-\-\ ]@\]"
.Replacement.Text = ""
.MatchWildcards = True
End
With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Replacement.ClearFormatting
With
Selection.Find.Replacement.Font
.Superscript = True
End
With
With
Selection.Find
.Text = "[[0-9,,0-9,~~-\-\ ]@]"
.Replacement.Text = ""
.MatchWildcards = True
End
With
Selection.Find.Execute
Replace:=wdReplaceAll
End
Sub
10.
箭頭上方加文字
Sub
箭頭上方加文字()
'
'
箭頭上方加文字 Macro
'
宏在 2008-4-16 由 *****
創(chuàng)建
'
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty,
_
PreserveFormatting:=False
Selection.TypeBackspace
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="eq \o(\s\do2(──────────→),\s\up5(敲擊Delete鍵清除此段文字,,改填所需文字,酌情增減箭頭長度,,最后同時按下shift和F9))"
Selection.MoveLeft Unit:=wdCharacter, Count:=2
Selection.MoveLeft Unit:=wdWord, Count:=25, Extend:=wdExtend
‘顧經(jīng)宇的代碼是26,,改成25更好
End
Sub
11
添加參考文獻格式一,參考文獻在文檔末尾以1.2. 3. 格式排列
Sub
添加參考文獻格式一()
'
'
添加參考文獻 Macro
'
宏在 2008-4-17 由 *****
創(chuàng)建
'
Selection.Style = ActiveDocument.Styles("尾注引用")
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With
ActiveDocument.Endnotes
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End
With
ActiveDocument.Endnotes.Add Range:=Selection.Range,
Reference:=""
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1,
Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("默認段落字體")
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:=". "
End
Sub
12.
添加參考文獻格式二,,參考文獻在文檔末尾以[1] [2] [3]
格式排列,,修改自格式一的代碼
Sub
添加參考文獻格式二()
'
'
添加參考文獻 Macro
'
宏在 2008-4-17 由 *****
創(chuàng)建
'
Selection.Style = ActiveDocument.Styles("尾注引用")
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With
ActiveDocument.Endnotes
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End
With
ActiveDocument.Endnotes.Add Range:=Selection.Range,
Reference:=""
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1,
Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("默認段落字體")
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:="] "
Selection.MoveLeft Unit:=wdCharacter + 2, Count:=1
Selection.TypeText
Text:="["
End
Sub
13.
返回正文
Sub
返回正文()
'返回正文 Macro
'宏在 2008-4-16
由 *****
創(chuàng)建
'
If
ActiveWindow.ActivePane.View.Type = wdPageView Or ActiveWindow.
_
ActivePane.View.Type = wdOnlineView Or
ActiveWindow.ActivePane.View.Type _
= wdPrintPreview Then
ActiveWindow.View.SeekView = wdSeekMainDocument
Else
ActiveWindow.Panes(2).Close
End
If
Selection.MoveRight Unit:=wdCharacter, Count:=2
End
Sub
14.
再次引用已有參考文獻
Sub
引用編號()
'引用編號 Macro
'宏在 2008-4-16
由 *****
創(chuàng)建
'
Selection.Font.Superscript = wdToggle
Selection.TypeText Text:="[]"
Selection.MoveLeft Unit:=wdCharacter, Count:=1
With
Dialogs(wdDialogInsertCrossReference)
.InsertAsHyperlink = True
.Show
End
With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Superscript = wdToggle
End
Sub
15.
查找被刪參考文獻遺留引用,
Sub
查找被刪編號()
'要刪除某個參考文獻,,應(yīng)該在原始引用處刪除引用,,這樣可以一并刪除參考文獻,而不是在文檔末尾文獻列表處刪除
Selection.WholeStory
Selection.Fields.Update
Selection.Find.ClearFormatting
With
Selection.Find
.Text = "錯誤,!未定義書簽,。"
End
With
Selection.Find.Execute
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1,
Extend:=wdExtend
End
Sub
16,、統(tǒng)計修訂的字數(shù)
Sub test()
Dim Rev As Revision, c1 As Long, n1 As Integer, a As String
Dim Wd As Range, c2 As Long, n2 As Integer, b As String
For Each Rev In ActiveDocument.Revisions
If Rev.Type = wdRevisionInsert Then
For Each Wd In Rev.Range.Words
c1 = c1 + IIf(Wd Like "[一-龥]*",
Wd.Characters.Count, 1)
Next
n1 = n1 + 1
a = a & Rev.Range.text & vbTab
ElseIf Rev.Type = wdRevisionDelete Then
For Each Wd In Rev.Range.Words
c2 = c2 + IIf(Wd Like "[一-龥]*",
Wd.Characters.Count, 1)
Next
n2 = n2 + 1
b = b & Rev.Range.text & vbTab
End If
Next
MsgBox "增加內(nèi)容" & n1
& "處共" & c1
& "字;刪除內(nèi)容"
&
n2 & "處共" & c2
& "字,。"
End Sub
17,、快速提取腳注內(nèi)容
Sub test()
Dim oFootNote As Footnote, myRange As Range
Dim BeforeName As String, BeforeSize As Single
On Error Resume Next
Application.ScreenUpdating = False
For Each oFootNote In ActiveDocument.Footnotes
With oFootNote
Set myRange = ActiveDocument.Range(.Reference.Start,
.Reference.End)
.Range.Copy
With myRange
.Text = "(JZ: )"
BeforeName = .Font.Name
BeforeSize = .Font.Size
myRange.SetRange .Start + 4, .Start + 4
.Paste
.Font.Name = BeforeName
.Font.Size = BeforeSize
End With
End With
Next
Application.ScreenUpdating = True
End Sub
18、從任意頁面編排頁碼
Sub test()
myPath = "H:\temp"
Selection.HomeKey Unit:=wdStory
Set myRange = Selection.Range
curpage = 0
Application.ScreenUpdating = False
Do
prepage = curpage
pagenum = pagenum + 1
Set myRange = myRange.GoToNext(What:=wdGoToPage)
curpage = myRange.Start
endpage = myRange.Previous.Start
If curpage = prepage Then _
endpage = ActiveDocument.Content.End
ActiveDocument.Range(prepage, endpage).Copy
With Documents.Add
.Content.Paste
.SaveAs myPath & "Page" & pagenum & ".doc"
.Close
End With
If curpage = prepage Then Exit Do
Loop
Application.ScreenUpdating = True
End Sub
19,、批量實現(xiàn)縮放打印
Sub
test()
Application.ScreenUpdating = False
With Application.FileSearch
.LookIn = "h:\Downloads\temp5"
.FileType = msoFileTypeWordDocuments
If .Execute > 0 Then
Fori = 1To.FoundFiles.Count
Documents.Open FileName:=.FoundFiles(i)
ActiveDocument.PrintOutPrintZoomPaperWidth:=10433,
PrintZoomPaperHeight:=14742
ActiveDocument.Close False
Next i
End If
End With
Application.ScreenUpdating = True
End Sub
20,、對文檔內(nèi)容進行順序排列
Sub
macro1()
Dim s() As String, temp As String, i As Long
VBAs = Split(ActiveDocument.Content, Chr(13) & Chr(13))
For i = 0 To UBound(s) \ 2
temp = s(i)
s(i) = s(UBound(s) - i)
s(UBound(s) - i) = temp
Next
Documents.Add
ActiveDocument.Content.Text = Join(s, Chr(13) & Chr(13))
End Sub
21、替換Word文檔插圖的超鏈接
Sub text()
n = 0
For Eachs In ActiveDocument.Shapes
s.Select
ActiveDocument.Hyperlinks.Add Anchor:=Selection.ShapeRange, _
Address:="
n=n+1
Next
MsgBox "共替換"
&n& "個圖片,!"
End Sub
22,、為文檔的每頁添加固定內(nèi)容
Sub
test()
Dim m As Integer, n As Page
m = Selection.Information(wdNumberOfPagesInDocument)
Selection.HomeKey Unit:=wdStory
For o = 1 To m
With Selection
.TypeText Text:="機械制圖國家標準"
.GoToNext what:=wdGoToPage
End With
Next
End Sub
23、批量實現(xiàn)圖片的等比例縮
Sub test()
Dim Shp As Shape, InlineShp As InlineShape
Dim Bder As Border
With ActiveDocument
For Each Shp In .Shapes
Shp.LockAspectRatio = msoTrue
Shp.Width = 4 * 28.35
Next
For Each InlineShp In .InlineShapes
InlineShp.LockAspectRatio = msoTrue
InlineShp.Width = 4 * 28.35
For Each Bder In InlineShp.Borders
With Bder
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
Next
Next
End With
End Sub
‘上述代碼中的“LockAspectRatio = msoTrue”表示鎖定縱橫比,,如果不需要鎖定縱橫比,,那么可以修改為“LockAspectRatio = msoFalse”。
24,、提取域代碼
Sub
提取域代碼()
Dim
myRange As Range, myCodes As String
Set
myRange = Selection.Range
With
myRange
If .Fields.Count = 0 Then
MsgBox "您所選的內(nèi)容中沒有域代碼!", vbInformation
Exit Sub
Else
.Fields.Update
.TextRetrievalMode.IncludeFieldCodes = True
.TextRetrievalMode.IncludeHiddenText = True
myCodes = .Text
myCodes = VBA.Replace(myCodes, Chr(19), "{")
myCodes = VBA.Replace(myCodes, Chr(21), "}")
.SetRange .End, .End
.InsertAfter myCodes '"注意,""{}""是由Ctrl+F9組合鍵自動插入的域標志! " &
vbLf & "域代碼:" &
myCodes
.Font.Name = "Tahoma"
.Font.Size = 11
.Cut
End If
End
With
End
Sub
25,、'完美顯示圖片表格的普通視圖
Sub
完美顯示圖片表格的普通視圖()
'此宏為雨雪霏霏特別奉獻的小偏方,歡迎各位朋友測試,。
'如果文檔中的嵌入式圖片、表格顯示遲滯,、錯位,,運行此宏,將在普通視圖下完美顯示它們,。
ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
End
Sub
'26,、完美顯示圖片表格的頁面視圖
Sub
完美顯示圖片表格的頁面視圖()
'此宏為雨雪霏霏特別奉獻的小偏方,歡迎各位朋友測試,。
'如果文檔中的各種圖片,、表格顯示遲滯、錯位,,運行此宏,,將在頁面視圖下完美顯示它們。
ActiveDocument.PrintPreview
ActiveDocument.ClosePrintPreview
ActiveWindow.View.Type = wdNormalView
ActiveWindow.View.Type = wdPrintView
End
Sub
'27,、徹底刪除頁眉頁腳
Sub
徹底刪除頁眉頁腳()
'此宏為雨雪霏霏試寫,。思路來自:
'①konggs版主于2005-7-26
20:38、2005-7-27 08:51發(fā)表的帖子,,
'鏈接為http://club./viewthread.php?tid=112178,;
'②守柔版主于2005-7-27年發(fā)表于站內(nèi)的文章《Word中鮮為人知的三招》,
'鏈接為http://www./Article/ShowArticle.asp?ArticleID=439,。
'此宏不足處在于:
'①刪除頁眉頁腳后不能再恢復(fù),;
'②本地文檔進行刪除操作后不保存退出的話,會在下次啟動Word時出現(xiàn)文檔恢復(fù)窗格。
Dim
w, y As String
Application.ScreenUpdating = False
Set
w = ActiveDocument.HTMLProject.HTMLProjectItems(2)
If
ActiveDocument.HTMLProject.HTMLProjectItems.Count = 2
Then
If w.Name = "header.htm" Then
w.Text = ""
ActiveDocument.HTMLProject.RefreshProject
ActiveDocument.HTMLProject.RefreshDocument
If ActiveDocument.Name Like "*.doc" Then
MsgBox "本文檔頁眉頁腳已徹底清除,,請及時保存,。" & Chr(13) & _
"若退出本地文檔時未保存,重新啟動Word時將出現(xiàn)恢復(fù)窗格,。",
vbExclamation, "ExcelHome"
Else
Exit Sub
End If
End If
Else
MsgBox "本文檔當前未設(shè)置頁眉頁腳,,不需要進行刪除操作。", vbOKOnly, "ExcelHome"
End
If
Application.ScreenUpdating = True
End
Sub
'28,、切換縱橫向頁面
Sub
切換縱橫向頁面()
'在"縱向頁面"與"橫向頁面"間切換,。
If
ActiveDocument.PageSetup.Orientation = wdOrientLandscape
Then
ActiveDocument.PageSetup.Orientation = wdOrientPortrait
Else
ActiveDocument.PageSetup.Orientation = wdOrientLandscape
End
If
End
Sub
|