实例介绍
【实例截图】
【核心代码】
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
相关软件
小贴士
感谢您为本站写下的评论，您的评论对其它用户来说具有重要的参考价值，所以请认真填写。
- 类似“顶”、“沙发”之类没有营养的文字，对勤劳贡献的楼主来说是令人沮丧的反馈信息。
- 相信您也不想看到一排文字/表情墙，所以请不要反馈意义不大的重复字符，也请尽量不要纯表情的回复。
- 提问之前请再仔细看一遍楼主的说明，或许是您遗漏了。
- 请勿到处挖坑绊人、招贴广告。既占空间让人厌烦，又没人会搭理，于人于己都无利。
关于好例子网
本站旨在为广大IT学习爱好者提供一个非营利性互相学习交流分享平台。本站所有资源都可以被免费获取学习研究。本站资源来自网友分享，对搜索内容的合法性不具有预见性、识别性、控制性，仅供学习研究，请务必在下载后24小时内给予删除，不得用于其他任何用途，否则后果自负。基于互联网的特殊性，平台无法对用户传输的作品、信息、内容的权属或合法性、安全性、合规性、真实性、科学性、完整权、有效性等进行实质审查；无论平台是否已进行审查，用户均应自行承担因其传输的作品、信息、内容而可能或已经产生的侵权或权属纠纷等法律责任。本站所有资源不代表本站的观点或立场，基于网友分享，根据中国法律《信息网络传播权保护条例》第二十二与二十三条之规定，若资源存在侵权或相关问题请联系本站客服人员，点此联系我们。关于更多版权及免责申明参见 版权及免责申明
网友评论
我要评论