OFFICE | WORD VBA 合集
生活随笔
收集整理的這篇文章主要介紹了
OFFICE | WORD VBA 合集
小編覺得挺不錯的,現在分享給大家,幫大家做個參考.
Sub 批量彩色變黑白()
'
' 批量圖片顏色沖蝕 宏
'
'
For Each InlineShape In ActiveDocument.InlineShapes
InlineShape.PictureFormat.ColorType = msoPictureGrayscale
InlineShape.PictureFormat.IncrementContrast 0.1
Next InlineShapeMsgBox "處理完畢！"End SubSub 黑白變彩色()
'
' 圖片顏色自動 宏
'
'
For Each InlineShape In ActiveDocument.InlineShapes
InlineShape.PictureFormat.ColorType = msoPictureAutomatic
InlineShape.PictureFormat.IncrementContrast 0.1
Next InlineShapeMsgBox "處理完畢！"End SubSub 圖片大小批量設置()
'
' 批量圖片大小設置 宏
'
'
Dim n ' 圖片個數W = InputBox("輸入要設置的圖片寬度（px）", "輸入寬度", 415)
H = InputBox("輸入要設置的圖片高度（px）", "輸入高度", 415)On Error Resume Next ' 忽略錯誤
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes 類型圖片
ActiveDocument.InlineShapes(n).LockAspectRatio = msoTrue ' 鎖定縱橫比
ActiveDocument.InlineShapes(n).Height = H '設置圖片高度為 **px，根據效果調整
ActiveDocument.InlineShapes(n).Width = W '設置圖片寬度 **px，根據效果調整
Next nFor n = 1 To ActiveDocument.Shapes.Count 'Shapes 類型圖片
ActiveDocument.Shapes(n).LockAspectRatio = msoTrue ' 鎖定縱橫比
ActiveDocument.Shapes(n).Height = H '設置圖片高度為 **px，根據效果調整
ActiveDocument.Shapes(n).Width = W '設置圖片寬度 **px，根據效果調整
Next nMsgBox "處理完畢！"End SubSub 圖片大小設置()
'
' 選中圖片大小設置 宏
'
'
Dim n ' 圖片個數W = InputBox("輸入要設置的圖片寬度（px）", "輸入寬度", 460)
H = InputBox("輸入要設置的圖片高度（px）", "輸入高度", 460)On Error Resume Next ' 忽略錯誤
For n = 1 To Selection.InlineShapes.Count 'InlineShapes 類型圖片
Selection.InlineShapes(n).LockAspectRatio = msoTrue ' 鎖定縱橫比
Selection.InlineShapes(n).Height = H '設置圖片高度為 **px，根據效果調整
Selection.InlineShapes(n).Width = W '設置圖片寬度 **px，根據效果調整
Next nFor n = 1 To ActiveDocument.Shapes.Count 'Shapes 類型圖片
ActiveDocument.Shapes(n).LockAspectRatio = msoTrue ' 鎖定縱橫比
ActiveDocument.Shapes(n).Height = H '設置圖片高度為 **px，根據效果調整
ActiveDocument.Shapes(n).Width = W '設置圖片寬度 **px，根據效果調整
Next nMsgBox "處理完畢！"End SubSub 調整表格間距()
'
' 選中表格 調整間距、上下居中
'
'
Dim n ' 定義表格個數On Error Resume Next ' 忽略錯誤For n = 1 To Selection.Tables.Count '計算表格個數Selection.Tables(n).SelectWith Selection.Tables(n).TopPadding = CentimetersToPoints(0.1).BottomPadding = CentimetersToPoints(0.1).LeftPadding = CentimetersToPoints(0.19).RightPadding = CentimetersToPoints(0.19).Spacing = 0.AllowPageBreaks = True.AllowAutoFit = TrueEnd WithWith Selection.Cells(1).WordWrap = True.FitText = FalseEnd WithNext n'Selection.ParagraphFormat.LineSpacing = LinesToPoints(32888) 單倍行距'Selection.ParagraphFormat.LineSpacing = LinesToPoints(32906) 1.2倍行距'Selection.ParagraphFormat.LineSpacing = LinesToPoints(32948) '1.5倍行距End SubSub 批量調整表格間距()
'
' 批量選中表格 調整間距、上下居中
'
'
Dim n ' 定義表格個數On Error Resume Next ' 忽略錯誤For n = 1 To ActiveDocument.Tables.Count '計算表格個數With ActiveDocument.Tables(n).TopPadding = CentimetersToPoints(0.1).BottomPadding = CentimetersToPoints(0.1).LeftPadding = CentimetersToPoints(0.19).RightPadding = CentimetersToPoints(0.19).Spacing = 0.AllowPageBreaks = True.AllowAutoFit = TrueEnd WithWith ActiveDocument.Cells(1).WordWrap = True.FitText = FalseEnd WithNext n'ActiveDocument.ParagraphFormat.LineSpacing = LinesToPoints(32888) 單倍行距
End SubSub 根據內容調整表格()
'
' 根據內容自動調整表格 宏
'
'
Dim n ' 定義表格個數On Error Resume Next ' 忽略錯誤For n = 1 To ActiveDocument.Tables.Count '計算表格個數ActiveDocument.Tables(n).AutoFitBehavior (wdAutoFitContent) '將表格調整為根據內容自動調整Next nMsgBox "處理完畢！"End SubSub 根據窗口調整表格()
'
' 根據窗口自動調整表格 宏
'
'
Dim n ' 定義表格個數On Error Resume Next ' 忽略錯誤For n = 1 To ActiveDocument.Tables.Count '計算表格個數ActiveDocument.Tables(n).AutoFitBehavior (wdAutoFitWindow) '將表格調整為根據窗口自動調整Next nMsgBox "處理完畢！"End SubSub 首行縮進()
'
' 選中段落首行縮進 宏
'
'With Selection.ParagraphFormat.LeftIndent = CentimetersToPoints(0).RightIndent = CentimetersToPoints(0).SpaceBefore = 0.SpaceBeforeAuto = False.SpaceAfter = 0.SpaceAfterAuto = False.LineSpacingRule = wdLineSpace1pt5.Alignment = wdAlignParagraphJustify.WidowControl = False.KeepWithNext = False.KeepTogether = False.PageBreakBefore = False.NoLineNumber = False.Hyphenation = True.FirstLineIndent = CentimetersToPoints(0.35).OutlineLevel = wdOutlineLevelBodyText.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 2.LineUnitBefore = 0.LineUnitAfter = 0.MirrorIndents = False.TextboxTightWrap = wdTightNone.CollapsedByDefault = False.AutoAdjustRightIndent = True.DisableLineHeightGrid = False.FarEastLineBreakControl = True.WordWrap = True.HangingPunctuation = True.HalfWidthPunctuationOnTopOfLine = False.AddSpaceBetweenFarEastAndAlpha = True.AddSpaceBetweenFarEastAndDigit = True.BaseLineAlignment = wdBaselineAlignAutoEnd With
End SubSub 首行頂格()
'
' 選中段落首行頂格 宏
'
'With Selection.ParagraphFormat.LeftIndent = CentimetersToPoints(0).RightIndent = CentimetersToPoints(0).SpaceBefore = 0.SpaceBeforeAuto = False.SpaceAfter = 0.SpaceAfterAuto = False.LineSpacingRule = wdLineSpace1pt5.Alignment = wdAlignParagraphJustify.WidowControl = False.KeepWithNext = False.KeepTogether = False.PageBreakBefore = False.NoLineNumber = False.Hyphenation = True.FirstLineIndent = CentimetersToPoints(0).OutlineLevel = wdOutlineLevelBodyText.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 0.LineUnitBefore = 0.LineUnitAfter = 0.MirrorIndents = False.TextboxTightWrap = wdTightNone.CollapsedByDefault = False.AutoAdjustRightIndent = True.DisableLineHeightGrid = False.FarEastLineBreakControl = True.WordWrap = True.HangingPunctuation = True.HalfWidthPunctuationOnTopOfLine = False.AddSpaceBetweenFarEastAndAlpha = True.AddSpaceBetweenFarEastAndDigit = True.BaseLineAlignment = wdBaselineAlignAutoEnd With
End SubSub 圖片添加陰影()
'
' 圖片陰影外部居中 宏
'
'
Dim n ' 圖片個數
On Error Resume Next ' 忽略錯誤
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes 類型圖片
ActiveDocument.InlineShapes(n).Shadow.Type = msoShadow25 '陰影、外部、中Next nMsgBox "處理完畢！"End SubSub 圖片去除陰影()
'
' 圖片無邊框無陰影 宏
'
'
Dim n ' 圖片個數
On Error Resume Next ' 忽略錯誤
For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes 類型圖片
ActiveDocument.InlineShapes(n).Shadow.Type = msoShadow19 '無邊框無陰影
Next nMsgBox "處理完畢！"End SubSub 標題變黑修復()
'
' 標題變黑修復 宏
'
'For Each templ In ActiveDocument.ListTemplatesFor Each lev In templ.ListLevelslev.Font.ResetNext levNext templMsgBox "處理完畢！"End SubSub 提高對比度()
'
' 批量增加圖片對比度 宏
'
'Dim myShape As Shape, myIns As InlineShapeFor Each myIns In ActiveDocument.InlineShapesmyIns.PictureFormat.IncrementBrightness -0.15 '降亮度myIns.PictureFormat.IncrementContrast 0.3 '增對比度NextMsgBox "處理完畢！"End SubSub 降低對比度()
'
' 批量降低圖片對比度 宏
'
'Dim myShape As Shape, myIns As InlineShapeFor Each myIns In ActiveDocument.InlineShapesmyIns.PictureFormat.IncrementBrightness 0.15 '增亮度myIns.PictureFormat.IncrementContrast -0.3 '降對比度NextMsgBox "處理完畢！"End SubSub 表格添加序號()
'
' 表格自動序號 宏
'
'
Dim i As Integer
i = 1
'遍歷選中的單元格
With SelectionFor Each aCell In .CellsaCell.Range.Delete '刪除原有內容aCell.Range.InsertAfter i '輸入序號i = i + 1 '序號遞增Next aCell
End WithMsgBox "處理完畢！"End SubSub 表格金額求和()
'
' 表格金額求和 宏
'
'Selection.InsertFormula Formula:="=SUM(ABOVE)", NumberFormat:=ChrW(165) & _"#,##0.00;(" & ChrW(165) & "#,##0.00)"End SubSub 正文段落序號()
'
' 正文段落序號 宏
'
'With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1).NumberFormat = "（%1）".TrailingCharacter = wdTrailingSpace.NumberStyle = wdListNumberStyleArabic.NumberPosition = CentimetersToPoints(0.71).Alignment = wdListLevelAlignLeft.TextPosition = CentimetersToPoints(0).TabPosition = wdUndefined.ResetOnHigher = 0.StartAt = 1With .Font.Bold = wdUndefined.Italic = wdUndefined.StrikeThrough = wdUndefined.Subscript = wdUndefined.Superscript = wdUndefined.Shadow = wdUndefined.Outline = wdUndefined.Emboss = wdUndefined.Engrave = wdUndefined.AllCaps = wdUndefined.Hidden = wdUndefined.Underline = wdUndefined.Color = wdUndefined.Size = wdUndefined.Animation = wdUndefined.DoubleStrikeThrough = wdUndefined.Name = "宋體"End With.LinkedStyle = ""End WithListGalleries(wdNumberGallery).ListTemplates(1).Name = ""Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:= _False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _wdWord10ListBehavior
End SubSub 數字金額大寫()
'修正了原數據中含有千分位分隔符,并加入了空格容錯,允許數字中帶有空格Dim Numeric As Currency, IntPart As Long, DecimalPart As Byte, MyField As Field, Label As StringDim Jiao As Byte, Fen As Byte, Oddment As String, Odd As String, MyChinese As StringDim strNumber As StringConst ZWDX As String = "壹貳叁肆伍陸柒捌玖零" '定義一個中文大寫漢字常量On Error Resume Next '錯誤忽略Dim rg As RangeSet rg = Selection.Rangerg.SelectWith SelectionstrNumber = VBA.Replace(.Text, " ", "")Numeric = VBA.Round(VBA.CCur(strNumber), 2) '四舍五入保留小數點后兩位'判斷是否在表格中If .Information(wdWithInTable) Then _.MoveRight Unit:=wdCell Else .MoveRight Unit:=wdCharacter'對數據進行判斷,是否在指定的范圍內If VBA.Abs(Numeric) > 2147483647 Then MsgBox "數值超過范圍!", _vbOKOnly + vbExclamation, "Warning": Exit SubIntPart = Int(VBA.Abs(Numeric)) '定義一個正整數Odd = VBA.IIf(IntPart = 0, "", "元") '定義一個STRING變量'插入中文大寫前的標簽Label = VBA.IIf(Numeric = VBA.Abs(Numeric), "", " 負")'對小數點后面二位數進行擇定DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100Select Case DecimalPartCase Is = 0 '如果是0,即是選定的數據為整數Oddment = VBA.IIf(Odd = "", "", Odd & "整")Case Is < 10 '<10,即是零頭是分Oddment = VBA.IIf(Odd <> "", "元零" & VBA.Mid(ZWDX, DecimalPart, 1) & "分", _VBA.Mid(ZWDX, DecimalPart, 1) & "分")Case 10, 20, 30, 40, 50, 60, 70, 80, 90 '如果是角整Oddment = "元" & VBA.Mid(ZWDX, DecimalPart / 10, 1) & "角整"Case Else '既有角,又有分的情況Jiao = VBA.Left(CStr(DecimalPart), 1) '取得角面值Fen = VBA.Right(CStr(DecimalPart), 1) '取得分面值Oddment = Odd & VBA.Mid(ZWDX, Jiao, 1) & "角" '轉換為角的中文大寫Oddment = Oddment & VBA.Mid(ZWDX, Fen, 1) & "分" '轉換為分的中文大寫End Select'指定區域插入中文大寫格式的域Set MyField = .Fields.Add(Range:=rg, Text:="= " & IntPart & " \*CHINESENUM2")MyField.Select '選定域(最后是用指定文本覆蓋選定區域)'如果僅有角分情況下,Mychinese為""MyChinese = VBA.IIf(MyField.Result <> "零", MyField.Result, "").Text = Label & MyChinese & OddmentEnd WithSelection.Fields.Unlink
End Sub
總結
以上是生活随笔為你收集整理的OFFICE | WORD VBA 合集的全部內容，希望文章能夠幫你解決所遇到的問題。
- 上一篇： Linux下用openmp速度反而慢,c
- 下一篇： 利用VS的代码优化和openmp并行计算