[原创并分享]批量WROD文档格式比较报告程序

应网友seenosee要求,作了一个小程序,希望能对大家有所帮助.

作为主题贴发表的目的,是便于以后检索.

适用于:根据标准文档对来自于指定文件夹中的学生WORD文档中的设置进行比较并签署报告的一个小程序,您需要在宏安全性为低的情况下使用该程序.

请修改其中的标准文档路径,注意"\".

您需要在OFFICE XP及以上版本中才能正确运行.

请运行该文档菜单栏右侧的"CompareFormat"命令.

比较范围:

1.页面设置

1.1.纸张大小

1.2.纸型方向

1.3.左页边距

1.4.右页边距

1.5.上页边距

1.6.下页边距

2.段落总数

3.正文总长度

4.错字指示

5.正确率统计

6.逐段落:

6.1.字体大小

6.2.字体名称

6.3.字体颜色

6.4.段前间距

6.5.段后间距

6.6.行距

6.7.首行缩进

附:中文字体颜色函数,通过它,可以获得标准调色板中中文颜色名称.

附件

eOLWpF6q.zip(23.28 KB)

2005-4-22 14:11, 下载次数: 154

[原创并分享]批量WROD文档格式比较报告程序

VpG5tWcb.zip(18.96 KB)

2005-4-22 14:15, 下载次数: 160

[原创并分享]批量WROD文档格式比较报告程序

