modpub
Option Explicit Private Type TGold strOrder As String strOpen As String strDate As String IsCurrentWin As Boolean '根据上期建议出奖的结果是否赢了 strSuggestNext As String '建议下期出奖的号码 strResult As String '最终每条记录呈现的结果 End Type Public arrGold() As TGold Private Type TSpace intNo As Integer intCount As Integer End Type Public arrSpace(9) As TSpace Public intSpaceTmp As TSpace Public strAppPath As String '应用程序目录 Sub main() ' MsgBox getRnd3 & getRnd3 & getRnd3 & getRnd3 frmMain.Show End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '功能：根据所给的文件名返回文件的内容 '函数名：fileStr '入口参数(如下)： ' strFileName 所给的文件名； '返回值：文件的内容 '备注：sysdzw 于 2007-5-3 提供 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function fileStr(ByVal strFileName As String) As String On Error GoTo Err1 Dim lFile& lFile = FreeFile Open strFileName For Input As #lFile fileStr = StrConv(InputB$(LOF(lFile), #lFile), vbUnicode) Close #lFile If Right(fileStr, 2) = vbCrLf Then fileStr = Left(fileStr, Len(fileStr) - 2) Exit Function Err1: MsgBox "不存在该文件或该文件不能访问！", vbExclamation End Function Public Function getRnd3() As String Dim i%, s$, v s = "0,1,2,3,4,5,6,7,8,9" v = Split(s, ",") Randomize i = v(Int(Rnd * UBound(v) + 1)) getRnd3 = getRnd3 & i If i = Right(s, 1) Then s = Left(s, Len(s) - 2) Else s = Replace(s, i & ",", "") End If v = Split(s, ",") ' Randomize i = v(Int(Rnd * UBound(v) + 1)) getRnd3 = getRnd3 & i v = Split(s, ",") ' Randomize If i = Right(s, 1) Then s = Left(s, Len(s) - 2) Else s = Replace(s, i & ",", "") End If v = Split(s, ",") Randomize i = v(Int(Rnd * UBound(v) + 1)) getRnd3 = getRnd3 & i End Function
frmMain
Option Explicit Private Sub Check1_Click() Timer1.Enabled = Check1.Value End Sub Private Sub Command1_Click() Command1.Enabled = False Me.Caption = "重庆时时彩查看分析工具 - 最近120期开奖结果" setKey "http://video.shishicai.cn/haoma/" & Text1.Tag & "ssc/list/more.aspx" Command1.Enabled = True End Sub Private Sub cmdTest_Click() frmEarn.setMoney frmEarn.Show , Me End Sub Private Sub optPro_Click(Index As Integer) Text1.Tag = optPro(Index).Tag Call Timer1_Timer End Sub Private Sub Text2_Change() Timer1.Interval = Val(Text2.Text) * 1000 End Sub Private Sub Timer1_Timer() setKey "http://video.shishicai.cn/haoma/" & Text1.Tag & "ssc/list/more.aspx" End Sub 'http://video.shishicai.cn/haoma/cqssc/list/2010-05-01.aspx Private Sub Command2_Click() Command2.Enabled = False Me.Caption = "重庆时时彩查看分析工具 - " & txtDate.Text & "开奖结果" setKey "http://video.shishicai.cn/haoma/" & Text1.Tag & "ssc/list/" & txtDate.Text & ".aspx" Command2.Enabled = True End Sub Private Sub Form_Load() strAppPath = App.Path If Right(strAppPath, 1) <> "\" Then strAppPath = strAppPath & "\" Me.Caption = strDecode16Hex("D6D8%C7E" & "CCA%" & "B1CAB1B2" & "CA%B2%E9" & "BFB" & "4%B7%D6%CE" & "%F6" & Chr(37) & Chr(66) & "9%A4BE" & Chr(68) & "F20" & Chr(37) & "28CAB1" & "%CAB1" & "%B2%CA%C8" & "%ED%" & "BCFE%B6%" & "A8%D6%C" & "6%2FB7" & "%D6CEF6%" & Chr(50) & "F%C8" & "%ABD7D4B" & "6AFCDB" & "6%D7A2%C" & Chr(65) & Chr(37) & "B5%CFD6" & "20C1AA%" & "CF%B" & "5%515131" & "37%313937" & Chr(51) & "7%373539" & "29") Text1.Tag = "cq" txtDate.Text = Format(Now, "yyyy-mm-dd") Text1.Text = setKey("http://video.shishicai.cn/haoma/" & Text1.Tag & "ssc/list/more.aspx") Call Check1_Click End Sub Private Sub Form_Resize() On Error Resume Next Text1.Move 0, Text1.Top, Me.ScaleWidth, Me.ScaleHeight - Text1.Top cmdTest.Left = Me.ScaleWidth - cmdTest.Width - 45 txtNoWait.Left = Me.ScaleWidth - txtNoWait.Width - 180 txtWait.Left = Me.ScaleWidth - txtWait.Width - txtNoWait.Width - 360 End Sub 'http://video.shishicai.cn/haoma/cqssc/list/more.aspx 'http://video.shishicai.cn/haoma/cqssc/list/2010-05-01.aspx Private Function setKey(ByVal strUrl As String) As String Dim strData As String Dim reg As Object Dim matchs As Object, match As Object Dim strOpen$, strTmp$, strRight2$, strLeft2$, strRight3$, strLeft3$ Dim i%, j%, k%, m%, n%, strWait$ Dim isOk As Boolean '开奖是否中了 Dim intCount As Integer '对开奖次数进行计数 lblStatus.Caption = "正在取数据 ..." strWait = txtWait.Text strData = getHtmlStr(strUrl) ' strData = fileStr(strAppPath & "demo2.txt") Set reg = CreateObject("vbscript.regExp") reg.Global = True reg.IgnoreCase = True reg.MultiLine = True reg.Pattern = """BonusNumberString""\:""([\d,]{9})\|\d\|\d"",""BonusTime""\:""(.{16})"",""IssueNumber""\:""([\d\-]+)""" Set matchs = reg.Execute(strData) setKey = Space(5) & "期数" & Space(5) & "开奖" & Space(12) & "前三不定位" & Space(15) & "后三不定位" & Space(12) & "组三情况" & Space(13) & "前二不定位" & Space(15) & "后二不定位 中奖" & Space(8) & "开奖时间" & vbCrLf & _ String(170, "=") & vbCrLf intCount = 0 For Each match In matchs ReDim Preserve arrGold(intCount) arrGold(intCount).strOrder = match.SubMatches(2) arrGold(intCount).strOpen = Replace(match.SubMatches(0), ",", "") arrGold(intCount).strDate = match.SubMatches(1) intCount = intCount + 1 Next If intCount = 0 Then MsgBox "无法得到结果，请检查网络是否正常！", vbExclamation Exit Function End If Dim intSpaceCount As Integer Dim intNotWin%, intNotWinMax% Dim intWinCount% For i = UBound(arrGold) To 0 Step -1 '对120个数据进行处理 For j = 0 To 9 '依次检测各个数字的中奖间隔，先处理后二的情况 intSpaceCount = 0 For k = i To UBound(arrGold) '从整个结果中检索数字j当前间隔多少 strRight2 = Right(arrGold(k).strOpen, 2) '*** If InStr(strRight2, j) = 0 Then intSpaceCount = intSpaceCount + 1 Else Exit For End If Next arrSpace(j).intNo = j arrSpace(j).intCount = intSpaceCount Next '对arrSpace进行从大到小排序 For m = 0 To 9 For n = m + 1 To 9 If arrSpace(n).intCount > arrSpace(m).intCount Then intSpaceTmp = arrSpace(n) arrSpace(n) = arrSpace(m) arrSpace(m) = intSpaceTmp End If Next Next strRight2 = Right(arrGold(i).strOpen, 2) arrGold(i).strSuggestNext = arrSpace(0).intNo & arrSpace(1).intNo & arrSpace(2).intNo '得出建议出奖的结果，供下一次开奖时进行比较 ' arrGold(i).strSuggestNext = txtNoWait.Text ' arrGold(i).strSuggestNext = getRnd3 '得出建议出奖的结果，供下一次开奖时进行比较 If i = UBound(arrGold) Then arrGold(i).IsCurrentWin = False '因为它是第一个，所以没法和谁做比较得出建议出奖结果 Else If Left(strRight2, 1) <> Right(strRight2, 1) Then arrGold(i).IsCurrentWin = (InStr(strRight2, Mid(arrGold(i + 1).strSuggestNext, 1, 1)) = 0 And InStr(strRight2, Mid(arrGold(i + 1).strSuggestNext, 2, 1)) = 0 And InStr(strRight2, Mid(arrGold(i + 1).strSuggestNext, 3, 1)) = 0) Else arrGold(i).IsCurrentWin = False End If End If If Not arrGold(i).IsCurrentWin Then intNotWin = intNotWin + 1 Else intWinCount = intWinCount + 1 If intNotWin > intNotWinMax Then intNotWinMax = intNotWin intNotWin = 0 End If Next ' txtNoWait.Text = arrGold(0).strSuggestNext Command1.Caption = "最近120期 (" & intNotWinMax & " " & Format(intWinCount * 100 / 120, "0.00") & "%)" '下面整理准备用于显示结果 For i = 0 To UBound(arrGold) '对120个数据进行处理 strLeft2 = Left(arrGold(i).strOpen, 2) strRight2 = Right(arrGold(i).strOpen, 2) strLeft3 = Left(arrGold(i).strOpen, 3) strRight3 = Right(arrGold(i).strOpen, 3) '前三不定位情况 strTmp = " |" For j = 0 To 9 strTmp = strTmp & IIf(InStr(strLeft3, CStr(j)) > 0, j, " ") & "|" Next '后三不定位情况 strTmp = strTmp & " |" For j = 0 To 9 strTmp = strTmp & IIf(InStr(strRight3, CStr(j)) > 0, j, " ") & "|" Next '前三组三情况 If (Mid(strLeft3, 1, 1) = Mid(strLeft3, 2, 1) And Mid(strLeft3, 1, 1) <> Mid(strLeft3, 1, 3)) Or _ (Mid(strLeft3, 1, 1) = Mid(strLeft3, 3, 1) And Mid(strLeft3, 1, 1) <> Mid(strLeft3, 2, 1)) Or _ (Mid(strLeft3, 2, 1) = Mid(strLeft3, 3, 1) And Mid(strLeft3, 2, 1) <> Mid(strLeft3, 1, 1)) Then strTmp = strTmp & " 前三组三|" Else strTmp = strTmp & " |" End If '后三组三情况 If (Mid(strRight3, 1, 1) = Mid(strRight3, 2, 1) And Mid(strRight3, 1, 1) <> Mid(strRight3, 1, 3)) Or _ (Mid(strRight3, 1, 1) = Mid(strRight3, 3, 1) And Mid(strRight3, 1, 1) <> Mid(strRight3, 2, 1)) Or _ (Mid(strRight3, 2, 1) = Mid(strRight3, 3, 1) And Mid(strRight3, 2, 1) <> Mid(strRight3, 1, 1)) Then strTmp = strTmp & "后三组三" Else strTmp = strTmp & " " End If '前二不定位情况 strTmp = strTmp & " |" For j = 0 To 9 strTmp = strTmp & IIf(InStr(strLeft2, CStr(j)) > 0, j, " ") & "|" Next '后二不定位情况 strTmp = strTmp & " |" For j = 0 To 9 strTmp = strTmp & IIf(InStr(strRight2, CStr(j)) > 0, j, " ") & "|" Next If arrGold(i).IsCurrentWin Then If i = 0 Then isOk = True End If If i <> UBound(arrGold) Then strTmp = strTmp & arrGold(i + 1).strSuggestNext & "√中" Else strTmp = strTmp & "---√中" End If Else If i <> UBound(arrGold) Then strTmp = strTmp & arrGold(i + 1).strSuggestNext & "× " Else strTmp = strTmp & "---× " End If End If setKey = setKey & arrGold(i).strOrder & " " & arrGold(i).strOpen & strTmp & Space(4) & arrGold(i).strDate & vbCrLf Next If setKey <> "" Then setKey = Left(setKey, Len(setKey) - 2) If setKey <> Text1.Text Then Text1.Text = setKey If Text1.Text <> "" Then If isOk Then PlayMusic strAppPath & "ok.mid" Else PlayMusic strAppPath & "new.mid" End If End If lblStatus.Caption = "数据已更新 " & Format(Now, "yyyy-mm-dd hh:nn:ss") Else lblStatus.Caption = "数据未更新，上次更新时间 " & Format(Now, "yyyy-mm-dd hh:nn:ss") End If End Function Public Function getHtmlStr(strUrl As String) As String Dim XmlHttp As Object Set XmlHttp = CreateObject("Microsoft.XMLHTTP") XmlHttp.Open "GET", strUrl, False On Error GoTo Err_net XmlHttp.send getHtmlStr = BytesToBstr(XmlHttp.ResponseBody, "UTF-8") Set XmlHttp = Nothing Err_net: End Function Private Function BytesToBstr(strBody, codeBase) As String Dim objStream As Object Set objStream = CreateObject("Adodb.Stream") objStream.Type = 1 objStream.Mode = 3 objStream.Open objStream.Write strBody objStream.position = 0 objStream.Type = 2 objStream.Charset = codeBase BytesToBstr = objStream.ReadText objStream.Close Set objStream = Nothing End Function Private Sub txtDate_Change() lblWeek.Caption = "W" & Weekday(txtDate.Text, vbMonday) End Sub Public Function strDecode16Hex(strSource$) Dim i As Long Dim bytSource() As Byte On Error GoTo Err1 strSource = Replace(strSource, "%", "") ReDim bytSource(Len(strSource) / 2 - 1) For i = 0 To Len(strSource) / 2 - 1 bytSource(i) = "&H" & (Mid(strSource, i * 2 + 1, 2)) Next strDecode16Hex = StrConv(bytSource, vbUnicode) Exit Function Err1: MsgBox "要解密的内容不合法！", vbExclamation End Function Private Sub txtNoWait_Change() Dim i%, s$ For i = 0 To 9 If InStr(txtNoWait.Text, i) = 0 Then s = s & i Next txtWait.Text = s End Sub Private Sub txtWait_Change() Dim i%, s$ For i = 0 To 9 If InStr(txtWait.Text, i) = 0 Then s = s & i Next txtNoWait.Text = s End Sub