应该是无法使用XMLHTTP的方式登录，还是用老方法登录，在原代码的基础上优化拉取时间和更新表格时间
' === 增强稳定性的主抓取过程 ===
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandler
Dim obj
IEApp As Object, obj
IEDoc As Object, obj
IETable As Object
Dim objClip As Object, objSheet As Worksheet, objBuglist As Worksheet
Dim startTime As Double, retryCount As Integer
' 禁用Excel功能提升稳定性
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' 初始化设置
Set objSheet = Sheets("Bugzilla")
Set objBuglist = Sheets("account")
retryCount = 0
RetryPoint:
' === 关键改进1：增强
IE实例创建 ===
Set obj
IEApp = CreateStable
IEInstance()
If obj
IEApp Is Nothing Then
MsgBox "无法创建Internet Explorer实例", vbCritical
GoTo CleanExit
End If
With obj
IEApp
.Visible = True ' 调试时可见
' === 关键改进2：带重试机制的导航 ===
.Navigate "https://logincas.tp-link.com:8443/login?service=http://bugzilla.tp-link.com/"
If Not WaitForCompleteLoad(obj
IEApp, "登录页面", 30) Then
retryCount = retryCount + 1
If retryCount <= 3 Then
.Quit
Set obj
IEApp = Nothing
GoTo RetryPoint
Else
MsgBox "登录页面加载失败，请检查网络连接", vbExclamation
GoTo CleanExit
End If
End If
Set obj
IEDoc = .Document
' === 关键改进3：安全元素访问 ===
If Not SetElementValue(obj
IEDoc, "username", objBuglist.Range("A3").value) Then
LogError "无法设置用户名字段"
GoTo CleanExit
End If
If Not SetElementValue(obj
IEDoc, "password", objBuglist.Range("B3").value) Then
LogError "无法设置密码字段"
GoTo CleanExit
End If
' 提交登录表单
startTime = Timer
Do
On Error Resume Next
.Document.forms(0).submit
On Error GoTo ErrorHandler
If Timer - startTime > 15 Then Exit Do ' 15秒超时
DoEvents
Loop While .Busy Or .readyState <> 4
' === 关键改进4：增强登录等待 ===
If Not WaitForCompleteLoad(obj
IEApp, "登录后页面", 30) Then
MsgBox "登录过程超时", vbExclamation
GoTo CleanExit
End If
' 导航到目标页面
.Navigate objBuglist.Range("B1").value
If Not WaitForCompleteLoad(obj
IEApp, "目标页面", 300) Then
MsgBox "目标页面加载超时", vbExclamation
GoTo CleanExit
End If
' 更新文档对象引用
Set obj
IEDoc = .Document
' === 关键改进5：增强表格定位 ===
Set obj
IETable = FindBuglistTable(obj
IEDoc)
If obj
IETable Is Nothing Then
SaveHTMLForDebugging obj
IEDoc, "C:\Temp\bugzilla_debug.html"
MsgBox "未找到表格元素，已保存页面HTML用于调试", vbExclamation
GoTo CleanExit
End If
' 处理表格数据
ProcessBuglistTable obj
IETable, objSheet
End With
' 初始化schedule表
InitializeScheduleSheet
CleanExit:
SafeCleanup obj
IEApp
Set objClip = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Sheets("schedule").Activate
Exit Sub
ErrorHandler:
HandleAutomationError Err.Number, Err.Description
Resume CleanExit
End Sub
' === 关键增强函数 ===
' 创建稳定的
IE实例
Private Function CreateStable
IEInstance() As Object
On Error Resume Next
Dim
ieApp As Object
' 尝试连接到现有
IE实例
Set
ieApp = GetObject("InternetExplorer.Application")
If
ieApp Is Nothing Then
' 创建新实例
Set
ieApp = CreateObject("InternetExplorer.Application")
End If
' 配置
IE设置
If Not
ieApp Is Nothing Then
With
ieApp
.Silent = True ' 禁止脚本
错误提示
.Visible = True
.Navigate "about:blank" ' 初始化实例
Do While .Busy Or .readyState <> 4
DoEvents
Loop
End With
End If
Set CreateStable
IEInstance =
ieApp
End Function
' 增强的页面加载等待
Private Function WaitForCompleteLoad(
ie As Object, pageName As String, timeoutSeconds As Integer) As Boolean
Dim startTime As Double
startTime = Timer
Do While
ie.Busy Or
ie.readyState <> 4
DoEvents
If Timer - startTime > timeoutSeconds Then
WaitForCompleteLoad = False
Exit Function
End If
Loop
' 额外等待确保完全加载
Dim extraWait As Double
extraWait = Timer + 2 ' 额外等待2秒
Do While Timer < extraWait
DoEvents
Loop
WaitForCompleteLoad = True
End Function
' 安全设置元素值（返回是否成功）
Private Function SetElementValue(doc As Object, elementName As String, value As String) As Boolean
On Error Resume Next
Dim element As Object
' 尝试多种方式获取元素
Set element = doc.getElementById(elementName)
If element Is Nothing Then Set element = doc.getElementsByName(elementName)(0)
If element Is Nothing Then Set element = doc.querySelector("[name='" & elementName & "']")
If Not element Is Nothing Then
element.value = value
SetElementValue = True
Else
Debug.Print "未找到元素: " & elementName
SetElementValue = False
End If
End Function
' 查找表格的多种方法
Private Function FindBuglistTable(doc As Object) As Object
On Error Resume Next
Dim table As Object
' 尝试多种定位方式
Set table = doc.getElementById("buglist_table")
If table Is Nothing Then Set table = doc.getElementsByClassName("buglist")(0)
If table Is Nothing Then Set table = doc.querySelector("table.buglist")
If table Is Nothing Then Set table = doc.querySelector("table[id*='bug']")
If table Is Nothing Then
' 尝试查找第一个表格
Dim tables As Object
Set tables = doc.getElementsByTagName("table")
If tables.Length > 0 Then Set table = tables(0)
End If
Set FindBuglistTable = table
End Function
' 处理表格数据
Private Sub ProcessBuglistTable(table As Object, targetSheet As Worksheet)
On Error Resume Next
Dim objClip As Object, LocaleID As Long
Set objClip = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objClip.SetText table.outerHTML
objClip.PutInClipboard
targetSheet.Select
targetSheet.Range("A1").Select
' 语言设置处理
LocaleID = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Select Case LocaleID
Case 2052, 1028
targetSheet.PasteSpecial "Unicode 文本", xlPasteAll
Case Else
targetSheet.PasteSpecial "Unicode Text", xlPasteAll
End Select
' 清除剪贴板
objClip.SetText ""
objClip.PutInClipboard
Set objClip = Nothing
End Sub
' 初始化schedule表
Private Sub InitializeScheduleSheet()
On Error Resume Next
If Sheets("schedule").cells(2, 1) = "" Then
Sheets("Bugzilla").Range("A2:A" & Sheets("Bugzilla").cells(rows.Count, "A").End(xlUp).row).Copy Sheets("schedule").Range("A2")
AddHyperlinks 2
End If
End Sub
' 添加超链接
Private Sub AddHyperlinks(startRow As Long)
On Error Resume Next
Dim ws As Worksheet, lastRow As Long, i As Long
Set ws = Sheets("schedule")
lastRow = ws.cells(ws.rows.Count, "A").End(xlUp).row
For i = startRow To lastRow
If ws.Hyperlinks.Count >= i Then
ws.Hyperlinks(i).Address = "http://bugzilla.tp-link.com/" & ws.Hyperlinks(i).Address
End If
Next
End Sub
' 安全清理资源
Private Sub SafeCleanup(
ieApp As Object)
On Error Resume Next
If Not
ieApp Is Nothing Then
If Not
ieApp.Document Is Nothing Then
ieApp.Quit
End If
Set
ieApp = Nothing
End If
End Sub
'
错误处理程序
Private Sub HandleAutomationError(errNumber As Long, errDescription As String)
Dim errMsg As String
Select Case errNumber
Case -2147352319 ' 自动化
错误
errMsg = "
IE自动化
错误 (0x
80020101):" & vbCrLf & _
"可能原因:" & vbCrLf & _
"1.
IE安全设置阻止自动化" & vbCrLf & _
"2. 页面未完全加载" & vbCrLf & _
"3. 对象已被释放"
Case 462 ' 远程服务器不存在或不可用
errMsg = "远程服务器
错误 (462):" & vbCrLf & _
"
IE实例可能已关闭"
Case Else
errMsg = "
错误 " & errNumber & ": " & errDescription
End Select
' 添加解决方案提示
errMsg = errMsg & vbCrLf & vbCrLf & "解决方案:" & vbCrLf & _
"1. 检查
IE安全设置" & vbCrLf & _
"2. 增加页面加载等待时间" & vbCrLf & _
"3. 以管理员身份运行Excel"
MsgBox errMsg, vbCritical, "自动化
错误"
End Sub
' 日志记录
Private Sub LogError(message As String)
Debug.Print "[" & Now & "] ERROR: " & message
End Sub
' 保存HTML用于调试
Private Sub SaveHTMLForDebugging(doc As Object, filePath As String)
On Error Resume Next
Dim fso As Object, ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.CreateTextFile(filePath, True)
ts.Write doc.DocumentElement.outerHTML
ts.Close
End Sub
' ===== 辅助函数 =====
' 获取稳定的
IE实例
Private Function GetStable
IEInstance() As Object
On Error Resume Next
Dim
ieApp As Object
' 尝试连接到现有
IE实例
Set
ieApp = GetObject("InternetExplorer.Application")
If
ieApp Is Nothing Then
' 创建新实例
Set
ieApp = CreateObject("InternetExplorer.Application")
End If
' 配置
IE设置
If Not
ieApp Is Nothing Then
With
ieApp
.Silent = True ' 禁止脚本
错误提示
.Visible = True
.Navigate "about:blank" ' 初始化实例
Do While .Busy Or .readyState <> 4
DoEvents
Loop
End With
End If
Set GetStable
IEInstance =
ieApp
End Function
' ===== 优化后的数据同步过程 =====
Private Sub CommandButton3_Click()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Dim srcSheet As Worksheet, scheSheet As Worksheet
Set srcSheet = Sheets("Bugzilla")
Set scheSheet = Sheets("schedule")
' 检查源数据是否存在
If srcSheet.Range("A2") = "" Then
MsgBox "Bugzilla工作表没有数据可复制", vbExclamation
Exit Sub
End If
Dim lastRowSrc As Long, lastRowSche As Long
lastRowSrc = srcSheet.cells(srcSheet.rows.Count, "A").End(xlUp).row
lastRowSche = scheSheet.cells(scheSheet.rows.Count, "A").End(xlUp).row
' 如果schedule工作表为空，复制整个范围
If lastRowSche < 2 Then
srcSheet.Range("A2:A" & lastRowSrc).Copy scheSheet.Range("A2")
add_http 2
lastRowSche = scheSheet.cells(scheSheet.rows.Count, "A").End(xlUp).row
End If
' 同步数据
Dim i As Long, j As Long, matchFound As Boolean
For i = 2 To lastRowSrc
matchFound = False
For j = 2 To lastRowSche
If scheSheet.cells(j, 1).value = srcSheet.cells(i, 1).value Then
' 更新现有行
With scheSheet
.cells(j, 2).value = srcSheet.cells(i, 2).value
.cells(j, 3).value = srcSheet.cells(i, 3).value
.cells(j, 4).value = srcSheet.cells(i, 8).value
.cells(j, 5).value = srcSheet.cells(i, 9).value
.cells(j, 6).value = srcSheet.cells(i, 4).value
.cells(j, 7).value = srcSheet.cells(i, 5).value
.cells(j, 8).value = srcSheet.cells(i, 6).value
End With
matchFound = True
Exit For
End If
Next j
' 添加新行
If Not matchFound Then
lastRowSche = lastRowSche + 1
srcSheet.Range("A" & i).Copy scheSheet.Range("A" & lastRowSche)
With scheSheet
.cells(lastRowSche, 1).value = srcSheet.cells(i, 1).value
.cells(lastRowSche, 2).value = srcSheet.cells(i, 2).value
.cells(lastRowSche, 3).value = srcSheet.cells(i, 3).value
.cells(lastRowSche, 4).value = srcSheet.cells(i, 8).value
.cells(lastRowSche, 5).value = srcSheet.cells(i, 9).value
.cells(lastRowSche, 6).value = srcSheet.cells(i, 4).value
.cells(lastRowSche, 7).value = srcSheet.cells(i, 5).value
.cells(lastRowSche, 8).value = srcSheet.cells(i, 6).value
End With
End If
Next i
MsgBox "数据同步完成!", vbInformation
CleanExit:
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox "同步
错误: " & Err.Description, vbCritical
Resume CleanExit
End Sub
' ===== 保留原始功能 =====
Function add_http(i As Long)
On Error Resume Next
For x = i To Sheets("schedule").cells(rows.Count, "A").End(xlUp).row
Sheets("schedule").Hyperlinks(x).Address = "http://bugzilla.tp-link.com/" & Sheets("schedule").Hyperlinks(x).Address
Next
End Function
Private Sub CommandButton2_Click()
Dim OutLookObj As Outlook.Application
Dim MailObj As MailItem
Dim src, sche
src = "account"
sche = "schedule"
Set objSheet = Sheets(src)
Set objsche = Sheets(sche)
Send = ""
CC = ""
i = 6
Do Until objSheet.cells(i, 1) = ""
Send = Send & objSheet.cells(i, 1) & ";"
i = i + 1
Loop
i = 6
Do Until objSheet.cells(i, 2) = ""
CC = CC & objSheet.cells(i, 2) & ";"
i = i + 1
Loop
Set OutLookObj = New Outlook.Application '创建一个OutLook应用对象
Set MailObj = OutLookObj.CreateItem(olMailItem) '创建一个邮件对象Mailobj
Range("A1:H3").Select
With MailObj
.To = Send '收件人
.CC = CC '抄送
.subject = objSheet.Range("C6").value '标题
.HTMLBody = getVal(2)
.Display
.Send '发送
End With
Set OutLookObj = Nothing
Set MailObj = Nothing
End Sub
Function getVal(ByVal j As Integer) As String
Dim i As Integer
i = 1
k = 2
getVal = ""
getVal = "<table border=" & "'1'" & " style=" & "'border-right: black thin solid; border-top: black thin solid; border-left: black thin solid; border-bottom: black thin solid'" & ">"
getVal = getVal & "<tr>"
Do Until cells(1, i) = ""
getVal = getVal & "<td align=" & "'left'" & " height=" & "'57'" & " style=" & "'width: 250px; background-color: lightskyblue; font-size: 9pt;'" & " valign=" & "'top'" & ">"
getVal = getVal & cells(1, i) & "</td>"
i = i + 1
Loop
getVal = getVal & "</tr>"
i = 1
Do Until cells(k, 1) = ""
If Not Sheets("schedule").rows(k).Hidden Then
Do Until cells(k, i) = ""
getVal = getVal & "<td align=" & "'left'" & " style=" & "'width: 239px;background-color: white;'" & " valign=" & "'top'" & ">"
getVal = getVal & cells(k, i) & "</td>"
i = i + 1
Loop
End If
k = k + 1
i = 1
getVal = getVal & "</tr>"
Loop
getVal = getVal & "</tr></table>"
End Function
本文解决了Extjs在IE浏览器中使用autoLoad加载页面时出现的错误80020101问题，发现原因是HTML注释导致。通过调试定位到问题，并给出了解决方案。
扫一扫
1056
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
