抽奖系统VB6.0
VERSION 5.00Object = "{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 = "退出" EndEndAttribute VB_Name = "抽奖"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption ExplicitPublic iPublic STPublic iCount As LongPublic g1, g2, g3 As IntegerPublic c1, c2, c3 As IntegerPublic n1, n2, n3 As IntegerPublic nflag As IntegerPublic str2 As StringPublic 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 txtTempDim Textline As StringCommonDialog1.CancelError = TrueOn Error GoTo ErrHandler' 设置标志CommonDialog1.Flags = cdlOFNHideReadOnly' 设置过滤器CommonDialog1.Filter = "TEXT Files (*.txt)|*.txt"' 指定缺省的过滤器CommonDialog1.FilterIndex = 2' 显示“打开”对话框CommonDialog1.ShowOpen' 显示选定文件的名字' CommonDialog1.FileNametxtTemp = "" 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 #1txtTemp = Mid(txtTemp, 2)ST = Split(txtTemp, "|")iCount = UBound(ST)Command1.Enabled = FalseRandomize'打开文件，准备写入获奖名单：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 SubPrivate Sub Command2_Click()Dim texttemp As StringDim ST1 As Variant Dim itmx As ListItemnflag = 3Command3.Enabled = FalseCommand4.Enabled = FalseIf iCount > n3 ThenIf 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 IfEnd SubPrivate Sub Command3_Click()Dim texttemp As StringDim ST1 As Variantnflag = 2Command2.Enabled = FalseCommand4.Enabled = FalseIf iCount > n2 ThenIf 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 IfEnd SubPrivate Sub Command4_Click()Dim texttemp As StringDim ST1 As Variantnflag = 1Command2.Enabled = FalseCommand3.Enabled = FalseIf iCount > n1 ThenIf 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 SubEnd If End SubPrivate Sub Command5_Click()Close #2EndEnd SubPrivate Sub Conf_Click(Index As Integer)奖项设置.ShowEnd SubPrivate Sub Form_Load()奖项设置.Text1.Text = 1奖项设置.Text2.Text = 3奖项设置.Text3.Text = 2奖项设置.Text4.Text = 6奖项设置.Text5.Text = 3奖项设置.Text6.Text = 10'判断当前抽奖等级nflag = 0WindowsMediaPlayer1.URL = App.Path & "\n.mp3"WindowsMediaPlayer1.settings.playCount = 1000Call WindowsMediaPlayer1.Controls.stopmstrPath = App.Path '获得当前路径If Right(mstrPath, 1) <> "\" Then mstrPath = mstrPath & "\" Set picTemp = LoadPicture(mstrPath & ".\b2.jpg")End SubPrivate Sub Form_Resize()Me.Refresh '必须在此RefreshMe.PaintPicture picTemp, 0, 0, Me.Width, Me.HeightEnd SubPrivate Sub Form_Terminate()Close #2End SubPrivate Sub Form_Unload(Cancel As Integer)Close #2End SubPrivate Sub Query_Click(Index As Integer)抽奖结果查询.ShowEnd SubPrivate Sub Quit_Click()EndClose #2End SubPrivate Sub Timer1_Timer()Dim i As LongDim X As LongDim Y As LongDim BL As DoubleDim t, k As IntegerDim a1() As IntegerLabel1.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 Thenk = UBound(a1)For i = 1 To UBound(a1)'If nflag = 3 Then Label1.Caption = "第" & CStr(g3) & "三等奖：" & vbCrLfLabel1.Caption = Label1.Caption & ST(a1(i)) & vbCrLfNextEnd IfEnd SubPublic Function GetRndNotRepeat(ByVal NumMin As Integer, ByVal NumMax As Integer, ByVal n As Integer)'编制:xsfhlzh'功能:取NumMin到NumMax间的n个随机整数'说明:取数标志数组是Byte，每一位表示NumMin到NumMax间某个数的状态Dim arr() As IntegerIf n > NumMax - NumMin 1 ThenReDim arr(0)arr(0) = 0ElseReDim arr(n)Dim b() As ByteDim m As Integerm = Int((NumMax - NumMin) / 8)ReDim b(m)'取数标志Dim X As Integer, Y As IntegerDim z As ByteRandomizearr(0) = 1For i = 1 To nDo'找到x的位置，y表示x在数组的第几个字节，z表示x在该字节的第几位X = Int(Rnd * (NumMax - NumMin 1)) NumMinY = X - NumMinz = 2 ^ (Y Mod 8)Y = Y \ 8Loop While b(Y) And zb(Y) = b(Y) Or zarr(i) = X'找到未取的数，并放入数组，设置标志位Next iEnd IfGetRndNotRepeat = arrEnd FunctionPublic Function DeleteArray(X, ByVal s As String)Dim i, n, pos As Integerpos = -1n = UBound(X)For i = 0 To nIf s = X(i) Thenpos = i'用pos记下需要删除的数的下标值Exit ForEnd IfNext iIf pos <> -1 ThenFor i = pos To n - 1 'pos及以后的数均在数组中向前移一位X(i) = X(i 1)Next iEnd IfReDim Preserve X(n - 1)DeleteArray = XEnd Function
评论