J
jpotucek
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 :
'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 (e-mail address removed)
format: "
' recipient = InputBox(strprompt, "Recipient's email", "(e-mail address removed)")
' 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
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
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 :
'xls code to format MessageBody Column'
Columns("D
").SelectWith 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 (e-mail address removed)
format: "
' recipient = InputBox(strprompt, "Recipient's email", "(e-mail address removed)")
' 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
1").SelectWith 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 ThenColumns("D
").ColumnWidth = 80End 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