Data getting truncated on xls to htm conversion

[jpotucek]

OK. Someone else wrote this code and they no longer work for the Company.. I'm JUST learning VBA (I'm not very good yet) and I'm trying to troubleshoot this code... please help !

This Macro (very bottom of the post) is run from Outlook and what it is SUPPOSED to do prompt the User for a Range of Dates and then asks them to make an email folder selection.. that part works fine. the Macro then reads all the emails in the folder and the ones which match the date range criteria get dumped into an xls file with the Columns Subject, Sender, ReceivedDate and MessageBody. The xls file is then converted to a .htm file and that is where the problem is (I think).


The MessageBody column is getting truncated and I'm losing alot of data. When the Macro is complete and I have my .htm output file,
I have to manually edit the .htm file to reformat the cells and pull in order to pull in all of the 'missing data' into the MessageBody colum:

'xls VBA code to format MessageBody Column'

    Columns("D:D").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Cells.EntireRow.AutoFit
    Range("A1").Select
    ActiveWorkbook.SaveAs Filename:= _
        "\\OLTV.LOCAL\DFSShares\Stamford-Home\user\Book1.xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", 
ReadOnlyRecommended:=False _
        , CreateBackup:=False
End Sub

Below is my VBA Code that the user runs in Outlook. Is there a way to get it to properly format the MessageBody Column so that I get all my data and I don't have to manually edit each .htm file?????? Can anyone help me out???????

'Outlook Macro Code'

Dim strMessageBody As String 
Dim strAttachment As String 
Dim dtStartDate As Date 
Dim dtEndDate As Date 
Dim globalRowCount As Long 
  
Dim xlApp As Excel.Application 
Dim xlBook As Excel.Workbook 
Dim xlSheet As Excel.Worksheet 
  
Option Explicit 
  
Sub Export() 
    
   Dim olApp As Outlook.Application 
   Dim olSession As Outlook.NameSpace 
   Dim olStartFolder As Outlook.MAPIFolder 
   Dim olDestFolder As Outlook.MAPIFolder 
   Dim strprompt As String 
   Dim recipient As String 
   Dim localRowCount As Integer 
    
    
   Set xlApp = CreateObject("Excel.Application") 
    
   'Initialize count of folders searched 
   globalRowCount = 1 
    
   ' Get a reference to the Outlook application and session. 
   Set olApp = Application 
   Set olSession = olApp.GetNamespace("MAPI") 
  
   ' Allow the user to input the start date 
   strprompt = "Enter the start date to search from:" 
   dtStartDate = InputBox(strprompt, "Start Date", Now() - 7) 
  
   ' Allow the user to input the end date 
   strprompt = "Enter the end date to search to:" 
   dtEndDate = InputBox(strprompt, "End Date", Now()) 
    
'   UserForm1.Show 
    
    
   If (IsNull(dtStartDate) <> 1) And (IsNull(dtEndDate) <> 1) Then 
  
      ' Allow the user to pick the folder in which to start the search. 
      MsgBox ("Pick the source folder (Feedback)") 
      Set olStartFolder = olSession.PickFolder 
      
      ' Check to make sure user didn't cancel PickFolder dialog. 
      If Not (olStartFolder Is Nothing) Then 
         ' Start the search process. 
         ProcessFolder olStartFolder 
         MsgBox CStr(globalRowCount) & " messages were found." 
      End If 
    
   xlApp.Quit 
  
'   strprompt = "Enter the recipient of the .html attachment in xxx@xxx.xxx 
format: " 
'   recipient = InputBox(strprompt, "Recipient's email", "dba@xxxx.com") 
  
'   DTSMailer strMessageBody, strAttachment 
'   DTSMailer commented out b/c no DTS package reference available on 
Geeta's machine. 
    
'   MsgBox "Email sent to " & recipient 
   MsgBox "Process is complete.  Check K:\feedback\htm\ for available files." 
  
   End If 
End Sub 
  
Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder) 
  
Dim i As Long 
Dim ValidEmails As Long 
ValidEmails = 0 
  
