' 自己写的宏

Declare Function CopyFile Lib "Kernel32.dll" Alias "CopyFileA" (ByVal Source As String, ByVal Dest As String, ByVal Flag As Boolean) As Boolean

Const CSAbout = vbCrLf & "Copyright (C) Kingron, All rights reserved" & vbCrLf & vbCrLf

Sub UpdateUI(Enabled As Boolean)

 Application.ScreenUpdating = Enabled

 Application.DisplayAlerts = Enabled

 Interactive = Enabled

End Sub

Private Sub SendMail(Address)

 Dim MS, MM

 

 On Error Resume Next

 Set MS = CreateObject("MSMAPI.MAPISession")

 Set MM = CreateObject("MSMAPI.MAPIMessages")

 

 MS.DownLoadMail = False

 MS.NewSession = False

 MS.LogonUI = True

 MS.SignOn

 

 MM.SessionID = MS.SessionID

 MM.Compose

 

 MM.RecipIndex = 0

 MM.RecipAddress = Address

 MM.MsgSubject = ActiveDocument.Name

 

 ActiveDocument.Save

 If ActiveDocument.Saved Then

   FName = "C:\" + ActiveDocument.Name

   CopyFile ActiveDocument.FullName, FName, False

   MM.AttachmentIndex = 0

   MM.AttachmentPathName = FName

   MM.Send True

   Kill FName

   MS.SignOff

 End If

End Sub

Function StringOfChar(Ch As String, Count As Integer)

 For i = 1 To Count

   StringOfChar = StringOfChar & Ch

 Next

End Function

Sub FindTextCount()

' 统计文本中指定字符出现的次数

 

 On Error Resume Next

 If ActiveDocument = "" Then Exit Sub

 Text = InputBox(CSAbout & "统计整个文档中指定字符出现的次数。" & StringOfChar(Chr(13), 2) & "请输入要统计次数的文本，可以使用特殊字符，例如^p=回车，和查找替换对话框中的类似：", "输入")

 If Text = "" Then Exit Sub

 

 UpdateUI (False)

 With ActiveDocument.Content.Find

   Do While .Execute(FindText:=Text) = True

     tim = tim + 1

   Loop

 End With

 UpdateUI (True)

 MsgBox ("当前文档共找到" + Str(tim) + "个"" + Text + ""。"), 48, "统计结果"

End Sub

Sub AddIndexItem()

'

' 把当前选择的文本转换成索引项目

'

   Bookmark = "Bookmark" + CStr(2147483648# * Rnd + 1)

   With ActiveDocument.Bookmarks

       .Add Range:=Selection.Range, Name:=Bookmark

       .DefaultSorting = wdSortByName

       .ShowHidden = False

   End With

   

   ' 添加索引项目

   ActiveDocument.Indexes.MarkEntry Range:=Selection.Range, Entry:=Selection.Text, EntryAutoText:=Selection.Text, _

       CrossReference:="", CrossReferenceAutoText:="", BookmarkName:=Bookmark

End Sub

Sub 发送附件()

'

' 发送附件 Macro

' 将当前的文件作为附件发送到MAPI邮件程序

'

 If Documents.Count = 0 Then

    MsgBox CSAbout & "当前没有打开的文件，无法发送邮件。", vbOKOnly + vbExclamation

 Else

    Addr = InputBox(CSAbout & "当前文件将被保存，如果不想继续，请点击取消" + Chr(13) + Chr(13) + "　　请输入收件人姓名或者电子邮件，多个收件人之间请使用分号(;)分隔：")

    If Addr <> "" Then SendMail (Addr)

 End If

End Sub

Sub PastAsText()

'

' PastAsText Macro

' 宏在 2004-7-22 由 Kingron 录制

'

   Selection.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:= _

       wdInLine, DisplayAsIcon:=False

End Sub

Sub InsertEquation()

   Selection.InlineShapes.AddOLEObject ClassType:="Equation.3", FileName:="", _

        LinkToFile:=False, DisplayAsIcon:=False

End Sub

Sub SumTable()

  On Error Resume Next

  If Selection.Information(wdWithInTable) = False Then

    MsgBox CSAbout & "请选择表格中需要计算的单元格再点击本按钮", vbExclamation

    Exit Sub

  End If

  Dim Total As Single

  Total = 0

  For Each Cell In Selection.Cells

    Total = Total + CDbl(Cell.Range.Words(1).Text)

  Next

  MsgBox Total

End Sub

Sub 调整表格边框()

'

' 调整表格边框 Macro

' 宏在 2006-1-20 由 一位不满意的Office用户 录制

'

   div = InputBox(CSAbout & "请输入表格内容与表格边框的边距" & vbCrLf & "单位厘米，格式：n.n；默认值0.2。", "输入边距", 0.2)

   If div = "" Then Exit Sub

   For Each T In ActiveDocument.Tables

     T.LeftPadding = CentimetersToPoints(div)

     T.RightPadding = CentimetersToPoints(div)

   Next

End Sub