It will need additional functions to achieve that kind of naming. If the folder "J:\TradeTickets\" doesn't exist it will crash, leaving a hidden Excel application running, so make sure it is there and you have write access before running it. If you are going to move the files at the end of the day to a dated folder, why not simply save them in the dated folder in the first place? It wouldn't be much of a stretch to create the folder.
The smaller macro is Sub ProcessMessage() which runs ....
The script to attach to a rule is Sub TableToExcel(olItem As MailItem)
Option Explicit
Sub ProcessMessage()
Dim olItem As MailItem
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
TableToExcel olItem
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
MsgBox "Selected message(s) processed."
Exit Sub
End Sub
Sub TableToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim oTable As Object
Dim strWorkBookName As String
Const strPath As String = "J:\TradeTickets\"
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
If oRng.Tables.Count = 0 Then GoTo lbl_Exit
Set oTable = oRng.Tables(1)
oTable.Range.Copy
.Close 0
End With
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'xlApp.Visible = True
On Error GoTo 0
Set xlWB = xlApp.workbooks.Add 'You might want to use a template here?
Set xlSheet = xlWB.Sheets(1)
xlSheet.Paste
strWorkBookName = FileNameUnique(strPath, "Trade.xlsx", "xlsx")
xlWB.SaveAs strPath & strWorkBookName
xlWB.Close SaveChanges:=False
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set oTable = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlApp = Nothing
Exit Sub
End Sub
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & lngF
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Reply With Quote