作者: 守柔发布时间: 2005-04-22

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋'* 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 ExplicitDim StandardFontColor As Long, WorkFontColor As LongSub CompareFormat()Dim StandardDoc As Document, aDoc As Document, MyDialog As FileDialog, vrtSelectedItem As VariantDim i As Paragraph, Worki As Paragraph, ParCount As IntegerDim StandardFontName As String, StandardFontSize As SingleDim WorkFontName As String, WorkFontSize As SingleDim StandardParLeftIndent As Single, StandardParLineSpacing As Single, StandardParSpaceAfter As SingleDim WorkParLeftIndent As Single, WorkParLineSpacing As Single, WorkParSpaceAfter As SingleDim StandardParSpaceBefore As Single, WorkParSpaceBefore As SingleDim StandardPageTop As Single, StandardPageBottom As Single, StandardPageLeft As Single, StandardPageRight As SingleDim WorkPageTop As Single, WorkPageBottom As Single, WorkPageLeft As Single, WorkPageRight As SingleDim StandardPaperSize As PageSetup, StandardPaperOrientation As ByteDim WorkPaperSize As PageSetup, WorkPaperOrientation As ByteDim aChar As Range, CharCount As Long, ErrCount As LongDim ErrorText As StringOn Error Resume NextSet 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 WithIf 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: " & vrtSelectedItemParCount = 0: CharCount = 0: ErrCount = 0'初始化变量With aDocErrorText = Chr(13) & "文档名:" & .Name & "文档作者:" & .BuiltInDocumentProperties("Author") & Chr(13)''''''标准文档获得页边距With StandardDoc.PageSetupStandardPaperSize = .PaperSizeStandardPaperOrientation = .OrientationStandardPageTop = VBA.Round(.TopMargin, 2)StandardPageBottom = VBA.Round(.BottomMargin, 2)StandardPageLeft = VBA.Round(.LeftMargin, 2)StandardPageRight = VBA.Round(.RightMargin, 2)End With'''''获得作业文档的页边距With .PageSetupWorkPaperSize = .PaperSizeWorkPaperOrientation = .OrientationWorkPageTop = 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 .ParagraphsParCount = ParCount + 1'''''取得段落格式With StandardDoc.Paragraphs(ParCount).FormatStandardParLeftIndent = .FirstLineIndentStandardParLineSpacing = .LineSpacingStandardParSpaceAfter = .SpaceAfterStandardParSpaceBefore = .SpaceBeforeEnd With'''取得字体格式With StandardDoc.Paragraphs(ParCount).RangeStandardFontName = .Font.NameFarEastStandardFontSize = .Font.SizeStandardFontColor = .Font.ColorEnd With''''取得段落格式With Worki.FormatWorkParLeftIndent = .FirstLineIndentWorkParLineSpacing = .LineSpacingWorkParSpaceAfter = .SpaceAfterWorkParSpaceBefore = .SpaceBeforeEnd With''''取得字体格式With Worki.RangeWorkFontName = .Font.NameFarEastWorkFontSize = .Font.SizeWorkFontColor = .Font.ColorEnd 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 WorkiFor 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 IfNext aCharErrorText = 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 WithNext vrtSelectedItemStandardDoc.Close FalseApplication.ScreenUpdating = True '恢复屏幕更新MsgBox "全部文档检查完毕,请核查!", vbOKOnly + vbExclamationEnd IfEnd Sub'----------------------Function GetStandardFontColor() As StringSelect Case StandardFontColorCase Is = -16777216GetStandardFontColor = "自动色"Case Is = 0GetStandardFontColor = "黑色"Case Is = 13209GetStandardFontColor = "褐色"Case Is = 13107GetStandardFontColor = "橄榄绿"Case Is = 13056GetStandardFontColor = "深绿"Case Is = 6697728GetStandardFontColor = "深灰蓝"Case Is = 8388608GetStandardFontColor = "深蓝"Case Is = 10040115GetStandardFontColor = "靛蓝"Case Is = 3355443GetStandardFontColor = "灰色-80%"Case Is = 128GetStandardFontColor = "深红"Case Is = 26367GetStandardFontColor = "桔黄"Case Is = 32896GetStandardFontColor = "深黄"Case Is = 32768GetStandardFontColor = "绿色"Case Is = 8421376GetStandardFontColor = "蓝绿色"Case Is = 16711680GetStandardFontColor = "蓝色"Case Is = 10053222GetStandardFontColor = "蓝-灰"Case Is = 8421504GetStandardFontColor = "灰色-50%"Case Is = 255GetStandardFontColor = "红色"Case Is = 39423GetStandardFontColor = "浅桔黄"Case Is = 52377GetStandardFontColor = "酸橙色"Case Is = 6723891GetStandardFontColor = "海绿"Case Is = 13421619GetStandardFontColor = "宝石蓝"Case Is = 16737843GetStandardFontColor = "浅蓝"Case Is = 8388736GetStandardFontColor = "紫色"Case Is = 10066329GetStandardFontColor = "灰色-40%"Case Is = 16711935GetStandardFontColor = "粉红"Case Is = 52479GetStandardFontColor = "金色"Case Is = 65535GetStandardFontColor = "黄色"Case Is = 65280GetStandardFontColor = "鲜绿"Case Is = 16776960GetStandardFontColor = "青绿"Case Is = 16763904GetStandardFontColor = "天蓝"Case Is = 6697881GetStandardFontColor = "梅红"Case Is = 12632256GetStandardFontColor = "灰色"Case Is = 13408767GetStandardFontColor = "玫瑰红"Case Is = 10079487GetStandardFontColor = "棕黄"Case Is = 10092543GetStandardFontColor = "浅黄"Case Is = 13434828GetStandardFontColor = "浅绿"Case Is = 16777164GetStandardFontColor = "浅青绿"Case Is = 16764057GetStandardFontColor = "淡蓝"Case Is = 16751052GetStandardFontColor = "淡紫"Case Is = 16777215GetStandardFontColor = "白色"End SelectEnd Function'----------------------Function GetWorkFontColor() As StringSelect Case WorkFontColorCase Is = -16777216GetWorkFontColor = "自动色"Case Is = 0GetWorkFontColor = "黑色"Case Is = 13209GetWorkFontColor = "褐色"Case Is = 13107GetWorkFontColor = "橄榄绿"Case Is = 13056GetWorkFontColor = "深绿"Case Is = 6697728GetWorkFontColor = "深灰蓝"Case Is = 8388608GetWorkFontColor = "深蓝"Case Is = 10040115GetWorkFontColor = "靛蓝"Case Is = 3355443GetWorkFontColor = "灰色-80%"Case Is = 128GetWorkFontColor = "深红"Case Is = 26367GetWorkFontColor = "桔黄"Case Is = 32896GetWorkFontColor = "深黄"Case Is = 32768GetWorkFontColor = "绿色"Case Is = 8421376GetWorkFontColor = "蓝绿色"Case Is = 16711680GetWorkFontColor = "蓝色"Case Is = 10053222GetWorkFontColor = "蓝-灰"Case Is = 8421504GetWorkFontColor = "灰色-50%"Case Is = 255GetWorkFontColor = "红色"Case Is = 39423GetWorkFontColor = "浅桔黄"Case Is = 52377GetWorkFontColor = "酸橙色"Case Is = 6723891GetWorkFontColor = "海绿"Case Is = 13421619GetWorkFontColor = "宝石蓝"Case Is = 16737843GetWorkFontColor = "浅蓝"Case Is = 8388736GetWorkFontColor = "紫色"Case Is = 10066329GetWorkFontColor = "灰色-40%"Case Is = 16711935GetWorkFontColor = "粉红"Case Is = 52479GetWorkFontColor = "金色"Case Is = 65535GetWorkFontColor = "黄色"Case Is = 65280GetWorkFontColor = "鲜绿"Case Is = 16776960GetWorkFontColor = "青绿"Case Is = 16763904GetWorkFontColor = "天蓝"Case Is = 6697881GetWorkFontColor = "梅红"Case Is = 12632256GetWorkFontColor = "灰色"Case Is = 13408767GetWorkFontColor = "玫瑰红"Case Is = 10079487GetWorkFontColor = "棕黄"Case Is = 10092543GetWorkFontColor = "浅黄"Case Is = 13434828GetWorkFontColor = "浅绿"Case Is = 16777164GetWorkFontColor = "浅青绿"Case Is = 16764057GetWorkFontColor = "淡蓝"Case Is = 16751052GetWorkFontColor = "淡紫"Case Is = 16777215GetWorkFontColor = "白色"End SelectEnd Function'----------------------

[此贴子已经被作者于2005-4-22 15:27:26编辑过]

作者: 守柔发布时间: 2005-04-22

做得太棒啦！

这个程序很有实用价值！

多谢守柔版主的辛勤劳动和无私奉献！

建议加为精华帖！！！

作者: seenosee 发布时间: 2005-04-22

敬爱的守柔版主，您好！

经过我反复测试，发现您的这个程序还有一点小问题，麻烦您查看一下。

这是程序运行前各文档：

Xv04TI9h.rar (38.42 KB)

麻烦您查看，谢谢！

附件

ss1SW9OO.rar(34.42 KB)

2005-4-23 14:26, 下载次数: 34

[原创并分享]批量WROD文档格式比较报告程序

作者: seenosee 发布时间: 2005-04-23

请恢复原来的两个文档中的格式设置(去除下划线等)

请注意,你的程序没有正确运行,你可以退出WORD后重启WORD,再行测试:

注意,这是我用你的测试前的主文档,进行测试的结果,和你的测试后的主文档中的测试结果,其中,你的测试后结果没有包含总段落数和文档总长度.

文档名:A10.doc文档作者:I Love You_Word!纸张大小不一致上页边距不符,应为72实为101.25左页边距不符,应为90实为110.25……标准文档段落总数为9,此文档段落总数为7标准文档全长213,此文档全长178录入文字正确率:175/178=98.31%I Love You_Word!2005-4-23 15:17:25*******************************************************文档名:A101.doc文档作者:极地组织纸张大小不一致……标准文档段落总数为9,此文档段落总数为7标准文档全长213,此文档全长178录入文字正确率:178/178=100%I Love You_Word!2005-4-23 15:17:29*******************************************************文档名:A101.doc文档作者:极地组织纸张大小不一致上页边距不符,应为0实为72下页边距不符,应为0实为72左页边距不符,应为0实为90右页边距不符,应为0实为90……录入文字正确率:0/178=0%dyg2005-4-23 14:14:28*******************************************************文档名:A10.doc文档作者:I Love You_Word!纸张大小不一致上页边距不符,应为0实为101.25下页边距不符,应为0实为72左页边距不符,应为0实为110.25右页边距不符,应为0实为90……录入文字正确率:0/178=0%dyg2005-4-23 14:14:30******************************************************请重新运行程序。

作者: 守柔发布时间: 2005-04-23

谢谢守柔版主热情回复，

经过我反复测试，发现您的这个程序还有一点小问题，麻烦您再查看一例。

这是程序运行前各文档：

WTC6BRwY.rar (36.16 KB) 为什么有时作业文档稍微改变一点，测试结果就会出错呢？

麻烦守柔版主测试！