Dim ss$(), ListNum%, n%, m%, l%, OpFilename$
Dim Newss$()Sub Savefile(xx As String)
Open xx For Output As #1
Print #1, Join(ss, vbCrLf)
Close #1
End Sub
Sub Openfile(xx As String)
Dim a$, i%
Open xx For Input As #1
Do Until EOF(1)
Line Input #1, a
If a <> "" Then
i = i + 1
ReDim Preserve ss(1 To i)
ss(i) = a
End If
Loop
Close #1
If i = 0 Then
MsgBox "没有数据可以提取了!!", 0, "警告!!"
Exit Sub
End IfListNum = UBound(ss)
labtip.Caption = "现有数据" & ListNum & "条,可以开始抽取了!!"
Command1.Enabled = False
Command2.Enabled = True
Command3.Enabled = False
End Sub
Private Sub Command1_Click()
OpFilename = IIf(Option1.Value, "c:\list13.txt", "c:\list15.txt")
Call Openfile(OpFilename)
End SubPrivate Sub Command2_Click()
n = Val(Combo1.Text) * 10
If ListNum - n < 0 Then
MsgBox "没有那么多数据了!!", 0, "警告!!"
Exit Sub
End IfDim i%, j%
ReDim Newss(1 To n)
List1.Clear
Randomize
For i = 1 To n
j = Int((ListNum + 1 - i) * Rnd + 1)
Newss(i) = ss(j)
ss(j) = ss(ListNum + 1 - i)
ss(ListNum + 1 - i) = ""
List1.AddItem Newss(i)
Next
ListNum = ListNum - n
If ListNum = 0 Then ReDim ss(0)
If ListNum > 0 Then ReDim Preserve ss(1 To ListNum)labtip.Caption = "本次抽取" & n & "条," & vbCrLf & "还有" & ListNum & "条可以开始抽取了!!"
Call Savefile(OpFilename)
Command2.Enabled = False
Command3.Enabled = True
End SubPrivate Sub Command3_Click()
On Error GoTo cuowu
Dim i As Integer
Dim kuang As OPENFILENAME
Dim filename As String
kuang.lStructSize = Len(kuang)
kuang.hwndOwner = Me.hWnd
kuang.hInstance = App.hInstance
kuang.lpstrFile = Space(254)
kuang.nMaxFile = 255
kuang.lpstrFileTitle = Space(254)
kuang.nMaxFileTitle = 255
kuang.lpstrInitialDir = App.Path
kuang.flags = 6148
kuang.lpstrFilter = "文本文件 (*.TXT)" + Chr$(0) + "*.TXT" + Chr$(0)
kuang.lpstrTitle = "保存文件的路径及文件名..."
i = GetSaveFileName(kuang)
If i >= 1 Then
filename = kuang.lpstrFile
filename = Left(filename, InStr(filename, Chr(0)) - 1)
End If
If Len(filename) = 0 Then Exit Sub
filename = IIf(InStr(filename, ".txt") > 1, filename, filename & ".txt")Open filename For Output As #1
Print #1, Join(Newss, vbCrLf)
Close #1MsgBox vbCrLf & "保存在:" & filename, vbOKOnly, "保存完成!!!"
Command3.Enabled = False
Command2.Enabled = True
Exit Sub
cuowu:
Close #1
MsgBox "未知原因导致操作失败!", 0, "警告!!"
End SubPrivate Sub Form_Load()
'Me.Caption = "子夜东方随机号码提取程序 V1.10"
For i = 1 To 10
Combo1.AddItem i
Next
Combo1.ListIndex = 0
Command1.Caption = "读取数据"
Command2.Caption = "抽取数据"
Command3.Caption = "保存数据"
Command3.Enabled = False
Command2.Enabled = False
labtip.Caption = "请先读取数据!!"
List1.Clear
l = 0
Option1.Caption = "13开头号源"
Option2.Caption = "15开头号源"
End SubPrivate Sub Form_Unload(Cancel As Integer)
Dim i%
If Command3.Enabled = True Then
i = MsgBox("你还没有保存数据,现在需要保存吗??", 1, "警告!")
If i = 1 Then Call Command3_Click
If i = 2 Then End
End If
End SubPrivate Sub Option1_Click()
If Command3.Enabled = True Then Exit Sub
Command1.Enabled = True
Command3.Enabled = False
Command2.Enabled = False
End SubPrivate Sub Option2_Click()
If Command3.Enabled = True Then Exit Sub
Command1.Enabled = True
Command3.Enabled = False
Command2.Enabled = False
End Sub
自己按照代码加控件和改代码内容
是根据别人的改的
RANDOMIZE
A=INT(RND()*
RANDOMIZE
A=INT(RND()*50+1)
PRINT A
先做3个Label
Private Sub Command1_Click()
Randomize
Label2.Caption = Fix(Rnd * 45)
Label3.Caption = Fix(Rnd * 45)
Label4.Caption = Fix(Rnd * 45)
If Label2.Caption = 6 Or Label3.Caption = 6 Or Label4.Caption = 6 Then
Image1.Visible = True
Else
Image1.Visible = False
End If
End Sub
Private Sub Command2_Click()
End
End Sub
把你的邮箱留下
我这里有一个随机点名的程序和源码
直接发给你,你就可以用