PPT抽奖程序故障

sun-bear

Sub txtStart()
For i = 1 To 5000
With ActivePresentation.Slides(1)
For j = 1 To 1
With .Shapes("txtNum" & j).TextFrame.TextRange
.Text = Int((300 - 1 + 1) * Rnd + 1)
.Font.Color.RGB = 10000 * Rnd
Debug.Print .Text
End With
Next
End With
DoEvents
Next
End Sub
Sub OnSlideShowTerminate()
Exit For
End Sub
这是网上找的一段PPT随机抽奖程序，我稍加修改如下：
Sub txtStart()
Dim a() As String
Dim i As Integer
Dim x As Integer
Open "高一名单.txt" For Input As #1
Do Until EOF(1)
i = i + 1
ReDim Preserve a(i) As String
Line Input #1, a(i)
Loop
For x = 1 To 5000
With ActivePresentation.Slides(1)
For j = 1 To 1
With .shapes("txtNum" & j).TextFrame.TextRange
.Text = a(Int(57 * Rnd + 1))
.Font.Color.RGB = 10000 * Rnd
Debug.Print .Text
End With
Next
End With
DoEvents
Next
End Sub
Sub OnSlideShowTerminate()
Exit For
End Sub
运行后名单能跑起来，但点停止后就不能再运行了，为啥？请高手指点，我对VBA一窍不通。

wbsjzh

这样改应该好一些：

• Public st As Boolean
  
• 
  
• Sub txtStart()
  
• st = True
  
•   Dim a() As String
  
•   Dim i As Integer
  
•   Dim x As Integer
  
•   Open "高一名单.txt" For Input As #1
  
•   Do Until EOF(1)
  
•     i = i + 1
  
•     ReDim Preserve a(i) As String
  
•     Line Input #1, a(i)
  
•   Loop
  
•   t = Timer
  
•       Do While st = True
  
•         With ActivePresentation.Slides(1)
  
•             If Timer >= t + 0.1 Then
  
•                 With .Shapes("txtNum").TextFrame.TextRange
  
•                     .Text = a(Int(7 * Rnd + 1))
  
•                     .Font.Color.RGB = 10000 * Rnd
  
•                 End With
  
•                 t = Timer
  
•             End If
  
•         End With
  
•         DoEvents
  
•         
  
•         If st = False Then Close #1: Exit Sub
  
•     Loop
  
• End Sub
  
• Sub OnSlideShowTerminate()
  
•     st = FalseEnd Sub
  

复制代码

zhangxc

首先非常感谢，我试了，还是不能运行。
18.                With .Shapes("txtNum").TextFrame.TextRange
在这一行报错，我不太懂这个东西，看不出问题在哪。

chufall

可能是文本框的名字和实际的不一致，传附件才能知道真相。

liulian058

这是程序的附件，麻烦您看看，谢谢！

prosingshe

已经修改，请测试

fred0925

附件已经更新过，如果文本文件里的人数发生改变时，程序里也要做相应调整。