PPT抽奖程序故障
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一窍不通。 这样改应该好一些：
[*]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
复制代码 首先非常感谢，我试了，还是不能运行。
18. With .Shapes("txtNum").TextFrame.TextRange
在这一行报错，我不太懂这个东西，看不出问题在哪。 可能是文本框的名字和实际的不一致，传附件才能知道真相。 这是程序的附件，麻烦您看看，谢谢！ 已经修改，请测试 附件已经更新过，如果文本文件里的人数发生改变时，程序里也要做相应调整。
页:
[1]