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 合集相关推荐

全国计算机二级office选择题知识点,全国计算机二级考试MS office选择题知识点合集(通用)...
全国计算机二级考试MS office选择题知识点合集(通用) 计算机二级选择题考点总结 2014年计算机二级 office高级应用考试基础知识计算机的发展.类型及其应用领域. 1.计算机 (comp ...
【WORD技巧合集】
懒人WORD 一.常用宏 1.1 一键选中所有表格一.常用宏打开宏快捷键:ALT+F8 1.1 一键选中所有表格应用场景: word内容太多,表格也很多,但格式又不统一,一个个调太麻烦,怎么办呢 ...
FILEminimizer Office，FILEminimizer Suite和FILEminimizer Server常见问题FAQ合集（一）
FILEminimizer Office,FILEminimizer Suite和FILEminimizer Server常见问题FAQ合集. 1.我的序列号和注册信息都无法使用? 注册信息包括三部分 ...
suite服务器文件,FILEminimizer Office，FILEminimizer Suite和FILEminimizer Server问题合集
原标题:FILEminimizer Office,FILEminimizer Suite和FILEminimizer Server问题合集 FILEminimizer Office,FILEminim ...
c语言关于office运行库,VC++运行库32/64位合集下载|微软常用运行库合集(2015- 2021版)...
Microsoft Visual C++简称Visual C++,是一款免费C++开发工具,具有集成开发环境,可提供编辑C语言,C++以及C++/CLI等编程语言.集成了便利的除错工具,特别是集成了微 ...
大学“电路分析基础”试题合集第六章（文末附PDF文档与Word文档）
大学"电路分析基础"试题合集第一章大学"电路分析基础"试题合集第二章大学"电路分析基础"试题合集第三章大学"电路分析基础&q ...
aspose使用合集java（Word、Excel、PPT转PDF）
aspose使用合集java(Word.Excel.PPT转PDF) aspose使用合集java(Word.Excel.PPT转PDF 文档所需jar包 Word转为PDF 获取license 简单 ...
【最全下载合集】最新Office 2021微软官方原版离线安装下载地址合集
Office2021下载地址合集说明:仅支持Win10/11系统,img镜像Win10/11下直接装载打开即可. 一.专业增强版(强烈推荐): http://officecdn.microsoft. ...
企业组织架构可编辑Word模板大合集（共105份）
合集名称:企业组织架构Word模板(可编辑) 数量:105份具体内容: 下载链接:企业组织架构Word模板大合集(共104份).zip-数据集文档类资源-CSDN下载下载链接:企业组织架构Wo ...
PS、AE、PR、CAD、SPSS、3D Max、Maya、Office 等常用软件插件合集
去年的时候小资源当了一阵的设计公司运营,趁着摸鱼的同时,也会给公司搜集各种好用的插件毕竟插件谁用谁知道,这是可以大大提高工作效率的东西呀所以最近小资源又花了一点时间来给大家收集整理出了此次推文 ...

OFFICE | WORD VBA 合集

OFFICE | WORD VBA 合集相关推荐

最新文章

热门文章