嘿，亲！知识可是无价之宝呢，但咱这精心整理的资料也耗费了不少心血呀。小小地破费一下，绝对物超所值哦！如有下载和支付问题，请联系我们QQ(微信同号)：813200300
本次赞助数额为： 1 元微信扫码支付：1 元
请留下您的邮箱，我们将在2小时内将文件发到您的邮箱
抽奖系统VB6.0
VERSION 5.00
Object = "{6BF52A50-394A-11D3-B153-00C04F79FAA6}#1.0#0"; "wmp.dll"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form 抽奖
AutoRedraw = -1 'True
Caption = "信威公司年会抽奖 @XINWEI IT"
ClientHeight = 8325
ClientLeft = 60
ClientTop = 750
ClientWidth = 13140
Icon = "gift.frx":0000
LinkTopic = "Form1"
Picture = "gift.frx":030A
ScaleHeight = 8325
ScaleWidth = 13140
StartUpPosition = 2 'CenterScreen
Begin VB.ListBox List2
Height = 255
Left = 3480
TabIndex = 6
Top = 0
Visible = 0 'False
Width = 1095
End
Begin VB.CommandButton Command5
Caption = "退 出"
Height = 375
Left = 11760
TabIndex = 4
Top = 6240
Width = 1095
End
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 60
Left = 2040
Top = 0
End
Begin VB.CommandButton Command4
Caption = "一等奖"
Height = 375
Left = 11760
TabIndex = 3
Top = 5640
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "二等奖"
Height = 375
Left = 11760
TabIndex = 2
Top = 4920
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "三等奖"
Height = 375
Left = 11760
TabIndex = 1
Top = 4200
Width = 1095
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 120
Top = 0
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Command1
Caption = "读取抽奖号"
Height = 375
Left = 11760
TabIndex = 0
Top = 3600
Width = 1095
End
Begin VB.Label Label8
BackColor = &H000000FF&
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 315
Left = 8280
TabIndex = 11
Top = 7440
Visible = 0 'False
Width = 3045
End
Begin VB.Label Label5
Alignment = 2 'Center
BackStyle = 0 'Transparent
BeginProperty Font
Name = "隶书"
Size = 27.75
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00800000&
Height = 1095
Left = 4680
TabIndex = 10
Top = 1920
Width = 5055
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
BeginProperty Font
Name = "隶书"
Size = 24
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 495
Left = 6000
TabIndex = 9
Top = 3240
Width = 255
End
Begin VB.Label Label1
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
BeginProperty Font
Name = "Arial Black"
Size = 26.25
Charset = 0
Weight = 900
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 750
Left = 6615
TabIndex = 8
Top = 960
Width = 180
End
Begin WMPLibCtl.WindowsMediaPlayer WindowsMediaPlayer1
Height = 495
Left = 8040
TabIndex = 7
Top = 0
Visible = 0 'False
Width = 2295
URL = ""
rate = 1
balance = 0
currentPosition = 0
defaultFrame = ""
playCount = 1
autoStart = -1 'True
currentMarker = 0
invokeURLs = -1 'True
baseURL = ""
volume = 100
mute = 0 'False
uiMode = "full"
stretchToFit = 0 'False
windowlessVideo = 0 'False
enabled = -1 'True
enableContextMenu= -1 'True
fullScreen = 0 'False
SAMIStyle = ""
SAMILang = ""
SAMIFilename = ""
captioningID = ""
enableErrorDialogs= 0 'False
_cx = 4048
_cy = 873
End
Begin VB.Label Label3
Caption = "当前被选序号"
ForeColor = &H000000FF&
Height = 255
Left = 4800
TabIndex = 5
Top = 0
Visible = 0 'False
Width = 1095
End
Begin VB.Menu Conf
Caption = "奖项设置"
Index = 3
End
Begin VB.Menu Query
Caption = "查询抽奖"
Index = 1
End
Begin VB.Menu Quit
Caption = "退出"
End
End
Attribute VB_Name = "抽奖"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public i
Public ST
Public iCount As Long
Public g1, g2, g3 As Integer
Public c1, c2, c3 As Integer
Public n1, n2, n3 As Integer
Public nflag As Integer
Public str2 As String
Public mstrPath As String '当前路径
Public picTemp As Picture
Private Sub Command1_Click()
If 奖项设置.Text1.Text = "" Or 奖项设置.Text2.Text = "" Or 奖项设置.Text3.Text = "" Or 奖项设置.Text4.Text = "" Or 奖项设置.Text5.Text = "" Or 奖项设置.Text6.Text = "" Then
MsgBox "请您先进行奖项设置！"
Exit Sub
End If
'定义一个变量 先吧所有数据都到里面
Dim txtTemp
Dim Textline As String
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
' 设置标志
CommonDialog1.Flags = cdlOFNHideReadOnly
' 设置过滤器
CommonDialog1.Filter = "TEXT Files (*.txt)|*.txt"
' 指定缺省的过滤器
CommonDialog1.FilterIndex = 2
' 显示“打开”对话框
CommonDialog1.ShowOpen
' 显示选定文件的名字
' CommonDialog1.FileName
txtTemp = ""
Open CommonDialog1.FileName For Input As #1 ' 打开配置文件。
Do While Not EOF(1)
Line Input #1, Textline
If Trim(Textline & " ") <> "" Then
txtTemp = txtTemp & "|" & Textline
List2.AddItem Textline
End If
Loop
Close #1
txtTemp = Mid(txtTemp, 2)
ST = Split(txtTemp, "|")
iCount = UBound(ST)
Command1.Enabled = False
Randomize
'打开文件，准备写入获奖名单：
str2 = App.Path "\" & Year(Now) & "年中奖名单" & Month(Now) & Day(Now) & CStr(Int(Rnd * 1000)) & ".txt"
Open "" & str2 & "" For Output As #2
'每个奖项 选择的次数
c1 = CInt(奖项设置.Text1.Text)
c2 = CInt(奖项设置.Text3.Text)
c3 = CInt(奖项设置.Text5.Text)
g1 = CInt(奖项设置.Text1.Text)
g2 = CInt(奖项设置.Text3.Text)
g3 = CInt(奖项设置.Text5.Text)
'每次抽奖时，随机显示的个数
n1 = CInt(奖项设置.Text2.Text)
n2 = CInt(奖项设置.Text4.Text)
n3 = CInt(奖项设置.Text6.Text)
ErrHandler:
End Sub
Private Sub Command2_Click()
Dim texttemp As String
Dim ST1 As Variant
Dim itmx As ListItem
nflag = 3
Command3.Enabled = False
Command4.Enabled = False
If iCount > n3 Then
If g3 > 0 Then
If Not Timer1.Enabled And Command2.Caption = "三等奖" Then
Timer1.Enabled = True
Command2.Caption = "停止"
Label2.Visible = False
Label2.Caption = ""
Label5.Visible = False
Label5.Caption = ""
Label1.Visible = True
Call WindowsMediaPlayer1.Controls.play
Label8.Visible = True
Label8.Caption = "正在进行三等奖的抽奖……"
Else
Call WindowsMediaPlayer1.Controls.pause
Timer1.Enabled = False
Command2.Caption = "三等奖"
g3 = g3 - 1
Label8.Caption = ""
Label8.Visible = False
抽奖结果查询.List1.AddItem "三等奖第" & CStr(c3 - g3) & "次抽奖："
Print #2, "三等奖第" & CStr(c3 - g3) & "次抽奖：" & vbCrLf
texttemp = Trim(Label1.Caption)
Print #2, texttemp
ST1 = Split(texttemp, vbCrLf)
For i = 0 To UBound(ST1) - 1
'抽奖结果查询.ListView1.ListItems.Add (2 - g3), , ST1(i)
'抽奖结果查询.ListView1.ListItems.Item.SubItems(3 - g3) = ST1(i)
'抽奖结果查询.ListView1.Items [i].SubItems[k].Text = ST1(i)
'抽奖结果查询.ListView1.ListItems.Item(i).SubItems(k) = ST(i)
抽奖结果查询.List1.AddItem ST1(i)
Label1.Visible = False
Label5.Caption = "三等奖第" & CStr(c3 - g3) & "次抽奖"
Label5.Visible = True
Label2.Caption = texttemp
Label2.Visible = True
'抽奖结果查询.List1.Visible = True
'
ST = DeleteArray(ST, ST1(i))
Next
iCount = UBound(ST)
Label3.Caption = CStr(iCount)
If g3 = 0 Then
Command2.Enabled = False
If g2 > 0 Then Command3.Enabled = True
If g1 > 0 Then Command4.Enabled = True
Timer1.Enabled = False
nflag = 0
End If
End If
End If
ElseIf iCount <= 0 Then
MsgBox "请先读取抽奖名单!"
Else
MsgBox "参与抽奖人数小于奖项数量，不用进行抽奖，或请重新读入抽奖名单！"
Exit Sub
End If
End Sub
Private Sub Command3_Click()
Dim texttemp As String
Dim ST1 As Variant
nflag = 2
Command2.Enabled = False
Command4.Enabled = False
If iCount > n2 Then
If g2 > 0 Then
If Not Timer1.Enabled And Command3.Caption = "二等奖" Then
Timer1.Enabled = True
Command2.Caption = "停止"
Label2.Visible = False
Label2.Caption = ""
Label5.Visible = False
Label5.Caption = ""
Label1.Visible = True
Call WindowsMediaPlayer1.Controls.play
Label8.Visible = True
Label8.Caption = "正在进行二等奖的抽奖……"
Else
Timer1.Enabled = False
Call WindowsMediaPlayer1.Controls.pause
Command3.Caption = "二等奖"
g2 = g2 - 1
Label8.Caption = ""
Label8.Visible = False
抽奖结果查询.List1.AddItem "二等奖第" & CStr(c2 - g2) & "次抽奖："
Print #2, "二等奖第" & CStr(c2 - g2) & "次抽奖："
texttemp = Trim(Label1.Caption)
Print #2, texttemp
ST1 = Split(texttemp, vbCrLf)
For i = 0 To UBound(ST1) - 1
抽奖结果查询.List1.AddItem ST1(i)
Label1.Visible = False
Label5.Caption = "二等奖第" & CStr(c2 - g2) & "次抽奖"
Label5.Visible = True
Label2.Caption = texttemp
Label2.Visible = True
'
ST = DeleteArray(ST, ST1(i))
Next
iCount = UBound(ST)
Label3.Caption = CStr(iCount)
If g2 = 0 Then
Command3.Enabled = False
If g3 > 0 Then Command2.Enabled = True
If g1 > 0 Then Command4.Enabled = True
Timer1.Enabled = False
nflag = 0
End If
End If
End If
ElseIf iCount <= 0 Then
MsgBox "请先读取抽奖名单!"
Else
MsgBox "参与抽奖人数小于奖项数量，不用进行抽奖，或请重新读入抽奖名单！"
Exit Sub
End If
End Sub
Private Sub Command4_Click()
Dim texttemp As String
Dim ST1 As Variant
nflag = 1
Command2.Enabled = False
Command3.Enabled = False
If iCount > n1 Then
If g1 > 0 Then
If Not Timer1.Enabled And Command4.Caption = "一等奖" Then
Timer1.Enabled = True
Command2.Caption = "停止"
Label2.Visible = False
Label2.Caption = ""
Label5.Visible = False
Label5.Caption = ""
Label1.Visible = True
Call WindowsMediaPlayer1.Controls.play
Label8.Visible = True
Label8.Caption = "正在进行一等奖的抽奖……"
Else
Timer1.Enabled = False
Call WindowsMediaPlayer1.Controls.pause
Command4.Caption = "一等奖"
g1 = g1 - 1
Label8.Caption = ""
Label8.Visible = False
抽奖结果查询.List1.AddItem "一等奖第" & CStr(c1 - g1) & "次抽奖："
Print #2, "一等奖第" & CStr(c1 - g1) & "次抽奖："
texttemp = Trim(Label1.Caption)
Print #2, texttemp
ST1 = Split(texttemp, vbCrLf)
For i = 0 To UBound(ST1) - 1
抽奖结果查询.List1.AddItem ST1(i)
Label1.Visible = False
Label5.Caption = "一等奖第" & CStr(c1 - g1) & "次抽奖"
Label5.Visible = True
Label2.Caption = texttemp
Label2.Visible = True
'
ST = DeleteArray(ST, ST1(i))
Next
iCount = UBound(ST)
Label3.Caption = CStr(iCount)
If g1 = 0 Then
Command4.Enabled = False
If g3 > 0 Then Command2.Enabled = True
If g2 > 0 Then Command3.Enabled = True
Timer1.Enabled = False
nflag = 0
End If
End If
End If
ElseIf iCount <= 0 Then
MsgBox "请先读取抽奖名单!"
Else
MsgBox "参与抽奖人数小于奖项数量，不用进行抽奖，或请重新读入抽奖名单！"
Exit Sub
End If
End Sub
Private Sub Command5_Click()
Close #2
End
End Sub
Private Sub Conf_Click(Index As Integer)
奖项设置.Show
End Sub
Private Sub Form_Load()
奖项设置.Text1.Text = 1
奖项设置.Text2.Text = 3
奖项设置.Text3.Text = 2
奖项设置.Text4.Text = 6
奖项设置.Text5.Text = 3
奖项设置.Text6.Text = 10
'判断当前抽奖等级
nflag = 0
WindowsMediaPlayer1.URL = App.Path & "\n.mp3"
WindowsMediaPlayer1.settings.playCount = 1000
Call WindowsMediaPlayer1.Controls.stop
mstrPath = App.Path '获得当前路径
If Right(mstrPath, 1) <> "\" Then mstrPath = mstrPath & "\"
Set picTemp = LoadPicture(mstrPath & ".\b2.jpg")
End Sub
Private Sub Form_Resize()
Me.Refresh '必须在此Refresh
Me.PaintPicture picTemp, 0, 0, Me.Width, Me.Height
End Sub
Private Sub Form_Terminate()
Close #2
End Sub
Private Sub Form_Unload(Cancel As Integer)
Close #2
End Sub
Private Sub Query_Click(Index As Integer)
抽奖结果查询.Show
End Sub
Private Sub Quit_Click()
End
Close #2
End Sub
Private Sub Timer1_Timer()
Dim i As Long
Dim X As Long
Dim Y As Long
Dim BL As Double
Dim t, k As Integer
Dim a1() As Integer
Label1.Caption = ""
If nflag = 3 Then a1 = GetRndNotRepeat(0, UBound(ST), n3)
If nflag = 2 Then a1 = GetRndNotRepeat(0, UBound(ST), n2)
If nflag = 1 Then a1 = GetRndNotRepeat(0, UBound(ST), n1)
If nflag <> 0 Then
k = UBound(a1)
For i = 1 To UBound(a1)
'If nflag = 3 Then Label1.Caption = "第" & CStr(g3) & "三等奖：" & vbCrLf
Label1.Caption = Label1.Caption & ST(a1(i)) & vbCrLf
Next
End If
End Sub
Public Function GetRndNotRepeat(ByVal NumMin As Integer, ByVal NumMax As Integer, ByVal n As Integer)
'编制:xsfhlzh
'功能:取NumMin到NumMax间的n个随机整数
'说明:取数标志数组是Byte，每一位表示NumMin到NumMax间某个数的状态
Dim arr() As Integer
If n > NumMax - NumMin 1 Then
ReDim arr(0)
arr(0) = 0
Else
ReDim arr(n)
Dim b() As Byte
Dim m As Integer
m = Int((NumMax - NumMin) / 8)
ReDim b(m)
'取数标志
Dim X As Integer, Y As Integer
Dim z As Byte
Randomize
arr(0) = 1
For i = 1 To n
Do
'找到x的位置，y表示x在数组的第几个字节，z表示x在该字节的第几位
X = Int(Rnd * (NumMax - NumMin 1)) NumMin
Y = X - NumMin
z = 2 ^ (Y Mod 8)
Y = Y \ 8
Loop While b(Y) And z
b(Y) = b(Y) Or z
arr(i) = X
'找到未取的数，并放入数组，设置标志位
Next i
End If
GetRndNotRepeat = arr
End Function
Public Function DeleteArray(X, ByVal s As String)
Dim i, n, pos As Integer
pos = -1
n = UBound(X)
For i = 0 To n
If s = X(i) Then
pos = i
'用pos记下需要删除的数的下标值
Exit For
End If
Next i
If pos <> -1 Then
For i = pos To n - 1 'pos及以后的数均在数组中向前移一位
X(i) = X(i 1)
Next i
End If
ReDim Preserve X(n - 1)
DeleteArray = X
End Function