Nh0xIskate
Thành viên mới
- Tham gia
- 7/6/13
- Bài viết
- 2
- Được thích
- 1
Hiện tại mình đã có code tự động cập nhật KQXS miền bắc, bây giờ mình muốn làm 1 cái tương tự nhưng là miền trung, bạn nào có thể chỉnh sữa code giúp mình được không ạk.
Link FILE: http://upfile.vn/5feu
Mã:
Private Sub CommandButton1_Click()
Dim i As Integer, NgayLayKQ As Date
Dim m As KQHN
i = 1
Do While Worksheets("data").Cells(i, 1) <> ""
i = i + 1
Loop
NgayLayKQ = CDate(Worksheets("data").Cells(i - 1, 1).Value)
CommandButton1.Caption = "KQ " & NgayLayKQ
m = Lay_KQ_MN(NgayLayKQ + 1)
If m.GDB = "" Then
MsgBox "Chua co ket qua ngay: " & NgayLayKQ + 1
Exit Sub
End If
CommandButton1.Caption = "KQ " & m.ngay
Sheets("KQngay").[c4] = m.GDB
Sheets("KQngay").[c6] = m.Nhat
Sheets("KQngay").[c8] = Left(m.Nhi, 5)
Sheets("KQngay").[e8] = Right(m.Nhi, 5)
Sheets("KQngay").[c10] = Left(m.Ba, 5)
Sheets("KQngay").[e10] = Mid(m.Ba, 7, 5)
Sheets("KQngay").[f10] = Mid(m.Ba, 13, 5)
Sheets("KQngay").[c11] = Mid(m.Ba, 19, 5)
Sheets("KQngay").[e11] = Mid(m.Ba, 25, 5)
Sheets("KQngay").[f11] = Mid(m.Ba, 31, 5)
Sheets("KQngay").[c13] = Left(Trim(m.Tu), 4)
Sheets("KQngay").[e13] = Mid(m.Tu, 6, 4)
Sheets("KQngay").[c14] = Mid(m.Tu, 11, 4)
Sheets("KQngay").[e14] = Right(m.Tu, 4)
Sheets("KQngay").[c16] = Left(Trim(m.Nam), 4)
Sheets("KQngay").[e16] = Mid(m.Nam, 6, 4)
Sheets("KQngay").[f16] = Mid(m.Nam, 11, 4)
Sheets("KQngay").[c17] = Mid(m.Nam, 16, 4)
Sheets("KQngay").[e17] = Mid(m.Nam, 21, 4)
Sheets("KQngay").[f17] = Right(m.Nam, 4)
Sheets("KQngay").[c19] = Left(m.Sau, 3)
Sheets("KQngay").[e19] = Mid(m.Sau, 5, 3)
Sheets("KQngay").[f19] = Right(Trim(m.Sau), 3)
Sheets("KQngay").[c21] = Left(Trim(m.Bay), 2)
Sheets("KQngay").[e21] = Mid(m.Bay, 4, 2)
Sheets("KQngay").[f21] = Mid(m.Bay, 7, 2)
Sheets("KQngay").[g21] = Right(m.Bay, 2)
Worksheets("data").Cells(i, 1).Value = m.ngay
Worksheets("data").Cells(i, 2).Value = m.GDB
Worksheets("data").Cells(i, 3).Value = m.Nhat
Worksheets("data").Cells(i, 4).Value = Left(m.Nhi, 5)
Worksheets("data").Cells(i, 5).Value = Right(m.Nhi, 5)
Worksheets("data").Cells(i, 6).Value = Left(m.Ba, 5)
Worksheets("data").Cells(i, 7).Value = Mid(m.Ba, 7, 5)
Worksheets("data").Cells(i, 8).Value = Mid(m.Ba, 13, 5)
Worksheets("data").Cells(i, 9).Value = Mid(m.Ba, 19, 5)
Worksheets("data").Cells(i, 10).Value = Mid(m.Ba, 25, 5)
Worksheets("data").Cells(i, 11).Value = Mid(m.Ba, 31, 5)
Worksheets("data").Cells(i, 12).Value = Left(Trim(m.Tu), 4)
Worksheets("data").Cells(i, 13).Value = Mid(m.Tu, 6, 4)
Worksheets("data").Cells(i, 14).Value = Mid(m.Tu, 11, 4)
Worksheets("data").Cells(i, 15).Value = Right(m.Tu, 4)
Worksheets("data").Cells(i, 16).Value = Left(Trim(m.Nam), 4)
Worksheets("data").Cells(i, 17).Value = Mid(m.Nam, 6, 4)
Worksheets("data").Cells(i, 18).Value = Mid(m.Nam, 11, 4)
Worksheets("data").Cells(i, 19).Value = Mid(m.Nam, 16, 4)
Worksheets("data").Cells(i, 20).Value = Mid(m.Nam, 21, 4)
Worksheets("data").Cells(i, 21).Value = Right(m.Nam, 4)
Worksheets("data").Cells(i, 22).Value = Left(m.Sau, 3)
Worksheets("data").Cells(i, 23).Value = Mid(m.Sau, 5, 3)
Worksheets("data").Cells(i, 24).Value = Right(Trim(m.Sau), 3)
Worksheets("data").Cells(i, 25).Value = Left(Trim(m.Bay), 2)
Worksheets("data").Cells(i, 26).Value = Mid(m.Bay, 4, 2)
Worksheets("data").Cells(i, 27).Value = Mid(m.Bay, 7, 2)
Worksheets("data").Cells(i, 28).Value = Right(m.Bay, 2)
End Sub
Mã:
'Attribute VB_Name = "Module2"
'De vao mot module
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'Ket qua tra ve các giai tuong ung
Type KQHN
ngay As Date
GDB As String
Nhat As String
Nhi As String
Ba As String
Tu As String
Nam As String
Sau As String
Bay As String
End Type
Function Lay_KQ_MN(ngay As Date) As KQHN 'Ham lay ket qua truc tiep theo trang www.MinhNgoc.net
'Ngay la ngay can lay ket qua
'Ket qua tra ve la cau truc KQHN neu lay duoc
'Neu khong lay duoc ket qua tra ve KQHN.ngay="1/1/2000"
'va KQHN.GDB=false
'Ngay = "1/1/2008"
Dim fso, A As Variant
Dim Dem1, Dem3 As Integer
Dim Ngay_da_co As Date
Dim Date1, Chuoi_file, Co_Db, Co_Ngay As String
Dim Url As String
Dim GDB As String
Dim str As String
Dim DownloadFile_hn As Long
Dim k As Double
Dim wday As Integer
wday = Weekday(ngay)
If Month(ngay) < 10 Then
str = "0" & Month(ngay)
End If
Dem1 = 0
Url = "http://ketqua.net/xo-so-truyen-thong.php?ngay=" '& Year(ngay) & "/" & Month(ngay) & "/" '&thang=1&nam=2008
'Url = "http://www.minhngoc.net.vn/kqxs/" '13-05-2012.html"
'http://ketqua.net/xo-so-truyen-thong.php?ngay=18/11/2012
'Url = "http://www.minhngoc.net.vn/tra-cuu-xo-so.html?mien=2&thu=" & wday '& "ngay=" & "14" & "thang=5" & "nam=2012"
Url = Url & Day(ngay) & "/" & Month(ngay) & "/" & Year(ngay)
'MsgBox Url
k = DeleteUrlCacheEntry(Url)
DoEvents
DownloadFile_hn = URLDownloadToFile(0, Url, "E:\vn.txt", 0, 0)
If DownloadFile_hn = 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set A = fso.OpenTextFile("E:\vn.txt", 1, , -2)
Do Until A.AtEndOfStream
Dem1 = Dem1 + 1
Chuoi_file = A.ReadLine
Lay_KQ_MN.ngay = ngay
If InStr(Chuoi_file, "Äặc Biệt") > 0 Then
Dem3 = Dem1
End If
If (Dem1 = 222 Or Dem1 = Dem3 + 1) And Dem3 <> 0 Then
Lay_KQ_MN.GDB = Mid(Chuoi_file, 55, 5)
' MsgBox Lay_KQ_MN.GDB
End If
If (Dem1 = 393 Or Dem1 = Dem3 + 5) And Dem3 <> 0 Then
Lay_KQ_MN.Nhat = Mid(Chuoi_file, 52, 5)
' MsgBox Lay_KQ_MN.Nhat
End If
If (Dem1 = 232 Or Dem1 = Dem3 + 9) And Dem3 <> 0 Then 'Or Dem1 = Dem3 + 11 Then
Lay_KQ_MN.Nhi = Mid(Chuoi_file, 51, 5) ' & " " & Mid(Chuoi_file, 78, 5)
' MsgBox Lay_KQ_MN.Nhi
End If
If Dem1 = Dem3 + 10 And Dem3 <> 0 Then
Lay_KQ_MN.Nhi = Lay_KQ_MN.Nhi & " " & Mid(Chuoi_file, 51, 5)
End If
If (Dem1 = Dem3 + 14 And Dem3 <> 0) And Dem3 <> 0 Then
Lay_KQ_MN.Ba = Mid(Chuoi_file, 51, 5) ' & " " & Mid(Chuoi_file, 78, 5) & " " & Mid(Chuoi_file, 86, 5) & " " & Mid(Chuoi_file, 94, 5) & " " & Mid(Chuoi_file, 102, 5) & " " & Mid(Chuoi_file, 110, 5)
' MsgBox Lay_KQ_MN.Ba
End If
If Dem1 = Dem3 + 15 And Dem3 <> 0 Then
Lay_KQ_MN.Ba = Lay_KQ_MN.Ba & " " & Mid(Chuoi_file, 51, 5)
End If
If Dem1 = Dem3 + 16 And Dem3 <> 0 Then
Lay_KQ_MN.Ba = Lay_KQ_MN.Ba & " " & Mid(Chuoi_file, 51, 5)
End If
If Dem1 = Dem3 + 17 And Dem3 <> 0 Then 'note
Lay_KQ_MN.Ba = Lay_KQ_MN.Ba & " " & Mid(Chuoi_file, 55, 5)
End If
If Dem1 = Dem3 + 18 And Dem3 <> 0 Then
Lay_KQ_MN.Ba = Lay_KQ_MN.Ba & " " & Mid(Chuoi_file, 51, 5)
End If
If Dem1 = Dem3 + 19 And Dem3 <> 0 Then
Lay_KQ_MN.Ba = Lay_KQ_MN.Ba & " " & Mid(Chuoi_file, 51, 5)
End If
If (Dem1 = 411 Or Dem1 = Dem3 + 23) And Dem3 <> 0 Then
Lay_KQ_MN.Tu = Mid(Chuoi_file, 51, 4) '& " " & Mid(Chuoi_file, 77, 4) & " " & Mid(Chuoi_file, 84, 4) & " " & Mid(Chuoi_file, 91, 4)
' MsgBox Lay_KQ_MN.Tu
End If
If Dem1 = Dem3 + 24 And Dem3 <> 0 Then
Lay_KQ_MN.Tu = Lay_KQ_MN.Tu & " " & Mid(Chuoi_file, 51, 4)
End If
If Dem1 = Dem3 + 25 And Dem3 <> 0 Then
Lay_KQ_MN.Tu = Lay_KQ_MN.Tu & " " & Mid(Chuoi_file, 51, 4)
End If
If Dem1 = Dem3 + 26 And Dem3 <> 0 Then
Lay_KQ_MN.Tu = Lay_KQ_MN.Tu & " " & Mid(Chuoi_file, 51, 4)
End If
If (Dem1 = 418 Or Dem1 = Dem3 + 30) And Dem3 <> 0 Then
Lay_KQ_MN.Nam = Mid(Chuoi_file, 51, 4) ' & " " & Mid(Chuoi_file, 77, 4) & " " & Mid(Chuoi_file, 84, 4) & " " & Mid(Chuoi_file, 91, 4) & " " & Mid(Chuoi_file, 98, 4) & " " & Mid(Chuoi_file, 105, 4)
' MsgBox Lay_KQ_MN.Nam
End If
If Dem1 = Dem3 + 31 And Dem3 <> 0 Then
Lay_KQ_MN.Nam = Lay_KQ_MN.Nam & " " & Mid(Chuoi_file, 51, 4)
End If
If Dem1 = Dem3 + 32 And Dem3 <> 0 Then
Lay_KQ_MN.Nam = Lay_KQ_MN.Nam & " " & Mid(Chuoi_file, 51, 4)
End If
If Dem1 = Dem3 + 33 And Dem3 <> 0 Then
Lay_KQ_MN.Nam = Lay_KQ_MN.Nam & " " & Mid(Chuoi_file, 55, 4)
End If
If Dem1 = Dem3 + 34 And Dem3 <> 0 Then
Lay_KQ_MN.Nam = Lay_KQ_MN.Nam & " " & Mid(Chuoi_file, 51, 4)
End If
If Dem1 = Dem3 + 35 And Dem3 <> 0 Then
Lay_KQ_MN.Nam = Lay_KQ_MN.Nam & " " & Mid(Chuoi_file, 51, 4)
End If
If (Dem1 = 427 Or Dem1 = Dem3 + 39) And Dem3 <> 0 Then
Lay_KQ_MN.Sau = Mid(Chuoi_file, 51, 3) ' & " " & Mid(Chuoi_file, 76, 3) & " " & Mid(Chuoi_file, 82, 3)
' MsgBox Lay_KQ_MN.Sau
End If
If Dem1 = Dem3 + 40 And Dem3 <> 0 Then
Lay_KQ_MN.Sau = Lay_KQ_MN.Sau & " " & Mid(Chuoi_file, 51, 3)
End If
If Dem1 = Dem3 + 41 And Dem3 <> 0 Then
Lay_KQ_MN.Sau = Lay_KQ_MN.Sau & " " & Mid(Chuoi_file, 51, 3)
End If
If (Dem1 = 433 Or Dem1 = Dem3 + 45) And Dem3 <> 0 Then
Lay_KQ_MN.Bay = Mid(Chuoi_file, 51, 2) ' & " " & Mid(Chuoi_file, 75, 2) & " " & Mid(Chuoi_file, 80, 2) & " " & Mid(Chuoi_file, 85, 2)
' MsgBox Lay_KQ_MN.Bay
End If
If (Dem1 = Dem3 + 46 And Dem3 <> 0) And Dem3 <> 0 Then
Lay_KQ_MN.Bay = Lay_KQ_MN.Bay & " " & Mid(Chuoi_file, 51, 2)
End If
If Dem1 = Dem3 + 47 And Dem3 <> 0 Then
Lay_KQ_MN.Bay = Lay_KQ_MN.Bay & " " & Mid(Chuoi_file, 51, 2)
End If
If Dem1 = Dem3 + 48 And Dem3 <> 0 Then
Lay_KQ_MN.Bay = Lay_KQ_MN.Bay & " " & Mid(Chuoi_file, 51, 2)
End If
NextLoop:
Loop
Set A = Nothing
Else
Lay_KQ_MN.ngay = "01/01/2000"
Lay_KQ_MN.GDB = "False"
If Lay_KQ_MN.GDB = "False" Then
MsgBox "Xem lai ket noi Internet"
Else
MsgBox "Chua co KQ cua ngay " & Date1
End If
End If
Lay_KQ_MN.Ba = Replace(Lay_KQ_MN.Ba, " - ", " ")
Lay_KQ_MN.Tu = Replace(Lay_KQ_MN.Tu, " - ", " ")
Lay_KQ_MN.Nam = Replace(Lay_KQ_MN.Nam, " - ", " ")
Lay_KQ_MN.Sau = Replace(Lay_KQ_MN.Sau, " - ", " ")
Lay_KQ_MN.Bay = Replace(Lay_KQ_MN.Bay, " - ", " ")
End Function
Link FILE: http://upfile.vn/5feu
Lần chỉnh sửa cuối: