1、VB Timer控件代码：
Private Sub Timer1_Timer()
Dim strsql As String
Dim conn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim r As Single
Me.Text1 = ""
VBA.Randomize
r = Rnd
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & App.Path & "\" & "ytzc.mdb"
strsql = "select top 1 * from tblbeing where mark='0' order by rnd(" & r & "-id)"
rst.Open strsql,conn,adOpenKeyset,adLockOptimistic
Me.Text1 = rst.Fields(0) & rst.Fields(1)
rst.Close
conn.Close
Set rst = nothing
Set conn = nothing
End Sub
2、以空格键控制抽奖开始、停止
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim strsql As String
Dim conn As New ADODB.Connection
'Dim rst As New ADODB.Recordse
If mykeycode = "waiting" Then
mykeycode = "start"
ElseIf mykeycode = "start" Then
mykeycode = "stop"
ElseIf mykeycode = "stop" Then
mykeycode = "start"
Else
End If
If KeyAscii = 32 And mykeycode = "start" Then
If mykey = 0 Then
MsgBox "请选择要抽奖的等级",vbOKOnly + 64,"提示"
Else
Me.Timer1.Enabled = True
Me.Timer1.Interval = 10
'Me.Command1.Caption = "停止"
End If
ElseIf KeyAscii = 32 And mykeycode = "stop" Then
Me.Timer1.Enabled = False
'Me.Command1.Caption = "摇奖"
If mykey = 1 Then
Me.Text2 = Me.Text2 & Me.Text1 & vbCrLf
ElseIf mykey = 2 Then
Me.Text3 = Me.Text3 & Me.Text1 & vbCrLf
ElseIf mykey = 3 Then
Me.Text4 = Me.Text4 & Me.Text1 & vbCrLf
Else
End If
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & App.Path & "\" & "ytzc.mdb"
strsql = "update tblbeing set mark=" & "'" & mykey & "'" & "where code=" & "'" & Mid(Me.Text1,5,9) & "'"
'rst.Open strsql,adLockOptimistic 无返回记录集,不能使用recordset
conn.Execute strsql
conn.Close
'Set rst = nothing
Set conn = nothing
Else
End If
End Sub
3、或者使用command控件控制抽奖开始、停止
Private Sub Command1_Click()
Dim strsql As String
Dim conn As New ADODB.Connection
'Dim rst As New ADODB.Recordset
If Me.Command1.Caption = "摇奖" Then
If mykey = 0 Then
MsgBox "请选择要抽奖的等级","提示"
Me.Text1 = ""
Else
Me.Timer1.Enabled = True
Me.Timer1.Interval = 10
Me.Command1.Caption = "停止"
End If
ElseIf Me.Command1.Caption = "停止" Then
Me.Timer1.Enabled = False
Me.Command1.Caption = "摇奖"
If mykey = 1 Then
Me.Text2 = Me.Text2 & Me.Text1 & vbCrLf
ElseIf mykey = 2 Then
Me.Text3 = Me.Text3 & Me.Text1 & vbCrLf
ElseIf mykey = 3 Then
Me.Text4 = Me.Text4 & Me.Text1 & vbCrLf
Else
End If
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & App.Path & "\" & "ytzc.mdb"
strsql = "update tblbeing set mark=" & "'" & mykey & "'" & "where code=" & "'" & Mid(Me.Text1,不能使用recordset
conn.Execute strsql
conn.Close
'Set rst = nothing
Set conn = nothing
Else
End If
End Sub