如何在两个不同的单元格中导出电子邮件体？
如何在两个不同的单元格中导出电子邮件体？
提问于 2022-08-24 22:25:36
我希望按日期范围从特定文件夹导出电子邮件数据。
宏导出收到的日期和电子邮件的正文。
目的是搜索来自提取体的特定数据，并将它们显示在其他行中。
由于Excel在单元格中有32767字符的限制，一些电子邮件的正文没有被完全导出。
是否有一种方法可以将主体导出为两行而不是一行，以避免Excel限制？
对完成这一过程的其他建议表示赞赏。
Sub ImportEmails()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Outlook.Namespace
Dim IFolder As Outlook.MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set OutlookApp = New Outlook.Application
'Outlook connection
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set wb = ThisWorkbook
'Select the folder to export emails, depending on the user´s folder name you must change it
Set IFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Test")
Set ws = wb.Sheets("Imported")
i = 0
Application.ScreenUpdating = False
ws.Cells.Clear
'Create headers
ws.Range("A1").Value = "Date Time"
ws.Range("B1").Value = "Body"
'Condition to select the today date in case of blank and export the emails
If IsEmpty(Range("end_date").Value) = True Then
Range("end_date").Value = "=today()"
End If
'Exporting proccedure
For Each OutlookMail In IFolder.Items
'Date validation
If DateValue(OutlookMail.ReceivedTime) >= DateValue(Range("start_date")) And DateValue(OutlookMail.ReceivedTime) <= DateValue(Range("end_date")) Then
'Fill the worksheet cells with the emails
ws.Range("A2").Offset(i, 0).Value = OutlookMail.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = OutlookMail.Body
i = i + 1
End If
Next OutlookMail
Application.ScreenUpdating = True
Set IFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
LRimpr = LastRow(ws)
Set rng = ws.Range("A2:B" & LRimpr)
'Sort the columns by newest to oldest using the worksheet last row
With rng
.Sort Key1:=.Cells(1), Order1:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
End With
MsgBox "Emails are successfully imported", vbInformation, "Import complete"
ws.Activate
End Sub回答 2
Stack Overflow用户
回答已采纳
发布于 2022-08-25 16:57:00
如果您愿意在一行的多个单元格中导出电子邮件正文，那么请替换您的行。
ws.Range("B2").Offset(i, 0).Value = OutlookMail.Body使用
Const CHUNK_SIZE As Long = 32000
Dim segment As Long
segment = 0
Do While True
ws.Range("B2").Offset(i, segment).Value = Mid$(OutlookMail.Body, segment * CHUNK_SIZE + 1, CHUNK_SIZE)
segment = segment + 1
If segment * CHUNK_SIZE > Len(OutlookMail.Body) Then Exit Do
Loop根据您的需求调整CHUNK_SIZE的值..。它控制将放入每个单元格中的字符数，最后一个单元格具有“剩余”字符(如果主体的字符小于CHUNK_SIZE，则控制所有字符)。
Stack Overflow用户
发布于 2022-08-30 13:54:04
将身体分裂成列中的细胞。
Option Explicit
Sub ImportEmails_SplitBody_MultipleRows()
' Reference Microsoft Outlook nn.n Object Library
Dim OutlookApp As Outlook.Application
Dim iFolder As Outlook.Folder
Dim iFolderItems As Outlook.Items
Dim j As Long
Dim OutlookItem As Object
Dim lenBody As Long
Dim maxLen As Long
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set OutlookApp = New Outlook.Application
' Select folder
Set iFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test")
' Sort items
Set iFolderItems = iFolder.Items
iFolderItems.Sort "[ReceivedTime]", True
Set wb = ThisWorkbook
Set ws = wb.Sheets("Imported")
i = 0
' Application is Excel. No impact on Outlook
'Application.ScreenUpdating = False
ws.Cells.Clear
'Create headers
ws.Range("A1").Value = "Date Time"
ws.Range("B1").Value = "Body"
'Condition to select today's date in case of blank
If IsEmpty(Range("end_date").Value) = True Then
Range("end_date").Value = "=today()"
End If
'Debug.Print Range("start_date")
'Debug.Print Range("end_date")
'Exporting procedure
maxLen = 32767
'Debug.Print " maxLen: " & maxLen
For j = 1 To iFolderItems.Count
'Date validation
If iFolderItems(j).Class = olMail Then
Set OutlookItem = iFolderItems(j)
'Debug.Print OutlookItem.Subject
If DateValue(OutlookItem.ReceivedTime) >= DateValue(Range("start_date")) And _
DateValue(OutlookItem.ReceivedTime) <= DateValue(Range("end_date")) Then
lenBody = Len(OutlookItem.Body)
Dim txt As String
txt = OutlookItem.Body
Dim lenTxt As Long
lenTxt = Len(txt)
Do Until lenTxt = 0
'Fill the worksheet cells with the emails
'Debug.Print " Len(txt): " & Len(txt)
If lenTxt > maxLen Then
ws.Range("A2").Offset(i, 0).Value = OutlookItem.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = Left(txt, maxLen)
txt = Right(txt, Len(txt) - maxLen)
Else
ws.Range("A2").Offset(i, 0).Value = OutlookItem.ReceivedTime
ws.Range("B2").Offset(i, 0).Value = txt
txt = ""
End If
i = i + 1
lenTxt = Len(txt)
Loop
Set OutlookItem = Nothing
End If
End If
Next
Application.ScreenUpdating = True
Set iFolder = Nothing
Set iFolderItems = Nothing
Set OutlookApp = Nothing
MsgBox "Emails are successfully imported", vbInformation, "Import complete"
ws.Activate
End Sub页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/73480087
复制相关文章
相似问题
腾讯云开发者
