VB6.0写的年会抽奖程序
去年年会给公司写的抽奖小程序，请大家多多指导链接：https://pan.baidu.com/s/1gvh-Tdsd7AydMI0YKfcBwA 提取码：a6o7
https://static.52pojie.cn/static/image/hrline/1.gif
1.主页面
https://attach.52pojie.cn//forum/202011/13/113718m25rkim5my2rcxky.png?l
2.代码部分
Dim ArrMan()Dim ArrMan1()
Dim t As Long
Dim StartCount As Long
Dim AwardType As String
Dim AwardCount As Integer
Dim ArrName() As String
Dim ArrRndNo() As Long
Dim strTitle As String
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'MsgBox KeyCode
'''esc退出
'If KeyCode = 27 Then Unload Me
'''空格开始结束抽奖
If KeyCode = 32 And lbl_award.Caption <> "幸运奖" Then
If StartCount = 0 Then
StartCount = StartCount + 1
StartAward
Else
StartCount = 0
EndAward
End If
End If
End Sub
'Sub InitUI()
'
'
'lblGongsi.Top = 1000
'lblGongsi.Left = Me.Width / 2 - lblGongsi.Width / 2 + img_logo.Width / 2
'
''Screen.Width
'
'
'lblTitle.Top = 2500
'lblTitle.Left = Me.Width / 2
'
'
'lbl_award.Top = 4000
'lbl_award.Left = Me.Width / 2 + lbl_award.Width / 6
'
'
'img_award.Top = Me.Height - img_award.Height / 2
'img_award.Left = Me.Width - img_award.Width / 2
'
'
'img_logo.Top = 1
'img_logo.Left = 1
'
'
'img_award.Visible = False
'lbl_award.Visible = False
'
'
'lbl_name(0).Visible = False
'
'
'
'Label1.Top = Me.Height + 2000
'Label1.Left = 1
'Label1.ForeColor = vbWhite 'RGB(119, 203, 231)
''Label1.ForeColor = RGB(119, 203, 231)
'
'Loadlbl_name 15
'
'
'
'End Sub
Sub InitUI()
lblGongsi.Top = 1000
lblGongsi.Left = Screen.Width / 2 - lblGongsi.Width / 2
lblTitle.Top = 2500
lblTitle.Left = Screen.Width / 2 - lblTitle.Width / 2
lbl_award.Top = 4000
lbl_award.Left = Screen.Width / 2 - lbl_award.Width / 2 + 500
img_award.Top = Screen.Height - img_award.Height
img_award.Left = Screen.Width - img_award.Width
img_logo.Top = 1
img_logo.Left = 1
img_award.Visible = False
lbl_award.Visible = False
lbl_name(0).Visible = False
Label1.Top = Screen.Height - Label1.Height
Label1.Left = 1
Label1.ForeColor = vbWhite 'RGB(119, 203, 231)
Loadlbl_name 15
img_logo.Picture = LoadPicture(App.Path & "\resource\公司logo.jpg")
strTitle = GetValue("title", "title", App.Path & "\set.ini")
lblGongsi.Caption = strTitle
End Sub
Sub Loadlbl_name(loadcount As Integer)
Dim t As Long
Dim lineno As Long
For t = 1 To loadcount
Load lbl_name(t)
lbl_name(t).Visible = False
lineno = Int(t / 5 * (-1)) / (-1)
lbl_name(t).Top = 5400 + (lineno - 1) * (lbl_name(t).Height + 400)
lbl_name(t).Left = Screen.Width / 2 + 3000 * ((t Mod 5) - 1) - 6000
Next
End Sub
Private Sub Form_Load()
ReDim ArrName(0 To 0)
ReDim ArrRndNo(0 To 0)
ReadManList
InitUI
Me.Picture = LoadPicture(App.Path & "\resource\主界面.jpg")
Me.AutoRedraw = True
AwardCount = 5
StartCount = 0
End Sub
Sub ReadManList()
Dim tempStr As String '定义变量tempStr为字符串
ReDim ArrMan(0 To 2, 0 To 0)
ReDim ArrMan1(0 To 2, 0 To 0)
Open App.Path & "\抽奖名单.txt" For Input As #1 '打开文件
While Not EOF(1)'读取到结束
Line Input #1, tempStr '读取一行到变量tempStr
ReDim Preserve ArrMan(0 To 2, 0 To UBound(ArrMan, 2) + 1)
ArrMan(1, UBound(ArrMan, 2)) = UBound(ArrMan, 2)
ArrMan(2, UBound(ArrMan, 2)) = tempStr
'对应的处理
Wend '未结束继续
Close #1 '关闭
Open App.Path & "\抽奖名单1.txt" For Input As #1 '打开文件
While Not EOF(1)'读取到结束
Line Input #1, tempStr '读取一行到变量tempStr
ReDim Preserve ArrMan1(0 To 2, 0 To UBound(ArrMan1, 2) + 1)
ArrMan1(1, UBound(ArrMan1, 2)) = UBound(ArrMan1, 2)
ArrMan1(2, UBound(ArrMan1, 2)) = tempStr
'对应的处理
Wend '未结束继续
Close #1 '关闭
'Stop
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
Me.PopupMenu menu_start
End If
End Sub
Private Sub Form_Resize()
Me.PaintPicture Me.Picture, 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub
Private Sub menu_awardlist_Click()
FrmAward.Show
End Sub
Private Sub menu_exit_Click()
Unload Me
End Sub
Private Sub menu_luckone_Click()
Dim t As Long
If Timer1.Enabled = True Then Exit Sub
lbl_award.Caption = "幸运奖(10)"
lbl_award.Visible = True
img_award.Visible = True
AwardType = "LuckOne"
AwardCount = 10
For t = 1 To 15
If t <= AwardCount Then
lbl_name(t).Visible = True
Else
lbl_name(t).Visible = False
End If
Next
img_award.Picture = LoadPicture(App.Path & "\奖项\幸运奖.jpg")
End Sub
Private Sub menu_lucktwo_Click()
Dim t As Long
If Timer1.Enabled = True Then Exit Sub
lbl_award.Caption = "幸运奖(15)"
lbl_award.Visible = True
img_award.Visible = True
AwardType = "LuckTwo"
AwardCount = 15
For t = 1 To 15
If t <= AwardCount Then
lbl_name(t).Visible = True
Else
lbl_name(t).Visible = False
End If
Next
img_award.Picture = LoadPicture(App.Path & "\奖项\幸运奖.jpg")
End Sub
Private Sub menu_one_Click()
Dim t As Long
If Timer1.Enabled = True Then Exit Sub
lbl_award.Caption = "一等奖(10)"
lbl_award.Visible = True
img_award.Visible = True
AwardType = "One"
AwardCount = 10
For t = 1 To 15
If t <= AwardCount Then
lbl_name(t).Visible = True
Else
lbl_name(t).Visible = False
End If
Next
img_award.Picture = LoadPicture(App.Path & "\奖项\一等奖.jpg")
End Sub
Private Sub menu_reset_Click()
ReadManList
ReDim ArrAwardName(0 To 2, 0 To 35)
End Sub
Private Sub Timer1_Timer()
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Dim rndNo As String
Dim strRndName As String
Dim i As Integer
Dim j As Long
Timer1.Enabled = False
Randomize (Timer)
For i = 1 To AwardCount
100:
rndNo = Int((UBound(ArrMan, 2)) * Rnd) + 1
ArrRndNo(i) = rndNo
'''比较随机数是否重复
For j = 1 To i - 1
If ArrRndNo(i) = ArrRndNo(j) Then
GoTo 100
End If
Next
strName = ArrMan(2, rndNo)
ArrName(i) = strName
lbl_name(i).Caption = strName
Next
If AwardType = "One" Then
Randomize (Timer)
rndNo = Int((UBound(ArrMan1, 2)) * Rnd) + 1
strName = ArrMan1(2, rndNo)
lbl_name(rndNo).Caption = strName
ArrName(rndNo) = strName
End If
' QuickSort ArrRndNo, False
'Stop
Timer1.Enabled = True
End Sub
'''开始抽奖
Sub StartAward()
If UBound(ArrMan, 2) <= 5 Then MsgBox "抽奖人数不足": Exit Sub
''''清空随机数组
ReDim ArrName(0 To AwardCount)
ReDim ArrRndNo(0 To AwardCount)
Timer1.Enabled = True
End Sub
'''结束抽奖
Sub EndAward()
If UBound(ArrMan, 2) <= 5 Then Exit Sub
Timer1.Enabled = False
QuickSort ArrRndNo, False
For t = 0 To UBound(ArrRndNo) - 1
ArrRowRemoveNew ArrMan, ArrRndNo(t)
Next
Select Case AwardType
Case "LuckOne":
For t = 1 To UBound(ArrName)
ArrAwardName(1, t) = AwardType
ArrAwardName(2, t) = ArrName(t)
SetValue "中奖名单", "幸运奖" & t, ArrName(t), App.Path & "\中奖名单.txt"
Next
Case "LuckTwo":
For t = 1 To UBound(ArrName)
ArrAwardName(1, t + 10) = AwardType
ArrAwardName(2, t + 10) = ArrName(t)
SetValue "中奖名单", "幸运奖" & t + 10, ArrName(t), App.Path & "\中奖名单.txt"
Next
Case "One":
For t = 1 To UBound(ArrName)
ArrAwardName(1, t + 25) = AwardType
ArrAwardName(2, t + 25) = ArrName(t)
SetValue "中奖名单", "一等奖" & t, ArrName(t), App.Path & "\中奖名单.txt"
Next
End Select
'Stop
End Sub
bigdoog 发表于 2020-11-13 20:07
你这个在本地电脑上面怎么安装使用呢？
这个是VB代码安装一个VB6.0企业版就可以运行。附件里有执行程序可以直接运行的 huangjie_52pj 发表于 2020-11-13 23:03
这个是VB代码安装一个VB6.0企业版就可以运行。附件里有执行程序可以直接运行的
好的，感谢了。:lol 你这个在本地电脑上面怎么安装使用呢？ 感谢楼主分享 谢谢楼主分享收藏 感谢楼主热心分享！ 感谢楼主的分享，收藏备用。 楼主看到回复一下 lunzi1026 发表于 2020-12-23 21:33
楼主看到回复一下
有什么事情？
页:
[1]
2