|
注意：请将两个文件夹解压在同一文件夹下。 以下为源代码： Private Sub CommandButton1_Click()
Dim MyRange As Range, YwRange As String, i As Range, n As Range, Ect As Integer
Dim Xct As Integer, Zz As String
On Error GoTo ErrHandle
If Me.CommandButton1.Caption = "Start" Then
Application.ScreenUpdating = False
TF = True
Documents.Open FileName:=ActiveDocument.Path & "\练习文章.doc"
Application.Windows("练习文章.doc").Visible = False
StTime = Now
Me.CommandButton1.Caption = "End"
Rn = Int(Rnd() * 3000 + 1)
Ys = Rn
Set YText = Documents("练习文章.doc").Content
Me.TextBox1.SetFocus
Me.TextBox1 = Mid(YText, Rn, 30)
MsgBox "您准备好了吗?第一个文字为（" & Mid(YText, Rn, 1) & "）开始!"
Documents("打字游戏.doc").Activate
ActiveDocument.Content.Delete
CountText = Selection.Start
Me.TextBox2 = ""
Me.TextBox3 = ""
Me.TextBox4 = ""
WaitTime
Else
Me.CommandButton1.Caption = "Start"
EnTime = Now
TF = False
Sd = Application.Selection.Start
Set MyRange = ActiveDocument.Range(0, Sd)
YwRange = Documents("练习文章.doc").Range(Ys - 1, Ys + Sd)
For Each i In MyRange.Characters
Xct = Xct + 1
Zz = Mid(YwRange, Xct, 1)
If i <> Zz Then Ect = Ect + 1
Next
Me.TextBox2.Value = Format(1 - Ect / Sd, "0.00%")
Me.TextBox3.Value = Format(CDate(EnTime - StTime), "H:MM:ss")
Me.TextBox4 = Round(Sd / ((EnTime - StTime) * 24 * 60)) & "(录入" & Sd & "字)"
StTime = 0
EnTime = 0
Sd = 0
Rn = Empty
Set YText = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandle:
MsgBox "该程序出现不可预测错误，将被关闭，请在退出后重新打开该程序！"
Application.Quit False
End If
End Sub
Private Sub UserForm_Initialize()
Me.Caption = "打字练习"
Me.CommandButton1.Caption = "Start"
Me.CommandButton1.SetFocus
End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
TF = False
Documents("练习文章.doc").Close False
End Sub
Private Sub UserForm_Layout()
UserForm1.Top = 0
UserForm1.Left = 160
End Sub ‘--------------------------------------------------------------------------------------------------------- Public StTime As Date, EnTime As Date, Rn As Integer, Sd As Integer, CountText As Integer, YText As Range
Public TF As Boolean, Ys As Integer, Temp As Byte
Sub MoveFont()
Dim Er As Integer
On Error Resume Next
If TF = False Then Exit Sub
CountText = Application.Selection.End
If CountText > 0 Then
EnTime = Now
Er = Rn + CountText - 1
If Er = YText.End - 1 Then MsgBox "对不起,已到文章末,请重新再来!": UserForm1.CommandButton1.Value = True: Exit Sub
DoEvents
UserForm1.TextBox1 = Mid(YText, Er, 25)
UserForm1.TextBox3.Value = Format(CDate(EnTime - StTime), "H:MM:ss")
End If
WaitTime
End Sub
Sub WaitTime()
If TF = False Then Exit Sub
Application.OnTime When:=Now + TimeValue("00:00:02"), Name:="MoveFont"
End Sub
Sub Starting()
UserForm1.Show (0)
End Sub
Sub MySub()
On Error Resume Next
UserForm1.Show (0)
Call UserForm_Layout
UserForm1.CommandButton1.Value = True
End Sub
Private Sub UserForm_Layout()
UserForm1.Top = 0
UserForm1.Left = 160
End Sub ’-------------------------------------------------------------------------------------------------------------- Private Sub Document_Close()
On Error Resume Next
Application.CommandBars("text").Reset
Options.SaveInterval = Temp
TF = False
Documents("文字游戏.doc").Close False
End Sub Private Sub Document_Open()
On Error Resume Next
Temp = Options.SaveInterval
If Temp <> 0 Then Options.SaveInterval = 0
Set MyControl = Application.CommandBars("text").Controls.Add
With MyControl
.FaceId = 102
.Caption = "BeginOrEnd"
.Visible = True
.OnAction = "MySub"
End With
For i = 1 To Application.CommandBars("text").Controls.Count - 1
Application.CommandBars("text").Controls(i).Visible = False
Next
UserForm1.Show (0)
End Sub
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2004-8-20 04:58
楼主
