我每天都会收到来自不同发件人的电子邮件，我的代码过去大约2分钟就能正常工作，遍历158封电子邮件。我通过在主题字段中查找文本来运行代码，因为每种电子邮件格式和布局都不同。 我无法从html电子邮件中读取文本，因此这些文本仅移至完整文件夹。 我的代码现已冻结，可以运行40分钟，但仍未完成。 即使我什么都没改变。 我还试图找到一种方法，用一个空格替换所有double，treble空格等。并将所有字符>替换为“” [无] 我的代码在下面
Option Explicit
Sub EmailText()
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim ObjOutlook As Object
Dim MyNamespace As Object
Dim i As Integer
Dim j, k As Long
Dim abody() As String
Dim strSubject As String
Set ObjOutlook = GetObject(, "Outlook.Application")
Set MyNamespace = ObjOutlook.GetNamespace("MAPI")
k = MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items.Count
For i = k To 1 Step -1
On Error GoTo vend
strSubject = MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Subject
If strSubject Like "*Aberdeen*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*Los Angeles*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*Seattle*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*Brisbane*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*Cairns*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*Bourne End*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*AirNav*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*CALGARY*" Then MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
If strSubject Like "*KPGD*" Then GoTo KPGD
If strSubject Like "*Victoria*" Then GoTo Victoria
If strSubject Like "*Blandford*" Then GoTo Blandford
If strSubject Like "*Macap*" Then GoTo Macapa
If strSubject Like "*Netherlands*" Then GoTo Netherlands
If strSubject Like "*WARRINGTON*" Then GoTo warrington
If strSubject Like "*Brentwood*" Then GoTo brentwood
If strSubject Like "*Chessington*" Then GoTo chessington
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete"): GoTo notfound
KPGD:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then
Sheet4.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet4.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet4.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(2)
Sheet4.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(1)
Sheet4.Cells(650000, 1).End(xlUp).Offset(0, 5) = Split(abody(j), " ")(6)
Sheet4.Cells(650000, 1).End(xlUp).Offset(0, 6) = strSubject
Sheet4.Cells(650000, 1).End(xlUp).Offset(0, 7) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
brentwood:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 63 Then
Sheet11.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet11.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet11.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(2)
Sheet11.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(1)
Sheet11.Cells(650000, 1).End(xlUp).Offset(0, 5) = Split(abody(j), " ")(6)
Sheet11.Cells(650000, 1).End(xlUp).Offset(0, 6) = strSubject
Sheet11.Cells(650000, 1).End(xlUp).Offset(0, 7) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
chessington:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then
Sheet13.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet13.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet13.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(2)
Sheet13.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(1)
Sheet13.Cells(650000, 1).End(xlUp).Offset(0, 4) = Split(abody(j), " ")(3)
Sheet13.Cells(650000, 1).End(xlUp).Offset(0, 5) = Split(abody(j), " ")(6)
Sheet13.Cells(650000, 1).End(xlUp).Offset(0, 6) = strSubject
Sheet13.Cells(650000, 1).End(xlUp).Offset(0, 7) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
warrington:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then
Sheet10.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet10.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(1)
Sheet10.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(2)
Sheet10.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(3)
Sheet10.Cells(650000, 1).End(xlUp).Offset(0, 4) = Split(abody(j), " ")(5)
Sheet10.Cells(650000, 1).End(xlUp).Offset(0, 5) = strSubject
Sheet10.Cells(650000, 1).End(xlUp).Offset(0, 6) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
Bourne:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 68 Then
Sheet3.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet3.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet3.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(1)
Sheet3.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(2)
Sheet3.Cells(650000, 1).End(xlUp).Offset(0, 4) = Split(abody(j), " ")(3)
Sheet3.Cells(650000, 1).End(xlUp).Offset(0, 5) = Split(abody(j), " ")(6)
Sheet3.Cells(650000, 1).End(xlUp).Offset(0, 6) = strSubject
Sheet3.Cells(650000, 1).End(xlUp).Offset(0, 7) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
Victoria:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 70 And Len(abody(j)) < 78 Then
Sheet8.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet8.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet8.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(2)
Sheet8.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(1)
Sheet8.Cells(650000, 1).End(xlUp).Offset(0, 4) = Split(abody(j), " ")(4)
Sheet8.Cells(650000, 1).End(xlUp).Offset(0, 5) = Split(abody(j), " ")(10)
Sheet8.Cells(650000, 1).End(xlUp).Offset(0, 6) = strSubject
Sheet8.Cells(650000, 1).End(xlUp).Offset(0, 7) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
Blandford:
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).BodyFormat = olFormatPlain
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 50 And Len(abody(j)) < 60 Then
Sheet7.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet7.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet7.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(1)
Sheet7.Cells(650000, 1).End(xlUp).Offset(0, 6) = strSubject
Sheet7.Cells(650000, 1).End(xlUp).Offset(0, 7) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
Macapa:
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).BodyFormat = olFormatPlain
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 90 And Len(abody(j)) < 160 Then
Sheet6.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(1)
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(3)
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 4) = Split(abody(j), " ")(2)
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 5) = Split(abody(j), " ")(4)
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 6) = Split(abody(j), " ")(5)
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 7) = strSubject
Sheet6.Cells(650000, 1).End(xlUp).Offset(0, 8) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
Netherlands:
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).BodyFormat = olFormatPlain
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
If Len(abody(j)) > 60 And Len(abody(j)) < 84 Then
Sheet2.Cells(650000, 1).End(xlUp).Offset(1, 0) = (abody(j))
Sheet2.Cells(650000, 1).End(xlUp).Offset(0, 1) = Split(abody(j), " ")(0)
Sheet2.Cells(650000, 1).End(xlUp).Offset(0, 2) = Split(abody(j), " ")(1)
Sheet2.Cells(650000, 1).End(xlUp).Offset(0, 3) = Split(abody(j), " ")(2)
Sheet2.Cells(650000, 1).End(xlUp).Offset(0, 4) = Split(abody(j), " ")(3)
Sheet2.Cells(650000, 1).End(xlUp).Offset(0, 5) = Split(abody(j), " ")(6)
Sheet2.Cells(650000, 1).End(xlUp).Offset(0, 6) = strSubject
Sheet2.Cells(650000, 1).End(xlUp).Offset(0, 7) = Len(abody(j))
End If
Next
MyNamespace.GetDefaultFolder(6).Folders("_Hex").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Hex_Complete")
GoTo comp
notfound:
comp:
Next
vend:
Set ObjOutlook = Nothing
Set MyNamespace = Nothing
End Sub