Nhờ các bác sửa code để chạy phù hợp với Win 64bit

Liên hệ QC

DanTri007

Thành viên mới
Tham gia
14/4/14
Bài viết
39
Được thích
1
Em có cái code chạy update kết quả nhờ các bác sửa cho phù hợp với Win 64bit và gán file excel chạy thử.

Code đây ạ:


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
Dim rW As Long
Dim TP As clsMain




Sub Auto_Open()


Set TP = New clsMain
TP.Create Application
'Exit Sub
SpeedOnK
Call FixExcel
If PathExists("C:\Tamhoang") = False Then MkDir ("C:\Tamhoang")
Application.DisplayFormulaBar = False
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",false)"
Dim Index As Long, n As Long, Col As Long, row As Long, Text As String
Dim Rng As Range, fso As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Set Rng = Sheets("Lotto").Range("A2")
Ngay = Lotto.[a10000].End(3) + 1


If Hour(Now) > 18 Then
Dy = Date
Else
Dy = Date - 1
End If




For Days = Ngay To Dy
EndR = Lotto.[a10000].End(3).row
Sheet9.Range("B10").Resize(, 21).Value = Lotto.Range("BE10000").End(3).Resize(, 21).Value


URL = "http://www.minhngoc.net.vn/ket-qua-xo-so/mien-bac/"
URL = URL & Day(Days) & "-" & Month(Days) & "-" & Year(Days) & ".html"
DownloadFile_hn = URLDownloadToFile(0, URL, "C:\Tamhoang\vn.txt", 0, 0)
FilesToImport = "C:\Tamhoang\vn.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextSource = fso_OpenTextFile("C:\Tamhoang\vn.txt", 1, , -2)
NumOfLines = Split(TextSource.ReadAll, vbCrLf)

If UBound(NumOfLines) > 0 Then
Lotto.Cells(EndR + 1, "A") = Days
If Weekday(Days) = 1 Then
Lotto.Cells(EndR + 1, "B") = "CN"
Else
Lotto.Cells(EndR + 1, "B") = "T" & Weekday(Days)
End If
'ReDim Res(1 To UBound(NumOfLines), 1 To 1)
For row = 1 To UBound(NumOfLines)
Text = NumOfLines(row)
If Text <> "" Then
If InStr(Text, """giaidb""") > 0 Then
Lotto.Cells(EndR + 1, "C").Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
Sheet9.[L11].Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai1""") > 0 Then
Lotto.Cells(EndR + 1, "D") = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai2""") > 0 Then
Lotto.Cells(EndR + 1, "E") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "F") = "'" & Mid(NumOfLines(row + 1), 26, 5)
ElseIf InStr(Text, """giai3""") > 0 Then
Lotto.Cells(EndR + 1, "G") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "H") = "'" & Mid(NumOfLines(row + 1), 26, 5)
Lotto.Cells(EndR + 1, "I") = "'" & Mid(NumOfLines(row + 1), 42, 5)
Lotto.Cells(EndR + 1, "J") = "'" & Mid(NumOfLines(row + 1), 58, 5)
Lotto.Cells(EndR + 1, "K") = "'" & Mid(NumOfLines(row + 1), 74, 5)
Lotto.Cells(EndR + 1, "L") = "'" & Mid(NumOfLines(row + 1), 90, 5)
ElseIf InStr(Text, """giai4""") > 0 Then
Lotto.Cells(EndR + 1, "M") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "N") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "O") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "P") = "'" & Mid(NumOfLines(row + 1), 55, 4)
ElseIf InStr(Text, """giai5""") > 0 Then
Lotto.Cells(EndR + 1, "Q") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "R") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "S") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "T") = "'" & Mid(NumOfLines(row + 1), 55, 4)
Lotto.Cells(EndR + 1, "U") = "'" & Mid(NumOfLines(row + 1), 70, 4)
Lotto.Cells(EndR + 1, "V") = "'" & Mid(NumOfLines(row + 1), 85, 4)
ElseIf InStr(Text, """giai6""") > 0 Then
Lotto.Cells(EndR + 1, "W") = "'" & Mid(NumOfLines(row + 1), 10, 3)
Lotto.Cells(EndR + 1, "X") = "'" & Mid(NumOfLines(row + 1), 24, 3)
Lotto.Cells(EndR + 1, "Y") = "'" & Mid(NumOfLines(row + 1), 38, 3)
ElseIf InStr(Text, """giai7""") > 0 Then
Lotto.Cells(EndR + 1, "Z") = "'" & Mid(NumOfLines(row + 1), 10, 2)
Lotto.Cells(EndR + 1, "AA") = "'" & Mid(NumOfLines(row + 1), 23, 2)
Lotto.Cells(EndR + 1, "AB") = "'" & Mid(NumOfLines(row + 1), 36, 2)
Lotto.Cells(EndR + 1, "AC") = "'" & Mid(NumOfLines(row + 1), 49, 2)

