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

Liên hệ QC

Người dùng đang xem chủ đề này

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