将 ID 添加到行并使用相同的 ID 更新回复行？
Add ID To Row And Update Reply Rows With Same ID?
希望你一切都好。我制作了一个电子邮件报告工具，但我真的很苦恼。每行都有一个 ID 号（从 1 开始到 G 列的第 2 行）。当收到回复时，我需要回复有其原始 ID。尝试使用 entryid 但是当回复电子邮件返回时这个值会改变所以它不是很好。
下面是我的代码；
Option Explicit
Const fPath As String = "C:\Users\neo_s_000\Desktop\Emails\" 'The path to save the messages
Const sfName As String = "C:\Users\neo_s_000\Desktop\Message Log.xlsx"
Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
If FileExists(sfName) Then
Set xlBook = Workbooks.Open(sfName)
Set xlSheet = xlBook.Sheets(1)
Else
Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
.Cells(1, 7) = "ID"
End With
xlBook.SaveAs sfName
End If
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
.Cells(1, 7) = "ID"
CreateFolders fPath
Set olNS = olApp.GetNamespace("MAPI")
olNS.Logon
Set olFolder = olNS.PickFolder
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
.Cells(NextRow, 6) = olItem.Body
End If
Next olItem
MsgBox "Outlook Mails Extracted to Excel"
End With
xlBook.Close SaveChanges:=True
lbl_Exit:
Set olApp = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Function SaveMessage(olItem As Object) As String
Dim Fname As String
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For iPath = 1 To UBound(vPath)
strPath = strPath & vPath(iPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next iPath
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
有什么想法吗？
好的，很抱歉这么久才给您答复。我会尽量给你 运行 我在评论中所说的内容。
早绑定与晚绑定
在 OOP all of the objects we interact with have a Type (aka Class).
我们通过访问与它们关联的成员来使用这些对象，这些成员由它们的类型定义。
为了访问这些成员，运行time 环境需要知道类型是什么。
我们可以在执行代码之前（因此在编译时）告诉运行时间环境类型是什么，这称为早期绑定。或者，我们可以让 RTE 在执行时（因此在 运行 时间）计算出来，这称为后期绑定。
在编译时定义类型是通过将对象声明为预期类型来完成的。例如：
Dim xlApp as Excel.Application
在 运行 时定义它是通过将对象声明为基类型然后将其转换为继承基类型的另一种类型来完成的。最常见的是使用 Object 的基类型，因为所有类型都派生自 Object 类型。 （或者 Variant 在 VBA 中很常见，因为它可以表示任何数据类型）。例如：
Dim xlApp as Object
使用早期绑定对您（程序员）的主要优势是 Intellisense，但使用早期绑定还有很多优势，例如程序优化、调试、错误捕获等。
您可以阅读有关这些概念的更多信息 here，但仅此而已。
类型库
为了将对象声明为我们想要的类型，我们需要确保该类型对 IDE 可用。类型包含在库（通常是 .DLL 文件）中，我们可以添加对这些库的引用以使用其中定义的类型。在 VBA 中，我们通过 "adding a reference" 执行此操作，可从 Tools 菜单中获得。
所有这些都在我 link 昨天写的 reference 中进行了解释。
实施早期绑定：
要使用早期绑定，请按照上面 link 中的描述设置引用，然后更改变量声明以从 Outlook 命名空间中调出适当的类型，如下所示：
Dim olApp As Outlook.Application
Dim olFolder As Outlook.Folder
Dim olNS As Outlook.Namespace
Dim xlBook As Workbook 'This is the same as Excel.Workbook... Excel is the default namespace and a reference is automatically included in your VBA project when you enter VBA from Excel (e.g. using AL+F11 or macro-recorder)
Dim xlSheet As Worksheet 'Same as Excel.Worksheet...
Dim NextRow As Long
Dim i As Long
Dim olItem As Object 'Here we have to use late binding because the return from Folder.Items collection can contain objects of multiple types (e.g. MailItem, MeetingItem, AppointmentItem, etc.)
实现 ID 字段：
就填充 ID 字段而言，您可能可以使用 Conversation.ConversationID 属性 获得所需内容。
例如
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
.Cells(NextRow, 6) = olItem.Body
Dim Convo as Outlook.Conversation
Set Convo = olItem.GetConversation()
.Cells(NextRow, 7) = convo.conversationID
End If
Next olItem
希望你一切都好。我制作了一个电子邮件报告工具，但我真的很苦恼。每行都有一个 ID 号（从 1 开始到 G 列的第 2 行）。当收到回复时，我需要回复有其原始 ID。尝试使用 entryid 但是当回复电子邮件返回时这个值会改变所以它不是很好。
下面是我的代码；
Option Explicit
Const fPath As String = "C:\Users\neo_s_000\Desktop\Emails\" 'The path to save the messages
Const sfName As String = "C:\Users\neo_s_000\Desktop\Message Log.xlsx"
Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
If FileExists(sfName) Then
Set xlBook = Workbooks.Open(sfName)
Set xlSheet = xlBook.Sheets(1)
Else
Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
.Cells(1, 7) = "ID"
End With
xlBook.SaveAs sfName
End If
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
.Cells(1, 7) = "ID"
CreateFolders fPath
Set olNS = olApp.GetNamespace("MAPI")
olNS.Logon
Set olFolder = olNS.PickFolder
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
.Cells(NextRow, 6) = olItem.Body
End If
Next olItem
MsgBox "Outlook Mails Extracted to Excel"
End With
xlBook.Close SaveChanges:=True
lbl_Exit:
Set olApp = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Function SaveMessage(olItem As Object) As String
Dim Fname As String
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For iPath = 1 To UBound(vPath)
strPath = strPath & vPath(iPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next iPath
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
有什么想法吗？
好的，很抱歉这么久才给您答复。我会尽量给你 运行 我在评论中所说的内容。
早绑定与晚绑定
在 OOP all of the objects we interact with have a Type (aka Class).
我们通过访问与它们关联的成员来使用这些对象，这些成员由它们的类型定义。
为了访问这些成员，运行time 环境需要知道类型是什么。
我们可以在执行代码之前（因此在编译时）告诉运行时间环境类型是什么，这称为早期绑定。或者，我们可以让 RTE 在执行时（因此在 运行 时间）计算出来，这称为后期绑定。
在编译时定义类型是通过将对象声明为预期类型来完成的。例如：
Dim xlApp as Excel.Application
在 运行 时定义它是通过将对象声明为基类型然后将其转换为继承基类型的另一种类型来完成的。最常见的是使用 Object 的基类型，因为所有类型都派生自 Object 类型。 （或者 Variant 在 VBA 中很常见，因为它可以表示任何数据类型）。例如：
Dim xlApp as Object
使用早期绑定对您（程序员）的主要优势是 Intellisense，但使用早期绑定还有很多优势，例如程序优化、调试、错误捕获等。
您可以阅读有关这些概念的更多信息 here，但仅此而已。
类型库
为了将对象声明为我们想要的类型，我们需要确保该类型对 IDE 可用。类型包含在库（通常是 .DLL 文件）中，我们可以添加对这些库的引用以使用其中定义的类型。在 VBA 中，我们通过 "adding a reference" 执行此操作，可从 Tools 菜单中获得。
所有这些都在我 link 昨天写的 reference 中进行了解释。
实施早期绑定：
要使用早期绑定，请按照上面 link 中的描述设置引用，然后更改变量声明以从 Outlook 命名空间中调出适当的类型，如下所示：
Dim olApp As Outlook.Application
Dim olFolder As Outlook.Folder
Dim olNS As Outlook.Namespace
Dim xlBook As Workbook 'This is the same as Excel.Workbook... Excel is the default namespace and a reference is automatically included in your VBA project when you enter VBA from Excel (e.g. using AL+F11 or macro-recorder)
Dim xlSheet As Worksheet 'Same as Excel.Worksheet...
Dim NextRow As Long
Dim i As Long
Dim olItem As Object 'Here we have to use late binding because the return from Folder.Items collection can contain objects of multiple types (e.g. MailItem, MeetingItem, AppointmentItem, etc.)
实现 ID 字段：
就填充 ID 字段而言，您可能可以使用 Conversation.ConversationID 属性 获得所需内容。
例如
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
.Cells(NextRow, 6) = olItem.Body
Dim Convo as Outlook.Conversation
Set Convo = olItem.GetConversation()
.Cells(NextRow, 7) = convo.conversationID
End If
Next olItem