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, conn, adOpenKeyset, 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 "请选择要抽奖的等级", vbOKOnly + 64, "提示"
        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, 5, 9) & "'"
    'rst.Open strsql, conn, adOpenKeyset, adLockOptimistic 无返回记录集,不能使用recordset
    conn.Execute strsql
   
    conn.Close
    'Set rst = Nothing
    Set conn = Nothing

Else

End If

End Sub