For i = CurrentFolder.Items.Count To 1 Step -1 
   If ((CurrentFolder.Items(i).ReceivedTime >= dtStartDate) And 
(CurrentFolder.Items(i).ReceivedTime < dtEndDate)) Then 
   ValidEmails = ValidEmails + 1 
   End If 
Next 
  
If CurrentFolder.Items.Count >= 1 And ValidEmails >= 1 Then 
    
   Dim localRowCount As Integer 
   Dim xlName As String 
      
   Set xlBook = xlApp.Workbooks.Add 
   Set xlSheet = xlBook.Worksheets(1) 
      
   localRowCount = 1 
   xlName = CStr(Format(dtStartDate, "MMDDYYYY")) & "_" & CurrentFolder.Name 
& "_feedback" 
  
   xlSheet.Cells(localRowCount, 1) = "SUBJECT" 
   xlSheet.Cells(localRowCount, 2) = "SENDER" 
   xlSheet.Cells(localRowCount, 3) = "RECEIVED DATE" 
   xlSheet.Cells(localRowCount, 4) = "MESSAGE BODY" 
  
    
   ' Late bind this object variable, 
   ' since it could be various item types 
   Dim olTempItem As Object 
   Dim olNewFolder As Outlook.MAPIFolder 
  

   ' Loop through the items in the current folder. 
   ' Looping through backwards in case items are to be deleted, 
   ' as this is the proper way to delete items in a collection. 
       For i = CurrentFolder.Items.Count To 1 Step -1 
    
          Set olTempItem = CurrentFolder.Items(i) 
    
          ' Check to see if a match is found 
          If ((olTempItem.ReceivedTime >= dtStartDate) And 
(olTempItem.ReceivedTime < dtEndDate)) Then 
            localRowCount = localRowCount + 1 
            globalRowCount = globalRowCount + 1 
            xlSheet.Cells(localRowCount, 1) = olTempItem.Subject 
            xlSheet.Cells(localRowCount, 2) = olTempItem.SenderEmailAddress 
            xlSheet.Cells(localRowCount, 3) = 
CStr(Format(olTempItem.ReceivedTime, "MM/DD/YYYY")) 
    '       Added this row of Code 4/3/06 jmr 
            xlSheet.Cells(localRowCount, 4) = 
WorksheetFunction.Clean(olTempItem.Body) 
    '       xlSheet.Cells(localRowCount, 4) = 
Replace(Replace(Replace(olTempItem.Body, Chr(9), " "), Chr(10) & Chr(10), 
Chr(10)), Chr(13), "") 
          End If 
        
       Next 
    
   readability_and_HTML_export 
   xlBook.SaveAs ("\\stm-fs1\marketing-shared\feedback\xls\" & xlName & 
".xls") 
    
    
   ActiveWorkbook.PublishObjects.Add( _ 
   SourceType:=xlSourceSheet, _ 
   FileName:="\\stm-fs1\marketing-shared\feedback\htm\" & xlName & ".htm", _ 
   Sheet:="Sheet1", _ 
   Source:="", _ 
   HtmlType:=xlHtmlStatic).Publish 
    
'   strAttachment = strAttachment & "\\stm-fs1\finapps\dynamics\feedback\" & 
xlName & ".htm; " 
    
   xlBook.Save 
   xlBook.Close 
  
End If 
  
' New temp code - 040406 
' Loop through and search each subfolder of the current folder. 
For Each olNewFolder In CurrentFolder.Folders 
  
Select Case olNewFolder.Name 
  
Case "Deleted Items", "Drafts", "Export", "Junk E - mail", "Notes" 
Case "Outbox", "Sent Items", "Search Folders", "Calendar", "Inbox" 
Case "Contacts", "Journal", "Shortcuts", "Tasks", "Folder Lists" 
Case Else 
ProcessFolder olNewFolder 
  
End Select 
  
Next olNewFolder 
  
' The next five lines are the original code 
' Loop through and search each subfolder of the current folder. 
' For Each olNewFolder In CurrentFolder.Folders 
      ' If olNewFolder.Name <> "Deleted Items" And olNewFolder.Name <> 
"Drafts" And olNewFolder.Name <> "Export" And olNewFolder.Name <> "Junk E - 
mail" And olNewFolder.Name <> "Outbox" And olNewFolder.Name <> "Sent Items" 
And olNewFolder.Name <> "Search Folders" And olNewFolder.Name <> "Calendar" 
And olNewFolder.Name <> "Contacts" And olNewFolder.Name <> "Notes" And 
olNewFolder.Name <> "Journal" And olNewFolder.Name <> "Shortcuts" And 
olNewFolder.Name <> "Tasks" And olNewFolder.Name <> "Folder Lists" And 
olNewFolder.Name <> "Inbox" Then 
        
        ' ProcessFolder olNewFolder 
      
      ' End If 
   ' Next 
End Sub 
  

Private Sub readability_and_HTML_export() 
' 
' readability_and_HTML_export Macro 

  
' 
    Cells.Select 
    Cells.EntireColumn.AutoFit 
    Cells.EntireRow.AutoFit 
    Columns("A:A").ColumnWidth = 32 
'    Range("A1").Select 
'    Range(Selection, Selection.End(xlDown)).Select 
'    Range(Selection, Selection.End(xlToRight)).Select 
    Cells.Select 
    With Selection 
        .HorizontalAlignment = xlGeneral 
        .VerticalAlignment = xlTop 
        .Orientation = 0 
        .AddIndent = False 
        .IndentLevel = 0 
        .ShrinkToFit = False 
        .ReadingOrder = xlContext 
        .MergeCells = False 
    End With 
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone 
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone 
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone 
    Selection.Borders(xlEdgeTop).LineStyle = xlNone 
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone 
    Selection.Borders(xlEdgeRight).LineStyle = xlNone 
    With Selection.Borders(xlInsideVertical) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
    With Selection.Borders(xlInsideHorizontal) 
        .LineStyle = xlContinuous 
        .Weight = xlThin 
        .ColorIndex = xlAutomatic 
    End With 
    Range("A1:D1").Select 
    With Selection.Interior 
        .ColorIndex = 37 
        .Pattern = xlSolid 
    End With 
    Selection.Font.Bold = True 
    Columns("C:C").Select 
    With Selection 
        .HorizontalAlignment = xlLeft 
        .WrapText = False 
        .Orientation = 0 
        .AddIndent = False 
        .IndentLevel = 0 
        .ShrinkToFit = False 
        .ReadingOrder = xlContext 
        .MergeCells = False 
    End With 
    If Columns("D:D").ColumnWidth < 80 Then 
        Columns("D:D").ColumnWidth = 80 
    End If 
  
    If Columns("B:B").ColumnWidth > 40 Then 
        Columns("B:B").ColumnWidth = 40 
    End If 
End Sub 
  
  
  
'Private Sub DTSMailer(messagebody As String, attachmentstring As String) 
Private Sub DTSMailer() 
    Dim oPKG As New DTS.Package 
    
    oPKG.LoadFromSQLServer "SQLServer", , , _ 
        DTSSQLStgFlag_UseTrustedConnection, , , , "Feedback_Mailer" 
    oPKG.FailOnError = True 
  
'    oPKG.GlobalVariables.Item("messagebody") = messagebody 
'    oPKG.GlobalVariables.Item("attachmentstring") = attachmentstring 
    
    oPKG.Execute 
    oPKG.UnInitialize 
    Set oPKG = Nothing 
End Sub

 

[jpotucek]

No bites... does that mean no one can help me out?

 

[CautionMP]

I was hoping that someone that 'knows' would jump in but...

When you say the subject is getting truncated, when converted do you only get the first 255 characters of the subject?

CMP

(GMT-07:00) Mountain Time (US & Canada)

 

[jpotucek]

The MessageBody column of the .htm file is getting truncated after 255. yes. I don't know how to code it so that the final output (the .htm file) is formated with wordwrap and Autofit for the entire document.

 

[CautionMP]

That's what I figured, the 255 character limit is pretty common in Excel. I don't think there is a setting in Excel to get past this limitation, but there are work arounds. Here are two ideas.

My first thought is to change the HTML file after Excel creates it.

[highlight gray]...
ActiveWorkbook.PublishObjects.Add( _ 
   SourceType:=xlSourceSheet, _ 
   FileName:="\\stm-fs1\marketing-shared\feedback\htm\" & xlName & ".htm", _ 
   Sheet:="Sheet1", _ 
   Source:="", _ 
   HtmlType:=xlHtmlStatic).Publish[/highlight]
[green]'Open the created HTML file and replace the Body text and re-write the file[/green]

[green]'New Declarations[/green]
Dim intFile As Integer
Dim strFile As String
intFile = FreeFile

[green]'Get the current HTML file text[/green]
Open "\\stm-fs1\marketing-shared\feedback\htm\" & xlName & ".htm" For Input As #intFile
strFile = Input(LOF(intFile), #intFile)
Close #intFile

[green]'replace the body text[/green]
For localRowCount = 2 To localRowCount 'Assumes localRowCOunt has not been touched
  strFile = Replace(strFile, Left(xlSheet.Cells(localRowCount, 4), 255), xlSheet.Cells(localRowCount, 4))
Next localRowCount

[green]'Write the modified text back to the HTML file[/green]
Open "\\stm-fs1\marketing-shared\feedback\htm\" & xlName & ".htm" For Output As #intFile
Print #intFile, strFile
Close #intFile

[highlight gray]'   strAttachment = strAttachment & "\\stm-fs1\finapps\dynamics\feedback\" & 
xlName & ".htm; " 
...[/highlight gray]

Second thought, write your own routine to create the HTML file:

[green]'New Declarations[/green]
Dim intFile As Integer
Dim strTableRow As String
intFile = FreeFile

[green]'Open the file and write the body and table header[/green]
[b]Open "\\stm-fs1\marketing-shared\feedback\htm\" & xlName & ".htm" For Input As #intFile
strTableRow = "<HTML><BODY>"
Print #intFile, strTableRow
strTableRow = "<TABLE>"
Print #intFile, strTableRow[/b]

[green]' Loop through the items in the current folder.
' Looping through backwards in case items are to be deleted,
' as this is the proper way to delete items in a collection.[/green]
    For i = CurrentFolder.Items.Count To 1 Step -1
 
       Set olTempItem = CurrentFolder.Items(i)
 
[green]       ' Check to see if a match is found[/green]
       If ((olTempItem.ReceivedTime >= dtStartDate) And (olTempItem.ReceivedTime < dtEndDate)) Then
         globalRowCount = globalRowCount + 1
         [b]strTableRow = "<TR><TD>" &[/b] olTempItem.Subject [b]& "</TD>"[/b]
         [b]strTableRow = strTableRow & "<TD>" &[/b] olTempItem.SenderEmailAddress [b]& "</TD>"[/b]
         [b]strTableRow = strTableRow & "<TD>" &[/b] CStr(Format(olTempItem.ReceivedTime, "MM/DD/YYYY")) [b]& "</TD>"[/b]
[green] '       Added this row of Code 4/3/06 jmr[/green]
         [b]strTableRow = strTableRow & "<TD>" &[/b] WorksheetFunction.Clean(olTempItem.Body) [b]& "</TD></TR>"[/b]
       End If
       [b]Print #intFile, strTableRow[/b]
    Next
[green]'Write the table and body footer[/green]
[b]strTableRow = "</TABLE>"
Print #intFile, strTableRow
strTableRow = "</BODY></HTML>"
Print #intFile, strTableRow
Close #intFile[/b]
...

Hope this helps,
CMP

(GMT-07:00) Mountain Time (US & Canada)

 

[jpotucek]

Thank you much! I'll let you know how I make out

 

[jpotucek]

Thank you for all your help !!!! I ended up adding WrapText=True Into readability_and_HTML_export section and it seems to be working fine now. SOmetimes it's the simplest things that I miss!!!! Thanks again