Outlook Email HTML Code Extraction_getting error as out of memory & runtime error 7

[uday]

Hi,

I am trying to extract HTML code from Outlook emails one by one, but the HTML code seems to be huge for some emails, and excel has cell character limitation of 32,767. So, I have tried with different logic to print HTML doe in different chunk for the same email, if the size is exceeds 32,767 then it will be printed in different column for the same email.

I have attached the excel file and the code. please help.

THE HTML EXTRACTION CODE IN OLD MODULE.

---

Public Sub ExtractHTMLFromEmails()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Object
    Dim ws As Worksheet
    Dim htmlContent As String
    Dim row As Long
    Dim col As Long
    Dim chunkSize As Long
    Dim remainingText As String
    Dim i As Integer
    Dim conversationIDs As Collection
    Dim conversationID As String
    
    ' Initialize Outlook
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.PickFolder
    Set ws = ThisWorkbook.ActiveSheet
    
    ' Create a collection to store unique conversation IDs
    Set conversationIDs = New Collection
    
    ' Add headers
    row = 1
    ws.Cells(row, 1) = "Subject"
    ws.Cells(row, 2) = "Conversation ID" ' Header for Conversation ID
    For i = 1 To 50
        ws.Cells(row, i + 2) = "HTML Part " & i ' Shift headers by one
    Next i
    row = row + 1
    
    chunkSize = 32767
    
    For Each olItem In olFolder.Items
        If TypeName(olItem) = "MailItem" Then
            conversationID = olItem.conversationID
            
            ' Check if conversation ID is already processed
            On Error Resume Next
            conversationIDs.Add conversationID, conversationID ' Use Conversation ID as key
            If Err.Number <> 0 Then
                ' Conversation ID is a duplicate, skip to the next item
                Err.Clear
                GoTo NextEmail
            End If
            On Error GoTo 0
            
            htmlContent = olItem.HTMLBody
            ws.Cells(row, 1) = olItem.Subject
            ws.Cells(row, 2) = conversationID ' Add Conversation ID
            
            ' Handle HTML content distribution
            remainingText = htmlContent
            col = 3 ' Start from column C
            
            Do While Len(remainingText) > 0 And col <= 52 ' C to AZ (50 columns)
                If Len(remainingText) > chunkSize Then
                    ws.Cells(row, col) = Left(remainingText, chunkSize)
                    remainingText = Mid(remainingText, chunkSize + 1)
                Else
                    ws.Cells(row, col) = remainingText
                    remainingText = ""
                End If
                col = col + 1
            Loop
            
            ' Add warning if content exceeds 50 parts
            If Len(remainingText) > 0 Then
                ws.Cells(row, 53) = "WARNING: Additional content truncated"
            End If
            
            row = row + 1
        End If
NextEmail:
    Next olItem
    
    ' Cleanup
    Set olItem = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    Set conversationIDs = Nothing
    
    ' Format the worksheet
    ws.Columns.AutoFit
    
    ' Add color to headers
    ws.Range(ws.Cells(1, 1), ws.Cells(1, 53)).Interior.Color = RGB(200, 220, 250)
    ws.Range(ws.Cells(1, 1), ws.Cells(1, 53)).Font.Bold = True
    
    MsgBox "HTML extraction completed successfully!", vbInformation
End Sub