|
Option Explicit
Private a As Long, b As Long, c As Long
Private d As String
Private xy(-1 To 7, -1 To 6) As String
Private js As Long
'按“开始”开始工作，按“停止”停止工作。（由于工作时间很长，当天不想干了，以后还可继续）
Private Sub Command1_Click()
If Timer1.Enabled = False Then Timer1.Enabled = True Else Timer1.Enabled = False
End Sub
'程序开始，初始化数据
Private Sub Form_Load()
Dim c0 As String
a = 231925775 '最大的场景编号
b = 2445323 '最小的场景编号
Open App.Path & ("\计数.dat") For Random As #1 Len = 12 '上一次工作，搜索了多少编号
Get #1, 1, c0
Close #1
c = Val(c0): Text1.Text = c
Open App.Path & ("\计数.dat") For Random As #1 Len = 12 '上一次工作，搜索出了多少场景
Get #1, 2, c0
Close #1
js = Val(c0): Text2.Text = js
End Sub
'工作内容
'在这里，时间控件是一个有趣的尝试，如果不用它完全可以，用 Do...Loop 但工作起来很无聊，也中止不了程序。用了它，的确大不一样
Private Sub Timer1_Timer()
Dim i As Integer, j As Integer, l As Long
Dim a0 As Integer, a1 As Integer, a4 As Integer, k As Integer
Dim sj As Boolean
For l = c To c + 9999 ' 每次搜索 10000 个编号
If b + l > a Then Timer1.Enabled = False: c = l - 1: Text1.Text = c: Exit Sub
d = js0(b + l) '.............翻译成 5 进制的数
Do '.............必须满足 12 个字符串的长度
If Len(d) >= 12 Then Exit Do
If Len(d) < 12 Then d = "0" + d
Loop
For j = -1 To 7 '.............初始化数组“xy()”
For i = -1 To 6
xy(j, i) = ""
Next i
Next j
k = 0 '.............给数组赋值
For j = 1 To 5
For i = 1 To 4
If xy(j, i) = "" Then
k = k + 1: xy(j, i) = Mid$(d, k, 1)
If xy(j, i) = "2" Then xy(j + 1, i) = "2"
If xy(j, i) = "3" Then xy(j, i + 1) = "3"
If xy(j, i) = "4" Then xy(j, i + 1) = "4": xy(j + 1, i) = "4": xy(j + 1, i + 1) = "4"
End If
If k >= 12 Then Exit For
Next i
If k >= 12 Then Exit For
Next j
d = "" '..............把 “xy()”联成新的扩充了的字符串 “d”
For j = 1 To 5
For i = 1 To 4
If xy(j, i) <> "" Then d = d + xy(j, i)
Next i
Next j
a0 = 0: a1 = 0: a4 = 0 '......计算“空位”、“小方块”、“大方块”的数量。
For j = 1 To 5
For i = 1 To 4
If xy(j, i) = "0" Then a0 = a0 + 1
If xy(j, i) = "1" Then a1 = a1 + 1
If xy(j, i) = "4" Then a4 = a4 + 1
Next i
Next j
sj = True
If a0 <> 2 Or a1 <> 4 Or a4 <> 4 Or Len(d) <> 20 Or (xy(5, 2) = "4" And xy(5, 3) = "4") Then sj = False
If sj = True Then '...........如果符合要求，继续记录
js = js + 1: Text2.Text = js
Open App.Path & ("\全部场景.dat") For Random As #1 Len = 22
Put #1, js, d
Close #1
End If
Next l
DoEvents
c = c + 10000: Text1.Text = c '一次循环结束，加上 10000，再进行下一次循环
End Sub
'十进制换五进制
Function js0(M As Double) As String
Dim N As Integer
Dim sj0 As String, sj1 As String
Dim w As Integer
sj0 = ""
Do
w = M - Int(M / 5) * 5
If w > 9 Then sj1 = Chr$(55 + w) Else sj1 = LTrim$(Str$(w))
sj0 = sj1 + sj0
M = Int(M / 5): If M = 0 Then Exit Do
Loop
js0 = sj0
End Function
'当关闭程序时，记录工作情况
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Timer1.Enabled = True Then Cancel = 1 Else Cancel = 0
Dim c0 As String
c0 = Str$(c)
Open App.Path & ("\计数.dat") For Random As #1 Len = 12 '.....打开随机文件
Put #1, 1, c0 '..............................................记录编号计数
Close #1 '....................................................关闭文件
c0 = Str$(js)
Open App.Path & ("\计数.dat") For Random As #1 Len = 12 '.....打开随机文件
Put #1, 2, c0 '..............................................记录布局计数
Close #1 '....................................................关闭文件
End Sub
|
