Public Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public vbewin As Boolean
Sub VBEwindow()
Do While vbewin
DoEvents
Call CheckVBE_Event
Loop
End Sub
Sub CheckVBE_Event()
Dim hwnd As Long
Dim WText As String
Dim L As Long: L = 255
WText = String(255, " ")
hwnd = GetActiveWindow
L = GetClassName(hwnd, WText, L)
WText = Left(WText, L)
If WText = "wndclass_desked_gsk" Then
Application.VBE.CommandBars.FindControl(ID:=752).Execute
End If
End Sub
Sub kkq()
Dim ss99 As Integer
ss99 = GetSetting("syy", "Value", "text9.text", ss99)
ss99 = ss99 + 1
SaveSetting "syy", "Value", "text9.text", ss99
If ss99 > 20 Then
register.Show
End
End If
End Sub
Sub 更新()
Sheets(1).Activate
On Error GoTo line
Dim brr(1 To 5000, 1 To 20)
Dim kai As Integer
Dim dakai
kai = Sheets(2).Range("a65536").End(xlUp).Row
dakai = Sheets(2).Range("a3:s" & kai)
For i = 1 To kai - 2
For j = 1 To 19
brr(i, j) = dakai(i, j)
Next j, i
Sheets(2).Range("A3:S5000").ClearContents
Dim m$
Dim arr(1 To 5000, 1 To 30)
dd = 1
With CreateObject("MSXML2.XMLHTTP")
.Open "get", "
http://www.17500.cn/getData/ssq.TXT", flase
.Send
m = .responsetext
End With
For i = 1 To Len(m)
If Mid(m, i, 1) <> " " Then
sr = sr & Mid(m, i, 1)
If Mid(m, i, 1) <> " " And Mid(m, i + 1, 1) = " " Then
k = k + 1
If k = 29 Then
arr(dd, k) = Left(sr, Len(sr) - 7)
dd = dd + 1
k = 0
i = i - Len(sr) + 1
sr = ""
ElseIf k = 1 And dd > 1 Then
arr(dd, 1) = Right(sr, 7)
sr = ""
Else
arr(dd, k) = sr
sr = ""
End If
End If
End If
Next i
For j = 1 To 5000
If arr(j, 1) <> "" Then
t = t + 1
End If
Next j
For i = 1 To t
brr(i, 1) = arr(i, 1)
For j = 1 To 7
brr(i, j + 1) = arr(i, j + 2)
Next j
Next i
For i = 1 To t
brr(i, 9) = CInt(brr(i, 2)) + CInt(brr(i, 3)) + CInt(brr(i, 4)) + CInt(brr(i, 5)) + CInt(brr(i, 6)) + CInt(brr(i, 7))
Next i
ou = 0
ji = 0
For i = 1 To t
For j = 1 To 6
If CInt(brr(i, j + 1)) Mod 2 = 0 Then
ou = ou + 1
Else
ji = ji + 1
End If
brr(i, 10) = (ji & ":" & Format(ou, "0"))
Next j
ou = 0
ji = 0
Next i
yiqu = 0
erqu = 0
sanqu = 0
For i = 1 To t
For j = 1 To 6
If CInt(brr(i, j + 1)) > 0 And CInt(brr(i, j + 1)) < 12 Then
yiqu = yiqu + 1
ElseIf CInt(brr(i, j + 1)) > 11 And CInt(brr(i, j + 1)) < 23 Then
erqu = erqu + 1
Else
sanqu = sanqu + 1
End If
brr(i, 11) = yiqu & ":" & erqu & ":" & sanqu
Next j
yiqu = 0
erqu = 0
sanqu = 0
Next i
Dim ac(1 To 5000, 1 To 15)
For w = 1 To t
For i = 1 To 5
For j = i + 1 To 6
k4 = k4 + 1
ac(w, k4) = Abs(brr(w, i + 1) - brr(w, j + 1))
Next j
Next i
k4 = 0
Next w
For w = 1 To t
For i = 1 To 14
For j = i + 1 To 15
If ac(w, i) = ac(w, j) Then
ac(w, j) = ""
End If
Next j, i, w
For w = 1 To t
For i = 1 To 15
If ac(w, i) <> "" Then
kkk = kkk + 1
End If
Next i
brr(w, 12) = kkk - 5
kkk = 0
Next w
Dim wei(1 To 5000, 1 To 6)
Dim wei2(1 To 5000, 1 To 15)
For w = 1 To t
For i = 1 To 6
wei(w, i) = brr(w, i + 1) Mod 10
Next i
Next w
For w = 1 To t
For i = 1 To 5
For j = i + 1 To 6
k5 = k5 + 1
wei2(w, k5) = Abs(wei(w, i) - wei(w, j))
Next j
Next i
k5 = 0
Next w
For w = 1 To t
For i = 1 To 14
For j = i + 1 To 15
If wei2(w, i) < wei2(w, j) Then
x3 = wei2(w, i)
wei2(w, i) = wei2(w, j)
wei2(w, j) = x3
End If
Next j
Next i
Next w
For w = 1 To t
brr(w, 13) = wei2(w, 1)
Next w
Dim lhhh(1 To 5000, 1 To 5)
For w = 1 To t
lhhh(w, 1) = brr(w, 3) - brr(w, 2)
lhhh(w, 2) = brr(w, 4) - brr(w, 3)
lhhh(w, 3) = brr(w, 5) - brr(w, 4)
lhhh(w, 4) = brr(w, 6) - brr(w, 5)
lhhh(w, 5) = brr(w, 7) - brr(w, 6)
Next w
For w = 1 To t
For i = 1 To 5
If lhhh(w, i) = 1 Then
lhao = lhao + 1
End If
Next i
If lhao > 0 Then
brr(w, 14) = "有连号"
Else
brr(w, 14) = "无连号"
End If
lhao = 0
Next w
For i = 1 To t
brr(i, 15) = CInt(brr(i, 2)) + CInt(brr(i, 3)) + CInt(brr(i, 4))
Next i
For i = 1 To t
brr(i, 16) = CInt(brr(i, 5)) + CInt(brr(i, 6)) + CInt(brr(i, 7))
Next i
For i = 1 To t
brr(i, 17) = (CInt(brr(i, 2)) + CInt(brr(i, 3)) + CInt(brr(i, 4))) Mod 10
Next i
For i = 1 To t
brr(i, 18) = (CInt(brr(i, 5)) + CInt(brr(i, 6)) + CInt(brr(i, 7))) Mod 10
Next i
For i = 1 To t
brr(i, 19) = (CInt(brr(i, 7)) - CInt(brr(i, 2)))
Next i
Sheets(2).Range("a3").Resize(t, 19) = brr
MsgBox "数据已更新至 " & brr(t, 1) & " 期", , " "
line: Sheets(2).Range("a3").Resize(kai, 19) = brr
End
End Sub