|
Option Explicit Const StatMsg1 = "自动更正项: "
Const StatMsg2 = " 总共"
Const StatMsg3 = "正在格式化..."
Const StatMsg4 = "正在保存..."
Const TagText = "自动更正文件"
Const szAppName = "自动更正保存与备份"
Const szErrorMsg = "发生错误，请决定是否重试一次？"
Const szACEntriesErrorMsg = "发生错误，可能是文件格式不正确。"
Const szWarnMsg = "即将用备份文件中的自动更正定义项替换现有的自动更正定义项。是否进行替换"
Const szFormatIncorrect = "自动更正备份文件格式有误"
Const szRestoreCompletemsg = "恭喜您，自动更正列表恢复完成。" ' 隐藏当前窗体，创建一个新Word文档，调用GetAutoCorrectEntries()并在文件前部添加"自动更正文件",
' 调用SaveACDoc取得文件名后进行存盘 Private Sub BackupAclList() Dim Y As Integer Application.ScreenUpdating = False Application.Documents.Add
Y = GetAutoCorrectEntries() ' 调用GetAutoCorrectEntries()函数 With Selection '在表格前添加标题
.SplitTable
.TypeText Text:=TagText
.TypeParagraph
End With
With ActiveDocument.Sentences(1) '修改标题的格式
.Bold = True
.Font.Size = 14
.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With Application.StatusBar = StatMsg4 ' 保存文件 If SaveACDoc = True Then ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges Application.ScreenUpdating = True End Sub ' 将自动更正定义项保存到一个文件中，包括数值和是否包含格式
' 名称是定义项的文本输入内容，数值是定义项的替换内容
' 格式项为一个逻辑值，如果它是True则自动更正项为带格式文本
' 然后将内容转换为表格文字并为表格添加标题 Private Function GetAutoCorrectEntries()
Dim x As Integer
Dim TotalACEntries As Integer
TotalACEntries = Application.Autocorrect.Entries.Count '取得项目数
For x = 1 To TotalACEntries
With Selection
.TypeText Text:=Application.Autocorrect.Entries.Item(x).Name
.TypeText vbTab
'检查是否是带格式文本
If Application.Autocorrect.Entries.Item(x).RichText = True Then
Application.Autocorrect.Entries(x).Apply Range:=Selection.Range
Else
.TypeText Text:=Application.Autocorrect.Entries.Item(x).Value
End If
.TypeText vbTab '添加制表位
.TypeText Text:=Application.Autocorrect.Entries.Item(x).RichText
.TypeParagraph
End With
Application.StatusBar = "保存" & StatMsg1 & x & StatMsg2 & TotalACEntries
Next x
'将内容转换为表格
Application.StatusBar = StatMsg3
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=3
' add row heading
With Selection
.MoveUp Unit:=wdLine, Count:=1
.InsertRows 1
.TypeText Text:="替换"
.MoveRight Unit:=wdCell
.TypeText Text:="替换为"
.MoveRight Unit:=wdCell
.TypeText Text:="带格式文本"
.HomeKey Unit:=wdStory
End With
End Function
Public Function SaveACDoc()
Dim Style, Response As Integer
Dim Title As String SaveACDoc = True
Err.Clear
On Error GoTo SaveACDocErrors With Dialogs(wdDialogFileSaveAs)
.Name = TagText
.Show
End With
SaveACDocErrors:
Select Case Err.Number
Case 0: ' no error
Case 4198: ' cancel
SaveACDoc = False
Case Else
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = Err.Number & " " & Err.Description
Response = MsgBox(szErrorMsg, Style, Title)
If Response = vbYes Then
Resume 'bring up SaveAs again
Else ' User choose No.
SaveACDoc = False
End If
End Select
End Function
'
' 揭示用户是否进行操作，如果用户回答 NO 则结束程序.
' 若用户确认，则显示打开文件对话框，则用户选择备份文件(通过〖备份〗按钮创建的)，并用OpenACDoc()打开文件
' 若成功则调用RestoreACEntries()恢复自动更正项。最后关闭备份文件。
'
Private Sub RestoreAclList()
Dim ACFileName, Title As String
Dim Style, Response, x As Integer
Style = vbYesNo + vbInformation + vbDefaultButton2 ' Define buttons.
Title = szAppName
Response = MsgBox(szWarnMsg, Style, Title)
If Response = vbNo Then GoTo bye:
With Dialogs(wdDialogFileOpen)
.Name = "*.doc"
.Display
ACFileName = .Name
End With If OpenACDoc(ACFileName) = True Then
x = RestoreACEntries()
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If bye:
End Sub Function RestoreACEntries()
Dim I, NumRows As Integer
Dim oDoc, oACorrect, oTable As Object Dim szName As String, szValue As String, szRTF As String Err.Clear
On Error GoTo RestoreACEntriesErrors: If ActiveDocument.Words(1) <> "自动更正" Then '检查文件的合格性
MsgBox szFormatIncorrect
Exit Function
End If
Application.ScreenUpdating = False
Set oDoc = ActiveDocument
Set oTable = oDoc.Tables(1)
Set oACorrect = Application.Autocorrect.Entries NumRows = ActiveDocument.Tables(1).Rows.Count
Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst
Selection.MoveRight Unit:=wdCell, Count:=3
For I = 2 To NumRows
szName = Selection.Text
Selection.MoveRight Unit:=wdCell: szValue = Selection.Text
Selection.MoveRight Unit:=wdCell: szRTF = Selection.Text
If szRTF = "False" Then
Application.StatusBar = "恢复" & StatMsg1 & szName
oACorrect.Add Name:=szName, Value:=szValue
Else
Application.StatusBar = "恢复" & StatMsg1 & szName
Selection.MoveLeft Unit:=wdCell
oACorrect.AddRichText szName, Selection.Range
Selection.MoveRight Unit:=wdCell
End If
Selection.MoveRight Unit:=wdCell
Next I
Application.ScreenUpdating = True
MsgBox szRestoreCompletemsg
RestoreACEntriesErrors:
Select Case Err.Number
Case 0: ' no error
Case Else
MsgBox (szACEntriesErrorMsg & vbCr & Err.Number & " " & Err.Description & " " & szName)
End Select
End Function
Public Function OpenACDoc(ByVal ACFileOpenName As String) As Boolean Dim Style As Integer OpenACDoc = True
Err.Clear
On Error GoTo OpenACDocErrors Documents.Open FileName:=ACFileOpenName OpenACDocErrors:
If Err.Number <> 0 Then OpenACDoc = False
End Function Private Sub Document_New()
Dim Response As Integer, strInfo As String
strInfo = "你可以用这这个程序备份或恢复自动更正列表。" + vbCrLf + vbCrLf + "〖 是 〗：创建一个保存有自动更正项的Word文档。" + vbCrLf + "〖 否 〗：从您保存的备份Word文档中恢复自动更正列表。" + vbCrLf + "选择〖取消〗则结束程序。" + vbCrLf
ReD
Response = MsgBox(strInfo, vbQuestion + vbYesNoCancel, "选择功能")
Select Case Response
Case vbYes
BackupAclList
GoTo ReDO
Case vbNo
RestoreAclList
GoTo ReDO
Case vbCancel
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End Select
End Sub Private Sub Document_Open()
'ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End Sub
[此贴子已经被konggs于2008-1-27 10:20:43编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-6-20 23:11
楼主
