Graham Mayor

Sub SetOutlookSecurityKey()
Dim WSHShell As Object
Dim rKeyWord As String
Dim wVer As String
Dim RegKey As String
Dim strItem As String
strItem = "EnableUnsafeClientMailRules"
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Outlook\Security\"
Debug.Print RegKey
End
Set WSHShell = CreateObject("WScript.Shell")
Start:
On Error Resume Next
rKeyWord = WSHShell.RegRead(RegKey & strItem)
Select Case rKeyWord
Case Is = "1"
MsgBox "Outlook Rules Security Check is Off"
Case Else
WSHShell.RegWrite RegKey & strItem, 1, "REG_DWORD"
MsgBox "Outlook Rules Security Check is Off"
End Select
lbl_Exit:
Exit Sub
End Sub

Option Explicit

Sub ProcessMessage()
'Graham Mayor 8 June 2015
'This macro is used to process a selection of messages from an Outlook folder
Dim olItem As MailItem
For Each olItem In Application.ActiveExplorer.Selection
'Ensure the selcetd item is an e-mail message
If olItem.Class = OlObjectClass.olMail Then
'Then run the main process
TableToExcel olItem
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
'Tell the user the job is done.
MsgBox "Selected message(s) processed."
Exit Sub
End Sub

Sub TableToExcel(olItem As MailItem)
'Graham Mayor 8 June 2015
'This macro is the main process
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
Dim strPath As String
Dim xlRng As Object

'Name the folder in which the workbook will reside
strPath = "C:\Path\Tables " & Format(Date, "(dd-mm-yyyy)\")
'Name the workbook
strWorkBookName = "Table.xlsx"
'Ensure the folder exists, and if it doesn't run the CreateFolders
'Function to create it.
CreateFolders strPath
With olItem
'Access the message body
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'If there are no tables then end the process
If oRng.Tables.Count = 0 Then GoTo lbl_Exit
'Indicate the first table in the message
Set oTable = oRng.Tables(1)
'And copy it to the clipboard
oTable.Range.Copy
'Close the message
.Close 0
End With

'See if Excel is running and if it is use the running version
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
'Excel is not running, so start it up
Set xlApp = CreateObject("Excel.Application")
End If
'xlApp.Visible = True 'Make true while testing
On Error GoTo 0
'Add a new and empty workbook
Set xlWB = xlApp.workbooks.Add 'You might want to use a template here?
'Indicate to the process to use the first sheet
Set xlSheet = xlWB.Sheets(1)
'Paste the clipboard content
xlSheet.Paste
'Optional section to format the table
Set xlRng = xlSheet.UsedRange
With xlRng
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.HorizontalAlignment = 1
.VerticalAlignment = -4160
.Columns.Autofit
End With
'end of optional section
'Ensure the filename doesn't exist and if it does append a
'bracketed number to the name
strWorkBookName = FileNameUnique(strPath, strWorkBookName, "xlsx")
'Save in the indicated folder
xlWB.SaveAs strPath & strWorkBookName
'Close the workbook
xlWB.Close SaveChanges:=False
lbl_Exit:
'and clean up
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 CreateFolders(strPath As String)
'Graham Mayor
'A function to create a named path if it doesn't exist
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor
'A function to create unique filenames (works in all Office apps that run VBA)
'strPath is the folder in which the file will be saved e.g. C:\Path\
'strFileName is the original name of the file to be saved
'strExtension is the filename extension e.g. "xlsx", "docx" etc
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
'Graham Mayor
'A function to establish if a file exists
'(works in all Office apps that run VBA)
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

Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'A function to establish if a folder exists
'(works in all Office apps that run VBA)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(strFolderName)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function