【1】
Sub 批量圖片1增對比度和降亮度()
Dim myShape As Shape, myIns As InlineShape
For Each myIns In ActiveDocument.InlineShapes
myIns.PictureFormat.IncrementBrightness -0.15 '降亮度
myIns.PictureFormat.IncrementContrast 0.3 '增對比度
Next
End Sub
【2】
Sub 批量圖片2降對比度和增亮度()
Dim myShape As Shape, myIns As InlineShape
For Each myIns In ActiveDocument.InlineShapes
myIns.PictureFormat.IncrementBrightness 0.15 '增亮度
myIns.PictureFormat.IncrementContrast -0.3 '降對比度
Next
End Sub
【3】
Sub 批量調(diào)整多個文檔圖片大小()
Dim fd As FileDialog, vrtSelectedItem As Variant, wd As Document, p As InlineShape, w, h
Application.ScreenUpdating = False
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
.InitialFileName = ActiveDocument.Path
If .Show <> -1 Then
Application.ScreenUpdating = True
MsgBox '您沒有選擇任何文檔！', vbOK, '退出'
Exit Sub
Else
w = InputBox('輸入要設(shè)置的圖片寬度（cm）', '輸入寬度', 8)
h = InputBox('輸入要設(shè)置的圖片高度（cm）', '輸入寬度', 8)
For Each vrtSelectedItem In .SelectedItems
Set wd = Documents.Open(vrtSelectedItem)
For Each p In wd.InlineShapes
p.LockAspectRatio = msoFalse '取消鎖定縱橫比
p.Width = Round(w / 2.54 * 72 * 4, 0) / 4 '將磅單位轉(zhuǎn)化成厘米
p.Height = Round(h / 2.54 * 72 * 4, 0) / 4
Next
wd.Close savechanges:=True
Set wd = Nothing
Next
End If
End With
Application.ScreenUpdating = True
MsgBox '圖片設(shè)置完成！', , '運(yùn)行完成 @蕭260961242'
End Sub
【4】處理word內(nèi)嵌Excel
說明：1、原始的Word文檔放在名為“word”的子目錄里
2、包含本代碼的宏文檔放在“word”的上一層
3、提取出來的Excel文檔存到名為“excel”的子目錄，和“word”并列
4、因?yàn)閮?nèi)嵌的Excel文檔比較多，加了一個條件判斷，只把label包含有“問題”的Excel存下來，不需要的話可以去掉
5、運(yùn)行代碼時Excel處于關(guān)閉狀態(tài)，所有word文檔（除了本宏文檔）處于關(guān)閉狀態(tài)
Sub Export_Embedded_Excel()
Dim wdDoc As Document '用于打開子目錄里word文檔
Dim iCtr As Integer '用于遍歷word文檔里Inlineshapes
Dim i As Long '用于遍歷文件夾里的word文檔
Dim xlApp As Object '用于打開內(nèi)嵌object
Dim objName As String '用于獲得內(nèi)嵌object的label
Dim city As String '用于獲得word文檔的文件名并作為Excel文檔命名的一部分
path = ThisDocument.path
On Error Resume Next
' 逐個打開word文件夾里的文檔
With Application.FileSearch
.NewSearch
.LookIn = path & '\word'
.SearchSubFolders = False
.FileName = '*.doc'
.FileType = msoFileTypeWordDocuments
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Set wdDoc = Documents.Open(FileName:=.FoundFiles(i))
city = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
Set xlApp = CreateObject('Excel.Application') '這行代碼很關(guān)鍵
' 把文檔里內(nèi)嵌的、名字里包含“問題”的excel文件保存下來
For iCtr = 1 To wdDoc.InlineShapes.Count
If wdDoc.InlineShapes(iCtr).Type = wdInlineShapeEmbeddedOLEObject Then
If wdDoc.InlineShapes(iCtr).OLEFormat.ProgID = 'Excel.Sheet.8' Then
If wdDoc.InlineShapes(iCtr).OLEFormat.IconLabel Like '*問題*' Then
objName = wdDoc.InlineShapes(iCtr).OLEFormat.IconLabel
wdDoc.InlineShapes(iCtr).OLEFormat.Open
Set xlApp = GetObject(, 'Excel.Application')
xlApp.Workbooks(1).SaveAs FileName:=path & '\excel\' & city & objName & iCtr & '.xls'
xlApp.Workbooks(1).Close
End If
End If
End If
Next iCtr
xlApp.Quit
Set xlApp = Nothing
wdDoc.Close False
' 下一個文檔
Next i
End If
End With
End Sub
【5】刪除圖片文字-AlternativeText
Sub 刪除可選文字()
Dim oShape As Shape
Dim oInlineShape As InlineShape
For Each oShape In ActiveDocument.Shapes
oShape.AlternativeText = '要刪除“可選文字”則此處留空，也可以替換成自己需要的文字'
Next
For Each oInlineShape In ActiveDocument.InlineShapes
oInlineShape.AlternativeText = '要刪除“可選文字”則此處留空，也可以替換成自己需要的文字'
Next
MsgBox '處理完畢！'
End Sub
【6】排版
Sub 格式設(shè)置()
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
'替換非標(biāo)準(zhǔn)引號為標(biāo)準(zhǔn)引號
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 = '０１２３４５６７８９ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ,./<>?;’:[]{}\|=-+_)(*%$#@!`~&'
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ù)點(diǎn)錯誤
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è)置段首縮進(jìn)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
【6】文檔合并
Sub 批量合并()
On Error Resume Next
Dim fd As FileDialog, i&, doc As Document, p$, t&, j&, s As Section, k&, n&, m&, c&
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
Set fd = Nothing
If MsgBox('是否合并文件夾 ' & p & ' ?', 4 + 48) = vbNo Then End
If MsgBox('<是>：Word 文檔(*.doc) <否>：文本文檔(*.txt)', 4 + 48) = vbYes Then t = 0 Else t = 1
If MsgBox('請選擇分隔符！——<是>：分節(jié)符 <否>：分頁符', 4 + 48) = vbYes Then j = 1 Else j = 0
If j = 1 Then
If MsgBox('每節(jié)頁碼！——<是>：重排 <否>：順延', 4 + 48) = vbYes Then k = 1 Else k = 2
Else
k = 2
End If
Documents.Add
With Application.FileSearch
.NewSearch
.LookIn = p
.SearchSubFolders = True
If t = 0 Then .FileName = '*.doc' Else .FileName = '*.txt'
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
If t = 0 Then
Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
Else
Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936, Visible:=False)
End If
doc.Content.Copy
doc.Close
Selection.EndKey 6
Selection.Paste
ActiveDocument.Characters(1).Copy
If j = 1 Then
Selection.InsertBreak Type:=wdSectionBreakNextPage
Else
Selection.InsertBreak Type:=wdPageBreak
End If
Next i
MsgBox '合并完畢！共合并 ' & .FoundFiles.Count & ' 個文件！', 0 + 64
Else
MsgBox '未發(fā)現(xiàn)文件！', 0 + 16
End If
End With
With ActiveDocument
.Characters.Last.Previous.Delete
.Characters.Last.Previous.Delete
'重排頁碼
For Each s In .Sections
s.Range.Select
With Selection.Sections(1).Headers(1).PageNumbers
.NumberStyle = wdPageNumberStyleNumberInDash
If k = 1 Then .RestartNumberingAtSection = True Else .RestartNumberingAtSection = False
.StartingNumber = 1
End With
Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=True
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.HeaderFooter.LinkToPrevious = Not Selection.HeaderFooter.LinkToPrevious
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Next
Selection.HomeKey 6
'奇數(shù)加頁
Do
For Each s In .Sections
n = s.Range.Information(3)
n = n - m
m = m + n
If n Mod 2 = 1 Then
s.Range.Characters.Last.InsertBreak Type:=wdPageBreak
n = 0
m = 0
c = 1
Exit For
Else
c = 0
End If
Next
Loop Until c = 0
End With
End Sub
