打字测试自动阅卷的实现(Word)

    因单位要求，帮镇工会组织的“2008迎奥运，计算机操作竞赛”出试题。主要内容有打字、Word操作、Excel操作和PPT操作。由于参加竞赛的人员 较多，不可能为每一位选手手工评分，所以用Office中的VBA来实现各个模块试题的自动评分。现将各部分操作题目及VBA程序贴出。

Word中实现打字测试自动评分
打字的内容：
href="file:///C:%5CDOCUME%7E1%5CADMINI%7E1%5CLOCALS%7E1%5CTemp%5Cmsohtml1%5C01%5Cclip_filelist.xml" rel="File-List" /> href="file:///C:%5CDOCUME%7E1%5CADMINI%7E1%5CLOCALS%7E1%5CTemp%5Cmsohtml1%5C01%5Cclip_editdata.mso" rel="Edit-Time-Data" />

（共62分）

是沙巴·冯的，写的很不错，好东西和大家一起分享@^_^%

 

岁月

 

当办公室后面的小河一再膨胀时，我知道，丰沛的雨季又来

 

了。不过这一季的雨水来得特别早，出乎我的意料，使我

 

没有准备去承受这一场雨季的湿润，洗涤我岁月的长衫。太

 

平洋上的风姑娘，欣然接受北婆罗洲莽莽苍林的邀请，夹着

 

一条长长的水带，翩然来到北婆罗洲的上空，洒下清泉万丈，

 

让热情奔放的处女林，显露着救旱逢甘露的喜悦。在岁月的

 

长河里，我摆一叶轻舟，从我生命的源头起航。河的两岸，

 

有桃红柳绿的葱茏簇拥，互争艳丽；也有骨排楼宇的森林，

 

穿插在其间：更有暗礁潜伏在激流当中，让我的旅途充满崎

 

岖和不安。激流中，也许会错过停泊的岸头，才能觅得柳暗

 

花明。人的一生中，难免错失良机，与幸运失之交臂。我的

 

小舟，就常常在岁月的长河中漂流。 这一场雨季，扑打在

 

我的窗口，敲响我每一场梦境中的时钟狂嚼着我的梦，这才

 

发现我的梦境如此苦涩难咽，便把破碎的梦吐在破玻璃上让

 

碎片模糊我的视线。我在河流上很很触了礁。而风，仍不肯

 

停歇，依然在广阔无垠的星宇下旋舞，旋舞。舞的精彩，舞

 

的狂乱。我只好遂一拾起被震碎的梦境，想一副拼图游戏，

 

以颤抖的双手，拼贴生命。风，仍不肯停歇，任性着舞动者

 

风云。岁月的长河被舞的惊涛骇浪，而我仍摆一叶轻舟，冲

 

破云头，使向前方。我不怕被覆舟。我更不怕颠簸我只想证

 

明我不是一个渡客。小河，每天都在膨胀。 雨水的丰沛，

 

是造成小河膨胀的现象。河里的鱼群，在简陋的洞口闪着。

 
'以下是自动评分代码：
'说明：由于在word中实现打字测试功能，则必须禁止在word中的复制功能，'''包括右键、编辑菜单及工具栏中的复制，还有快捷键Ctrl+C等，这样才能保证'选手在操作过程中只能打字输入！
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'以下是禁止复制等内容
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub Document_Close()
With Application
.CommandBars("Edit").Controls("复制(&c)").Enabled = True
.CommandBars("File").Controls("另存为(&a)...").Enabled = True '另存为菜单按钮失效
.CommandBars("Standard").Controls("复制(&c)").Enabled = True
.CommandBars("Text").Enabled = True

End With
End Sub

Private Sub Document_Open()
With Application
'.OnKey Key = "^c", procedure:="dd"
.CommandBars("Edit").Controls("复制(&c)").Enabled = False '复制菜单按钮失效
.CommandBars("File").Controls("另存为(&a)...").Enabled = False '另存为菜单按钮失效
.CommandBars("Standard").Controls("复制(&c)").Enabled = False '复制工具按钮失效
.CommandBars("Text").Enabled = False '右键菜单失效
End With
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyC), KeyCategory:=wdKeyCategoryCommand, _
    Command:="dd"  '使用ctrl+c则运行dd

End Sub
Sub dd()
MsgBox "呵呵！不能复制哦！"
End Sub
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'以下是评分内容
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub CommandButton1_Click()
Dim Score As Single
Dim i, j, sl, dl As Integer

s = pswdInputBox()
 If s = 8415002 Then

Score = 0
l = 0

For i = 2 To 48 Step 2
 sl = Len(ActiveDocument.Paragraphs(i).Range.Text)
 dl = Len(ActiveDocument.Paragraphs(i + 1).Range.Text)
 If sl > dl Then
   For j = 1 To dl
     If ActiveDocument.Paragraphs(i).Range.Characters(j).Text = _
        ActiveDocument.Paragraphs(i + 1).Range.Characters(j).Text Then
     
        Score = Score + 0.1
     End If
   Next j
 Else
    For j = 1 To sl
     If ActiveDocument.Paragraphs(i).Range.Characters(j).Text = _
        ActiveDocument.Paragraphs(i + 1).Range.Characters(j).Text Then
     
        Score = Score + 0.1
     End If
   Next j
 End If
 
Next i
MsgBox ("您的分数是： " & Int(Score))

End If
End Sub