Exit For
End If

End If
Next
End If
TextSource.Close
Lotto.Range("BE" & EndR + 1).Resize(, 9).Value = Sheet9.Range("B11").Resize(, 9).Value
DB.Range("A2").End(4).Offset(1).Resize(, 21).Value = Sheet9.Range("B11").Resize(, 21).Value
For Each Clls In Lotto.Range("C" & EndR + 1 & ":AC" & EndR + 1)
If Clls <> "" Then Clls.Offset(, 27) = "'" & Right(Clls, 2)
Next
Endrw = DB.[A2].End(4).row
DB.Range("K" & Endrw) = "'" & Sheet9.[L11]
DB.Range("M" & Endrw) = "'" & Right(DB.Range("K" & Endrw), 2)
DB.Range("R" & Endrw) = "'" & Bo(DB.Range("M" & Endrw))






If Lotto.Cells(EndR, "C") = "" Then
For rW = EndR To 2 Step -1
If Lotto.Cells(rW, "C") <> "" Then Exit For
Next
If Lotto.Cells(EndR + 1, "C") = Lotto.Cells(rW, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(rW, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
ElseIf Lotto.Cells(EndR + 1, "C") = Lotto.Cells(EndR, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(EndR, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
Next


Set objFSO = CreateObject("Scripting.FileSystemObject")
If FileExists("C:\Tamhoang\vn.txt") = True Then objFSO.DeleteFile ("C:\Tamhoang\vn.txt"), DeleteReadOnly
'If PathExists("C:\Tamhoang") = True Then objFSO.deletefolder ("C:\Tamhoang"), DeleteReadOnly
With Application
.ScreenUpdating = False
.DisplayFormulaBar = False
.CommandBars("Formatting").Visible = False
.CommandBars("Standard").Visible = False
.StatusBar = False
.DisplayStatusBar = True
End With

With ActiveWindow
'.DisplayHeadings = False
.DisplayOutline = False
'.DisplayHorizontalScrollBar = True
'.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = False
.Zoom = 100
Application.ScreenUpdating = False
End With




Sheet3.Visible = 2
Sheet4.Visible = 2
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",False)"
Application.DisplayFormulaBar = False
Sheet1.Select
SpeedOff




End Sub
Sub Auto_Close()
Set TP = Nothing
With Application
.ScreenUpdating = True
.DisplayFormulaBar = True
.CommandBars("Formatting").Visible = True
.CommandBars("Standard").Visible = True
.StatusBar = True
.DisplayStatusBar = True
End With

With ActiveWindow
.DisplayHeadings = True
.DisplayOutline = True
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = True
.Zoom = 100
Application.ScreenUpdating = True
End With
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",True)"
Application.DisplayFormulaBar = True
Application.Calculation = xlCalculationAutomatic


Sheet1.Cells.Clear
Sheet1.[A:AA].ColumnWidth = 9
End Sub
Function PathExists(pname) As Boolean
Dim x As String
On Error Resume Next


x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
End Function
Function FileExists(ByVal fname As String) As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
FileExists = fs.FileExists(fname)
End Function
Sub FixExcel()
With Application.ErrorCheckingOptions
.EvaluateToError = False
.TextDate = False
.NumberAsText = False
.InconsistentFormula = False
.OmittedCells = False
.UnlockedFormulaCells = False
'.ListLottoValidation = False
.InconsistentTableFormula = False
End With
End Sub


Xin chân thành cảm ơn các bác!
 
1. Bạn đổi
Mã:
Private Declare Function
thành
Mã:
Private Declare PtrSafe Function
2. Đổi Long thành PtrLong các biến bị lỗi
 
Upvote 0
Em sửa rồi k chạy được, bác xem giúp em báo lỗi tất. chắc lỗi hệ tất.
 
Upvote 0
Do tôi không có excel 64bit nên không test được, bạn thử sửa đoạn khai báo hàm của bạn thành đoạn dưới đây thử xem.
Mã:
#if VBA7 then
    Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias _
        "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As LongPtr) As LongPtr
#else
    Private Declare Function DeleteUrlCacheEntry Lib "wininet" 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
#end if
 
Upvote 0
Em có cái code chạy update kết quả nhờ các bác sửa cho phù hợp với Win 64bit và gán file excel chạy thử.

Code đây ạ:


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
Dim rW As Long
Dim TP As clsMain




Sub Auto_Open()


Set TP = New clsMain
TP.Create Application
'Exit Sub
SpeedOnK
Call FixExcel
If PathExists("C:\Tamhoang") = False Then MkDir ("C:\Tamhoang")
Application.DisplayFormulaBar = False
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",false)"
Dim Index As Long, n As Long, Col As Long, row As Long, Text As String
Dim Rng As Range, fso As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Set Rng = Sheets("Lotto").Range("A2")
Ngay = Lotto.[a10000].End(3) + 1


If Hour(Now) > 18 Then
Dy = Date
Else
Dy = Date - 1
End If




For Days = Ngay To Dy
EndR = Lotto.[a10000].End(3).row
Sheet9.Range("B10").Resize(, 21).Value = Lotto.Range("BE10000").End(3).Resize(, 21).Value


URL = "http://www.minhngoc.net.vn/ket-qua-xo-so/mien-bac/"
URL = URL & Day(Days) & "-" & Month(Days) & "-" & Year(Days) & ".html"
DownloadFile_hn = URLDownloadToFile(0, URL, "C:\Tamhoang\vn.txt", 0, 0)
FilesToImport = "C:\Tamhoang\vn.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextSource = fso_OpenTextFile("C:\Tamhoang\vn.txt", 1, , -2)
NumOfLines = Split(TextSource.ReadAll, vbCrLf)

If UBound(NumOfLines) > 0 Then
Lotto.Cells(EndR + 1, "A") = Days
If Weekday(Days) = 1 Then
Lotto.Cells(EndR + 1, "B") = "CN"
Else
Lotto.Cells(EndR + 1, "B") = "T" & Weekday(Days)
End If
'ReDim Res(1 To UBound(NumOfLines), 1 To 1)
For row = 1 To UBound(NumOfLines)
Text = NumOfLines(row)
If Text <> "" Then
If InStr(Text, """giaidb""") > 0 Then
Lotto.Cells(EndR + 1, "C").Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
Sheet9.[L11].Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai1""") > 0 Then
Lotto.Cells(EndR + 1, "D") = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai2""") > 0 Then
Lotto.Cells(EndR + 1, "E") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "F") = "'" & Mid(NumOfLines(row + 1), 26, 5)
ElseIf InStr(Text, """giai3""") > 0 Then
Lotto.Cells(EndR + 1, "G") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "H") = "'" & Mid(NumOfLines(row + 1), 26, 5)
Lotto.Cells(EndR + 1, "I") = "'" & Mid(NumOfLines(row + 1), 42, 5)
Lotto.Cells(EndR + 1, "J") = "'" & Mid(NumOfLines(row + 1), 58, 5)
Lotto.Cells(EndR + 1, "K") = "'" & Mid(NumOfLines(row + 1), 74, 5)
Lotto.Cells(EndR + 1, "L") = "'" & Mid(NumOfLines(row + 1), 90, 5)
ElseIf InStr(Text, """giai4""") > 0 Then
Lotto.Cells(EndR + 1, "M") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "N") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "O") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "P") = "'" & Mid(NumOfLines(row + 1), 55, 4)
ElseIf InStr(Text, """giai5""") > 0 Then
Lotto.Cells(EndR + 1, "Q") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "R") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "S") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "T") = "'" & Mid(NumOfLines(row + 1), 55, 4)
Lotto.Cells(EndR + 1, "U") = "'" & Mid(NumOfLines(row + 1), 70, 4)
Lotto.Cells(EndR + 1, "V") = "'" & Mid(NumOfLines(row + 1), 85, 4)
ElseIf InStr(Text, """giai6""") > 0 Then
Lotto.Cells(EndR + 1, "W") = "'" & Mid(NumOfLines(row + 1), 10, 3)
Lotto.Cells(EndR + 1, "X") = "'" & Mid(NumOfLines(row + 1), 24, 3)
Lotto.Cells(EndR + 1, "Y") = "'" & Mid(NumOfLines(row + 1), 38, 3)
ElseIf InStr(Text, """giai7""") > 0 Then
Lotto.Cells(EndR + 1, "Z") = "'" & Mid(NumOfLines(row + 1), 10, 2)
Lotto.Cells(EndR + 1, "AA") = "'" & Mid(NumOfLines(row + 1), 23, 2)
Lotto.Cells(EndR + 1, "AB") = "'" & Mid(NumOfLines(row + 1), 36, 2)
Lotto.Cells(EndR + 1, "AC") = "'" & Mid(NumOfLines(row + 1), 49, 2)

