|
|
楼主 |
发表于 2005-4-22 14:10
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
|
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-4-22 15:26:47
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Dim StandardFontColor As Long, WorkFontColor As Long
Sub CompareFormat()
Dim StandardDoc As Document, aDoc As Document, MyDialog As FileDialog, vrtSelectedItem As Variant
Dim i As Paragraph, Worki As Paragraph, ParCount As Integer
Dim StandardFontName As String, StandardFontSize As Single
Dim WorkFontName As String, WorkFontSize As Single
Dim StandardParLeftIndent As Single, StandardParLineSpacing As Single, StandardParSpaceAfter As Single
Dim WorkParLeftIndent As Single, WorkParLineSpacing As Single, WorkParSpaceAfter As Single
Dim StandardParSpaceBefore As Single, WorkParSpaceBefore As Single
Dim StandardPageTop As Single, StandardPageBottom As Single, StandardPageLeft As Single, StandardPageRight As Single
Dim WorkPageTop As Single, WorkPageBottom As Single, WorkPageLeft As Single, WorkPageRight As Single
Dim StandardPaperSize As PageSetup, StandardPaperOrientation As Byte
Dim WorkPaperSize As PageSetup, WorkPaperOrientation As Byte
Dim aChar As Range, CharCount As Long, ErrCount As Long
Dim ErrorText As String
On Error Resume Next
Set StandardDoc = Documents.Open(FileName:="E:\Word作业样板.Doc", Visible:=False)
'定义一个文件夹选取对话框
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择,可用SHIFT/CTRL进行选定
End With
If MyDialog.Show = -1 Then '确定
Application.ScreenUpdating = False '关闭屏幕更新
For Each vrtSelectedItem In MyDialog.SelectedItems '在所有选取项目中循环
Set aDoc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)
' MsgBox "Selected item's path: " & vrtSelectedItem
ParCount = 0: CharCount = 0: ErrCount = 0 '初始化变量
With aDoc
ErrorText = Chr(13) & "文档名:" & .Name & "文档作者:" & .BuiltInDocumentProperties("Author") & Chr(13)
''''''标准文档获得页边距
With StandardDoc.PageSetup
StandardPaperSize = .PaperSize
StandardPaperOrientation = .Orientation
StandardPageTop = VBA.Round(.TopMargin, 2)
StandardPageBottom = VBA.Round(.BottomMargin, 2)
StandardPageLeft = VBA.Round(.LeftMargin, 2)
StandardPageRight = VBA.Round(.RightMargin, 2)
End With
'''''获得作业文档的页边距
With .PageSetup
WorkPaperSize = .PaperSize
WorkPaperOrientation = .Orientation
WorkPageTop = VBA.Round(.TopMargin, 2)
WorkPageBottom = VBA.Round(.BottomMargin, 2)
WorkPageLeft = VBA.Round(.LeftMargin, 2)
WorkPageRight = VBA.Round(.RightMargin, 2)
End With
''''''''''''''''''''''''''''''''''比较页面设置
If StandardPaperSize <> WorkPaperSize Then ErrorText = ErrorText & "纸张大小不一致" & Chr(13)
If StandardPaperOrientation <> WorkPaperOrientation Then ErrorText = ErrorText & "纸型方向不一致" & Chr(13)
If StandardPageTop <> WorkPageTop Then ErrorText = ErrorText & "上页边距不符,应为" & StandardPageTop & "实为" & WorkPageTop & Chr(13)
If StandardPageBottom <> WorkPageBottom Then ErrorText = ErrorText & "下页边距不符,应为" & StandardPageBottom & "实为" & WorkPageBottom & Chr(13)
If StandardPageLeft <> WorkPageLeft Then ErrorText = ErrorText & "左页边距不符,应为" & StandardPageLeft & "实为" & WorkPageLeft & Chr(13)
If StandardPageRight <> WorkPageRight Then ErrorText = ErrorText & "右页边距不符,应为" & StandardPageRight & "实为" & WorkPageRight & Chr(13)
For Each Worki In .Paragraphs
ParCount = ParCount + 1
'''''取得段落格式
With StandardDoc.Paragraphs(ParCount).Format
StandardParLeftIndent = .FirstLineIndent
StandardParLineSpacing = .LineSpacing
StandardParSpaceAfter = .SpaceAfter
StandardParSpaceBefore = .SpaceBefore
End With
'''取得字体格式
With StandardDoc.Paragraphs(ParCount).Range
StandardFontName = .Font.NameFarEast
StandardFontSize = .Font.Size
StandardFontColor = .Font.Color
End With
''''取得段落格式
With Worki.Format
WorkParLeftIndent = .FirstLineIndent
WorkParLineSpacing = .LineSpacing
WorkParSpaceAfter = .SpaceAfter
WorkParSpaceBefore = .SpaceBefore
End With
''''取得字体格式
With Worki.Range
WorkFontName = .Font.NameFarEast
WorkFontSize = .Font.Size
WorkFontColor = .Font.Color
End With
'''''''''''''''''''''''''''''比较段落格式
If StandardParLeftIndent <> WorkParLeftIndent Then ErrorText = ErrorText & "第" & ParCount & "段落首行缩进不符,应为" & StandardParLeftIndent & "实为" & WorkParLeftIndent & Chr(13)
If StandardParLineSpacing <> WorkParLineSpacing Then ErrorText = ErrorText & "第" & ParCount & "行间距不符,应为" & StandardParLineSpacing & "实为" & WorkParLineSpacing & Chr(13)
If StandardParSpaceAfter <> WorkParSpaceAfter Then ErrorText = ErrorText & "第" & ParCount & "段后间距不符,应为" & StandardParSpaceAfter & "实为" & WorkParSpaceAfter & Chr(13)
If StandardParSpaceBefore <> WorkParSpaceBefore Then ErrorText = ErrorText & "第" & ParCount & "段前间距不符,应为" & StandardParSpaceBefore & "实为" & WorkParSpaceBefore & Chr(13)
'''''''''''''''''''''''''''''比较字体格式
If StandardFontName <> WorkFontName Then ErrorText = ErrorText & "第" & ParCount & "段落中中文字体不符,应为" & StandardFontName & "实为" & WorkFontName & Chr(13)
If StandardFontSize <> WorkFontSize Then ErrorText = ErrorText & "第" & ParCount & "段落中中文字体字号不符,应为" & StandardFontSize & "实为" & WorkFontSize & Chr(13)
If StandardFontColor <> WorkFontColor Then ErrorText = ErrorText & "第" & ParCount & "段落中中文字体颜色不符,应为" & GetStandardFontColor & "实为" & GetWorkFontColor & Chr(13)
Next Worki
For Each aChar In .Characters '在作业文档的字中循环
CharCount = CharCount + 1 '计数
If aChar <> StandardDoc.Characters(CharCount) Then '比较
ErrCount = ErrCount + 1 '计数
aChar.Font.StrikeThrough = True '删除线
aChar.Font.Color = wdColorRed '红色字体
End If
Next aChar
ErrorText = ErrorText & "标准文档段落总数为" & StandardDoc.Paragraphs.Count & ",此文档段落总数为" & .Paragraphs.Count & Chr(13)
ErrorText = ErrorText & "标准文档全长" & StandardDoc.Content.End & ",此文档全长" & .Content.End & Chr(13)
ErrorText = ErrorText & "录入文字正确率:" & .Characters.Count - ErrCount & "/" & .Characters.Count & "=" & VBA.Round(((.Characters.Count - ErrCount) / .Characters.Count * 100), 2) & "%" & Chr(13)
ErrorText = ErrorText & Application.UserName & Now & Chr(13)
ErrorText = ErrorText & "*******************************************************"
ThisDocument.Content.InsertAfter ErrorText
.Content.InsertAfter ErrorText
.Close True '保存文档(内含批改记录)
End With
Next vrtSelectedItem
StandardDoc.Close False
Application.ScreenUpdating = True '恢复屏幕更新
MsgBox "全部文档检查完毕,请核查!", vbOKOnly + vbExclamation
End If
End Sub
'----------------------
Function GetStandardFontColor() As String
Select Case StandardFontColor
Case Is = -16777216
GetStandardFontColor = "自动色"
Case Is = 0
GetStandardFontColor = "黑色"
Case Is = 13209
GetStandardFontColor = "褐色"
Case Is = 13107
GetStandardFontColor = "橄榄绿"
Case Is = 13056
GetStandardFontColor = "深绿"
Case Is = 6697728
GetStandardFontColor = "深灰蓝"
Case Is = 8388608
GetStandardFontColor = "深蓝"
Case Is = 10040115
GetStandardFontColor = "靛蓝"
Case Is = 3355443
GetStandardFontColor = "灰色-80%"
Case Is = 128
GetStandardFontColor = "深红"
Case Is = 26367
GetStandardFontColor = "桔黄"
Case Is = 32896
GetStandardFontColor = "深黄"
Case Is = 32768
GetStandardFontColor = "绿色"
Case Is = 8421376
GetStandardFontColor = "蓝绿色"
Case Is = 16711680
GetStandardFontColor = "蓝色"
Case Is = 10053222
GetStandardFontColor = "蓝-灰"
Case Is = 8421504
GetStandardFontColor = "灰色-50%"
Case Is = 255
GetStandardFontColor = "红色"
Case Is = 39423
GetStandardFontColor = "浅桔黄"
Case Is = 52377
GetStandardFontColor = "酸橙色"
Case Is = 6723891
GetStandardFontColor = "海绿"
Case Is = 13421619
GetStandardFontColor = "宝石蓝"
Case Is = 16737843
GetStandardFontColor = "浅蓝"
Case Is = 8388736
GetStandardFontColor = "紫色"
Case Is = 10066329
GetStandardFontColor = "灰色-40%"
Case Is = 16711935
GetStandardFontColor = "粉红"
Case Is = 52479
GetStandardFontColor = "金色"
Case Is = 65535
GetStandardFontColor = "黄色"
Case Is = 65280
GetStandardFontColor = "鲜绿"
Case Is = 16776960
GetStandardFontColor = "青绿"
Case Is = 16763904
GetStandardFontColor = "天蓝"
Case Is = 6697881
GetStandardFontColor = "梅红"
Case Is = 12632256
GetStandardFontColor = "灰色"
Case Is = 13408767
GetStandardFontColor = "玫瑰红"
Case Is = 10079487
GetStandardFontColor = "棕黄"
Case Is = 10092543
GetStandardFontColor = "浅黄"
Case Is = 13434828
GetStandardFontColor = "浅绿"
Case Is = 16777164
GetStandardFontColor = "浅青绿"
Case Is = 16764057
GetStandardFontColor = "淡蓝"
Case Is = 16751052
GetStandardFontColor = "淡紫"
Case Is = 16777215
GetStandardFontColor = "白色"
End Select
End Function
'----------------------
Function GetWorkFontColor() As String
Select Case WorkFontColor
Case Is = -16777216
GetWorkFontColor = "自动色"
Case Is = 0
GetWorkFontColor = "黑色"
Case Is = 13209
GetWorkFontColor = "褐色"
Case Is = 13107
GetWorkFontColor = "橄榄绿"
Case Is = 13056
GetWorkFontColor = "深绿"
Case Is = 6697728
GetWorkFontColor = "深灰蓝"
Case Is = 8388608
GetWorkFontColor = "深蓝"
Case Is = 10040115
GetWorkFontColor = "靛蓝"
Case Is = 3355443
GetWorkFontColor = "灰色-80%"
Case Is = 128
GetWorkFontColor = "深红"
Case Is = 26367
GetWorkFontColor = "桔黄"
Case Is = 32896
GetWorkFontColor = "深黄"
Case Is = 32768
GetWorkFontColor = "绿色"
Case Is = 8421376
GetWorkFontColor = "蓝绿色"
Case Is = 16711680
GetWorkFontColor = "蓝色"
Case Is = 10053222
GetWorkFontColor = "蓝-灰"
Case Is = 8421504
GetWorkFontColor = "灰色-50%"
Case Is = 255
GetWorkFontColor = "红色"
Case Is = 39423
GetWorkFontColor = "浅桔黄"
Case Is = 52377
GetWorkFontColor = "酸橙色"
Case Is = 6723891
GetWorkFontColor = "海绿"
Case Is = 13421619
GetWorkFontColor = "宝石蓝"
Case Is = 16737843
GetWorkFontColor = "浅蓝"
Case Is = 8388736
GetWorkFontColor = "紫色"
Case Is = 10066329
GetWorkFontColor = "灰色-40%"
Case Is = 16711935
GetWorkFontColor = "粉红"
Case Is = 52479
GetWorkFontColor = "金色"
Case Is = 65535
GetWorkFontColor = "黄色"
Case Is = 65280
GetWorkFontColor = "鲜绿"
Case Is = 16776960
GetWorkFontColor = "青绿"
Case Is = 16763904
GetWorkFontColor = "天蓝"
Case Is = 6697881
GetWorkFontColor = "梅红"
Case Is = 12632256
GetWorkFontColor = "灰色"
Case Is = 13408767
GetWorkFontColor = "玫瑰红"
Case Is = 10079487
GetWorkFontColor = "棕黄"
Case Is = 10092543
GetWorkFontColor = "浅黄"
Case Is = 13434828
GetWorkFontColor = "浅绿"
Case Is = 16777164
GetWorkFontColor = "浅青绿"
Case Is = 16764057
GetWorkFontColor = "淡蓝"
Case Is = 16751052
GetWorkFontColor = "淡紫"
Case Is = 16777215
GetWorkFontColor = "白色"
End Select
End Function
'----------------------
[此贴子已经被作者于2005-4-22 15:27:26编辑过] |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-4-22 14:09
