Có ai giúp giùm em cái này không ạ. file excel của em khi chạy marco vba này luôn mặc định là trình duyệt IE. em muốn chuyển sang mở bằng Chrome hoặc Firefox nhưng em k biết về code. đoạn code trong file module như sau:
Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim URL As String
Dim BVISIBLE As Boolean
Dim DELAY As Long
Dim NUM As String
Dim SHUTD As Integer
Dim SES_col As Integer
Const TYPE_CLICK As String = "CLICK"
Const TYPE_SET As String = "SET"
Const TYPE_URL As String = "URL"
Const TYPE_GET As String = "GETDATA"
Const TYPE_GETLINK As String = "GETLINK"
Const TYPE_SEND As String = "SEND"
Const TYPE_SEARCH1 As String = "SEARCHLINK"
Const TYPE_FORCE As String = "FORCE" 'right type
Sub reg_web()
Dim sh As Variant
Dim i, j As Long
Dim r1, r2, r3 As Variant
Dim rowfrom, colfrom As Long
Set sh = ThisWorkbook.ActiveSheet
If Not init(sh) Then
Exit Sub
End If
colfrom = 0
NUM = 0
ReDim r1(NUM)
ReDim r2(NUM)
ReDim r3(NUM)
For j = 1 To 65535
If sh.Rows(2).Cells(j).value = "" And sh.Rows(2).Cells(j + 1).value = "" _
And sh.Rows(2).Cells(j + 2).value = "" Then
Exit For
End If
NUM = NUM + 1
ReDim Preserve r1(1 To NUM)
ReDim Preserve r2(1 To NUM)
ReDim Preserve r3(1 To NUM)
r1(j) = Trim(CStr(sh.Rows(2).Cells(j).value))
r2(j) = Trim(CStr(sh.Rows(3).Cells(j).value))
If colfrom = 0 And _
StrComp(Left(sh.Rows(2).Cells(j).value, Len(TYPE_SET)), _
TYPE_SET, vbTextCompare) = 0 Then 'col for available of data,
colfrom = j
End If
Next j
rowfrom = Application.Max(sh.Cells(1, SES_col), 4) '4 is start
For i = rowfrom To 65535
sh.Cells(1, SES_col) = i
If (sh.Cells(i, colfrom) = "" _
And sh.Cells(i + 1, colfrom) = "" _
And sh.Cells(i + 2, colfrom) = "") Then
Exit For
ThisWorkbook.Save
End If
If i Mod 10 = 0 Then
ThisWorkbook.Save
End If
If sh.Cells(i, colfrom) <> "" Then
For j = 1 To NUM
r3(j) = Trim(CStr(sh.Rows(i).Cells(j).value))
Next j
sh.Cells(i, NUM + 1).value = "K" & reg(URL, r1, r2, r3, NUM)
End If
'write output and all infor again to excel
For j = 1 To NUM
sh.Rows(i).Cells(j).value = Format(r3(j))
sh.Rows(i).Cells(j).Font.Color = RGB(0, 0, 0)
If Mid(sh.Cells(i, NUM + 1).value, j, 1) = 1 Then
Else
sh.Rows(i).Cells(j).Font.Color = RGB(255, 0, 0)
End If
Next j
Next i
ThisWorkbook.Save
If SHUTD > 0 Then
Shell ("cmd /c shutdown -s -f -t 1")
End If
End Sub
Private Function reg(ByVal lurl As String, ByRef setref As Variant, ByRef setxpath As Variant, ByRef setvalue As Variant, ByVal n As Integer) As String
Dim htmldoc, oIE1Doc As HTMLDocument
Dim MyBrowser, oIE1 As InternetExplorer
Dim MyHTML_Element, oIE1Element As IHTMLElement
Dim i As Long
Dim ret, a As String
Dim out As String
Dim b As String
Application.DisplayAlerts = False
wait_time (3)
b = ShellRun("taskkill /f /im iexplore.exe")
b = ShellRun("taskkill /f /im MicrosoftEdge.exe")
b = ShellRun("taskkill /f /im ielowutil.exe")
Set MyBrowser = New InternetExplorer
MyBrowser.Visible = BVISIBLE
ret = String(n, "0")
For i = 1 To n
If setref(i) <> "" Then a = "0" Else: a = "1"
If StrComp(Left(setref(i), Len(TYPE_URL)), TYPE_URL, vbTextCompare) = 0 Then
lurl = URL
If StrComp(Left(setvalue(i), 4), "html", vbTextCompare) = 0 _
And setvalue(i) <> lurl Then 'URL ,reload page
lurl = setref(i)
End If
MyBrowser.navigate lurl
Loading MyBrowser, 1
Set htmldoc = MyBrowser.document
a = "1"
End If
If StrComp(Left(setref(i), Len(TYPE_CLICK)), TYPE_CLICK, vbTextCompare) = 0 Then 'if a button -> click
If ClickXpath(htmldoc, setxpath(i)) Then
Loading MyBrowser, 3
a = "1"
End If
End If
If StrComp(Left(setref(i), Len(TYPE_SEND)), TYPE_SEND, vbTextCompare) = 0 Then 'if a send key
If SendKeyhtml(MyBrowser, BVISIBLE, htmldoc, setxpath(i)) Then
Loading MyBrowser, 3
a = "1"
End If
End If
If StrComp(Left(setref(i), Len(TYPE_SET)), TYPE_SET, vbTextCompare) = 0 _
And setvalue(i) <> "" And setxpath(i) <> "" Then 'Set Object
If InputValueXpath(htmldoc, setxpath(i), setvalue(i)) Then
Loading MyBrowser, 1
a = "1"
Else
End If
End If
'output
If StrComp(Left(setref(i), Len(TYPE_GET)), TYPE_GET, vbTextCompare) = 0 _
And setxpath(i) <> "" Then 'Get Object
out = ""
If GetValueXpath(htmldoc, setxpath(i), out) Then
Loading MyBrowser, 1
a = "1"
Else
End If
setvalue(i) = out
End If
If StrComp(Left(setref(i), Len(TYPE_GETLINK)), TYPE_GETLINK, vbTextCompare) = 0 _
And setxpath(i) <> "" Then 'Get Object
out = ""
If GetLinkXpath(htmldoc, setxpath(i), out) Then
Loading MyBrowser, 1
a = "1"
Else
End If
setvalue(i) = out
End If
If StrComp(Left(setref(i), Len(TYPE_SEARCH1)), TYPE_SEARCH1, vbTextCompare) = 0 _
And setxpath(i) <> "" Then 'Get Search Object
out = ""
If SearchLink(htmldoc, setxpath(i), out) Then
Loading MyBrowser, 0
a = "1"
Else
End If
setvalue(i) = out
End If
'Check to continous or not
ret = Left(ret, i - 1) & a & Mid(ret, i + 1)
If StrComp(Right(setref(i), Len(TYPE_FORCE)), TYPE_FORCE, vbTextCompare) = 0 _
Or a <> "0" Then
Else
Exit For
End If
Next i
reg = ret
Set htmldoc = Nothing
MyBrowser.Stop
MyBrowser.Quit
Set MyBrowser = Nothing
Delete_IE_Cache
reg = ret
End Function
Private Function init(ByVal sh As Variant) As Boolean
Dim key As String
init = True
URL = sh.Cells(1, Application.Match("URL:", sh.Range("A1:AA1"), False) + 1)
BVISIBLE = False
If StrComp(sh.Cells(1, Application.Match("Visible:", sh.Range("A1:AA1"), False) + 1), "1", vbTextCompare) = 0 Then
BVISIBLE = True
End If
DELAY = Int(sh.Cells(1, Application.Match("DELAY:", sh.Range("A1:AA1"), False) + 1))
SHUTD = Int(sh.Cells(1, Application.Match("SHUTDOWN:", sh.Range("A1:AA1"), False) + 1))
SES_col = Application.Match("SESSION:", sh.Range("A1:AA1"), False) + 1
'Genuine
key = sh.Cells(1, Application.Match("ACTIVE:", sh.Range("A1:AA1"), False) + 1)
key = Main_Key_Check(sh, key)
sh.Cells(1, Application.Match("ACTIVE:", sh.Range("A1:AA1"), False) + 1) = key
'About:
sh.Cells(1, 1) = "DonateNEO:"
sh.Cells(1, Application.Match("DonateNEO:", sh.Range("A1:AA1"), False) + 1) = "AcdsTrQtcUu1hXqpdW5bwvgZSSpeeT12r8"
End Function
'<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>'
Private Sub Delete_IE_Cache()
Dim a As String
'using get output to wait until cmd end
a = ShellRun("taskkill /f /im iexplore.exe")
a = ShellRun("taskkill /f /im MicrosoftEdge.exe")
a = ShellRun("taskkill /f /im ielowutil.exe")
a = ShellRun("RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 255")
a = ShellRun("RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 32")
a = ShellRun("RunDll32.exe InetCpl.cpl, ClearMyTracksByProcess 4351")
'MicrosoftEdge.exe
a = ShellRun("cmd /c del /s /f /q C:\Users\Administrator\AppData\Local\Microsoft\Windows\INetCache\*")
a = ShellRun("cmd /c del /s /f /q C:\Users\Administrator\AppData\Local\Microsoft\Windows\INetCookies\*")
a = ShellRun("cmd /c del /s /f /q C:\Users\Administrator\AppData\Local\Microsoft\Windows\WebCache\*")
'C:\Users\Administrator\AppData\Local\Microsoft\Windows\INetCookies
wait_time (1)
End Sub
Private Function ShellRun(sCmd As String) As String
'Run a shell command, returning the output as a string
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
'run command
Dim oExec As Object
Dim oOutput As Object
Set oExec = oShell.Exec(sCmd)
Set oOutput = oExec.StdOut
'handle the results as they are written to and read from the StdOut object
Dim s As String
Dim sLine As String
While Not oOutput.AtEndOfStream
sLine = oOutput.ReadLine
If sLine <> "" Then s = s & sLine & vbCrLf
Wend
ShellRun = s
End Function
Public Sub Loading(ByVal MyBrowser As InternetExplorer, Optional waitt As Integer = 0)
Const READYSTATE_COMPLETE As Integer = 4
Do
DoEvents
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE And MyBrowser.Busy = False 'And MyBrowser.statusText = "Done" 'And MyBrowser.document.readyState = "complete"
wait_time (waitt + DELAY)
End Sub
Private Sub wait_time(ByVal a As Integer)
Dim time1, time2
If a > 59 Then
a = 59
End If
time1 = Now
time2 = Now + TimeValue("0:00:" & Format(a, "00"))
Do Until time1 >= time2
DoEvents
time1 = Now()
Loop
End Sub