Exit For
End If

End If
Next
End If
TextSource.Close
Lotto.Range("BE" & EndR + 1).Resize(, 9).Value = Sheet9.Range("B11").Resize(, 9).Value
DB.Range("A2").End(4).Offset(1).Resize(, 21).Value = Sheet9.Range("B11").Resize(, 21).Value
For Each Clls In Lotto.Range("C" & EndR + 1 & ":AC" & EndR + 1)
If Clls <> "" Then Clls.Offset(, 27) = "'" & Right(Clls, 2)
Next
Endrw = DB.[A2].End(4).row
DB.Range("K" & Endrw) = "'" & Sheet9.[L11]
DB.Range("M" & Endrw) = "'" & Right(DB.Range("K" & Endrw), 2)
DB.Range("R" & Endrw) = "'" & Bo(DB.Range("M" & Endrw))






If Lotto.Cells(EndR, "C") = "" Then
For rW = EndR To 2 Step -1
If Lotto.Cells(rW, "C") <> "" Then Exit For
Next
If Lotto.Cells(EndR + 1, "C") = Lotto.Cells(rW, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(rW, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
ElseIf Lotto.Cells(EndR + 1, "C") = Lotto.Cells(EndR, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(EndR, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
Next


Set objFSO = CreateObject("Scripting.FileSystemObject")
If FileExists("C:\Tamhoang\vn.txt") = True Then objFSO.DeleteFile ("C:\Tamhoang\vn.txt"), DeleteReadOnly
'If PathExists("C:\Tamhoang") = True Then objFSO.deletefolder ("C:\Tamhoang"), DeleteReadOnly
With Application
.ScreenUpdating = False
.DisplayFormulaBar = False
.CommandBars("Formatting").Visible = False
.CommandBars("Standard").Visible = False
.StatusBar = False
.DisplayStatusBar = True
End With

With ActiveWindow
'.DisplayHeadings = False
.DisplayOutline = False
'.DisplayHorizontalScrollBar = True
'.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = False
.Zoom = 100
Application.ScreenUpdating = False
End With




Sheet3.Visible = 2
Sheet4.Visible = 2
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",False)"
Application.DisplayFormulaBar = False
Sheet1.Select
SpeedOff




End Sub
Sub Auto_Close()
Set TP = Nothing
With Application
.ScreenUpdating = True
.DisplayFormulaBar = True
.CommandBars("Formatting").Visible = True
.CommandBars("Standard").Visible = True
.StatusBar = True
.DisplayStatusBar = True
End With

With ActiveWindow
.DisplayHeadings = True
.DisplayOutline = True
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = True
.Zoom = 100
Application.ScreenUpdating = True
End With
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",True)"
Application.DisplayFormulaBar = True
Application.Calculation = xlCalculationAutomatic


Sheet1.Cells.Clear
Sheet1.[A:AA].ColumnWidth = 9
End Sub
Function PathExists(pname) As Boolean
Dim x As String
On Error Resume Next


x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
End Function
Function FileExists(ByVal fname As String) As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
FileExists = fs.FileExists(fname)
End Function
Sub FixExcel()
With Application.ErrorCheckingOptions
.EvaluateToError = False
.TextDate = False
.NumberAsText = False
.InconsistentFormula = False
.OmittedCells = False
.UnlockedFormulaCells = False
'.ListLottoValidation = False
.InconsistentTableFormula = False
End With
End Sub


Xin chân thành cảm ơn các bác!
Bác này còn trên đấy không cho em xin file Excel này với được không ạ. . .
 
Upvote 0
Bác này còn trên đấy không cho em xin file Excel này với được không ạ. . .
Suy nghĩ chút đi. 4 năm rồi, không biết người ở phương trời nào, một đi không trở lại cho tới bây giờ. Đưa chuột vào nick thì thấy: Nhìn thấy lần cuối: 12 Tháng năm 2017.
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom