Problem with Code - converting emails to .htm files

**jpotucek** · April 20th 06, 07:42 PM posted to microsoft.public.outlook.program_vba

OK. Someone else wrote this code and they are no longer here. I'm
| not very good with VBA, just trying to get this mess to work.
|
| I'll post the code at the bottom of this post.... but basically what
| it is SUPPOSED to do when the Macro is run in Outlook is ask the user
| for a range of dates and then ask them to pick an email folder to run
| the macro against. It then reads all the emails in the folder and the
| ones which match the date range criteria get dumped into an xls file
| with Columns Subject, sender, received date and message body. The
| xls file is then converted to a .htm file and it's done....
|
|
| what's it's NOT doing is formatting the Message Body column correctly
| in the final .htm file. it is displaying as one long line and is
| getting truncated after it reaches the limit for the column length.
| These are emails from our customers and we can't be truncating the
| message body!!!!
|
| anyway, what I've been having the user do is to run the Macro in
| Outlook (code below) and then edit the .htm output file (open it in
| excel) and run this macro against it to properly format it the cells:
|
| 'xls code to format MessageBody Column'
| Columns("D

").ColumnWidth 80 Then
| Columns("D

**Michael Bauer** · April 24th 06, 07:44 AM posted to microsoft.public.outlook.program_vba

**jpotucek** · April 24th 06, 10:34 AM posted to microsoft.public.outlook.program_vba

**Michael Bauer** · April 24th 06, 02:55 PM posted to microsoft.public.outlook.program_vba

**jpotucek** · April 24th 06, 04:58 PM posted to microsoft.public.outlook.program_vba

**Michael Bauer** · April 24th 06, 06:52 PM posted to microsoft.public.outlook.program_vba

Am Mon, 24 Apr 2006 07:58:01 -0700 schrieb jpotucek:

No prob, we can try to do the job here.

If I gave you a wrong answer, then please ask again and format your original
post in a way that the question is clear.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --

Sorry, I suppose I didn't format my original question very elequently..
And I already posted in the excel forum and i never got any help...
Someone
only replied that I needed to post to the Outlook forum instead..

Does anyone know of any other Forums that I can post to where someone who
knows more about VBA than I do maybe give me a hand with this code?

"Michael Bauer" wrote:

Am Mon, 24 Apr 2006 01:34:01 -0700 schrieb jpotucek:

The wrong forum is another issue as your problem is Excel related. But
that
wasn´t my answer :-)

You said:
| Seems to me that I should be able to elimate a step and incorporate
| the ABove code into the below code???? Can anyone help me
out???????

and I answered where I think that code snippet should be placed.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --

Sorry, I don't unserstand your reply? You mean I posted the in the
wrong
formum?

"Michael Bauer" wrote:

Am Thu, 20 Apr 2006 10:42:01 -0700 schrieb jpotucek:

It seems that the code belongs into the readability_and_HTML_export
method.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --

OK. Someone else wrote this code and they are no longer here. I'm
| not very good with VBA, just trying to get this mess to work.
|
| I'll post the code at the bottom of this post.... but basically what
| it is SUPPOSED to do when the Macro is run in Outlook is ask the user
| for a range of dates and then ask them to pick an email folder to run
| the macro against. It then reads all the emails in the folder and the
| ones which match the date range criteria get dumped into an xls file
| with Columns Subject, sender, received date and message body. The
| xls file is then converted to a .htm file and it's done....
|
|
| what's it's NOT doing is formatting the Message Body column correctly
| in the final .htm file. it is displaying as one long line and is
| getting truncated after it reaches the limit for the column length.
| These are emails from our customers and we can't be truncating the
| message body!!!!
|
| anyway, what I've been having the user do is to run the Macro in
| Outlook (code below) and then edit the .htm output file (open it in
| excel) and run this macro against it to properly format it the
cells:
|
| 'xls code to format MessageBody Column'
| Columns("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
|
| Seems to me that I should be able to elimate a step and incorporate
| the ABove code into the below code???? 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
| format: "
| ' recipient = InputBox(strprompt, "Recipient's email",
| ")
|
| ' 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

**jpotucek** · April 24th 06, 07:57 PM posted to microsoft.public.outlook.program_vba

1").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

").ColumnWidth 80 Then
Columns("D

**Michael Bauer** · April 25th 06, 07:04 AM posted to microsoft.public.outlook.program_vba

**jpotucek** · April 26th 06, 07:01 PM posted to microsoft.public.outlook.program_vba

Thank you for all your help !!!! In readability_and_HTML_export I set
WrapText=True and it's working fine now. SOmetimes it's the simplest
things that I miss!!!! Thanks again

"Michael Bauer" wrote:

Am Mon, 24 Apr 2006 10:57:02 -0700 schrieb jpotucek:

In readability_and_HTML_export set WrapText=True for the entire worksheet or
at least for column D. If the column width is too small then you need to
wrap the text.

A good approach is to use the macro recorder in this case: Copy a few sample
messages into the sheet. Then start the recorder, format the sheet manually
and stop the recorder. You can now use the recorded result (maybe with a few
modifications) for your code.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.vbOffice.net --

Thank you so much. I will try and make my question as direct as possible.

I have a User who runs this Macro (Code Below) From Outlook against a
Mailbox
with basically tons of email folders and thousands of emails. The
user
inputs a date range and specifies a folder for the macro to run against
and
it scans that folder, dumps the emails that meet the date range criteria
into
an xls spreadsheet and then the spreadsheet is converted to a .htm file.

The problem is... ALL OF data makes it into the MessageBody column in the
.xls file but the MessageBody column is Truncated after 255 characters in
the
.htm file. I'd like the MessageBody column of the .htm file to contain
ALL the date - I don't know how to incorporate the word-wrap and autofit
code
that I need to accomplish this.

Help?

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

format: "
' recipient = InputBox(strprompt, "Recipient's email", ")

' 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("A11").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").ColumnWidth 80 Then
Columns("D").ColumnWidth = 80
End If

If Columns("B:B").ColumnWidth 40 Then

Thread Tools	Search this Thread
Show Printable Version Email this Page	Search this Thread: Advanced Search
Display Modes
Switch to Linear Mode Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Distr List, Code execution speed problem	saeongjeema via OfficeKB.com	Outlook and VBA	2	March 27th 06 09:15 PM
Converting iCal (mac) .ics files to Outlook .vcs files	[email protected]	Outlook - Calandaring	1	March 22nd 06 04:30 AM
Converting iCal (mac) .ics files to Outlook .vcs files	Adam	Outlook - General Queries	0	March 10th 06 08:40 PM
Converting Palm .dba files	Ridaher101	Outlook - Calandaring	1	January 21st 06 05:58 PM
Can an OL folder's Home Page be a non-htm, editable document?	T. Wise	Outlook - General Queries	1	January 9th 06 10:54 AM