Attribute VB_Name = "OutlookMacroEands_22_02_2023" Private Declare PtrSafe Function CustomTimeOffMsgBox Lib "user32" Alias "MessageBoxTimeoutA" ( _ ByVal xHwnd As LongPtr, _ ByVal xText As String, _ ByVal xCaption As String, _ ByVal xMsgBoxStyle As VbMsgBoxStyle, _ ByVal xwlange As Long, _ ByVal xTimeOut As Long) _ As Long 'See SOURCE below ' This function removes invalid and other characters from file names Private Sub ReplaceCharsForFileNameU(sName As String, sChr As String) sName = Replace(sName, "/", sChr) sName = Replace(sName, "\", sChr) sName = Replace(sName, ":", sChr) sName = Replace(sName, "?", sChr) sName = Replace(sName, Chr(34), sChr) 'Speech mark sName = Replace(sName, "<", sChr) sName = Replace(sName, ">", sChr) sName = Replace(sName, "|", sChr) sName = Replace(sName, "&", sChr) sName = Replace(sName, "%", sChr) sName = Replace(sName, "*", sChr) sName = Replace(sName, " ", sChr) sName = Replace(sName, "{", sChr) sName = Replace(sName, "[", sChr) sName = Replace(sName, "]", sChr) sName = Replace(sName, "}", sChr) sName = Replace(sName, "!", sChr) sName = Replace(sName, Chr(9), sChr) '30/06/2022 Tab copied into The Subject 'https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/character-set-0127 or .../reference/character-sets End Sub ' This function removes invalid and other characters from file names (From Details) Private Sub ReplaceCharsForFileNameV(sSender As String, sChr As String) sSender = Replace(sSender, "/", sChr) sSender = Replace(sSender, "\", sChr) sSender = Replace(sSender, ":", sChr) sSender = Replace(sSender, "?", sChr) sSender = Replace(sSender, Chr(34), sChr) sSender = Replace(sSender, "<", sChr) sSender = Replace(sSender, ">", sChr) sSender = Replace(sSender, "|", sChr) sSender = Replace(sSender, "&", sChr) sSender = Replace(sSender, "%", sChr) sSender = Replace(sSender, "*", sChr) sSender = Replace(sSender, " ", sChr) sSender = Replace(sSender, "{", sChr) sSender = Replace(sSender, "[", sChr) sSender = Replace(sSender, "]", sChr) sSender = Replace(sSender, "}", sChr) sSender = Replace(sSender, "!", sChr) sSender = Replace(sSender, Chr(9), sChr) '30/06/2022 Tab copied into The Subject End Sub Sub OutlookEands_22_02_2023() Dim Selection As Selection Dim obj As Object Dim Item As MailItem Dim wrdApp As Word.Application Dim wrdDoc As Word.Document 'If Word.Windows.Count = 0 Then 'If Application.ActiveExplorer = Word Then 'Dim Msg, Style, Response, MyString 'Msg = "Open Word Now." ' Style = vbOKOnly 'Title = "Macro Es Email to Docx" ' Response = MsgBox(Msg, Style, Title) ' If Response = vbOKOnly Then ' MyString = "OK" ' End If ' End If 'Macro E amended from https://www.slipstick.com/developer/code-samples/save-outlook-email-pdf ''Error Handler to deal with if Word is not Open when macro is run 04/05/2022 JM '' SOURCE: www.mrexcel.com/board/threads/searching-excel-from-word.287617/ '''On Error Resume Next '12/11/2021 On ERROR CLOSE VISUAL BASIC, OPEN WORD, AND RERUN THE MACRO. Set wrdApp = GetObject(, "Word.Application") ''''Changed 10/11/2021 works if WordApp is open and leaves file open and active ''Error Handler to deal with if Word is not Open when macro is run 04/05/2022 JM '''If Err.Number <> 0 Then ''Added 04/05/2022 JM ''' Set wrdApp = CreateObject("Word.Application") ''Added 04/05/2022 JM ''' End If ''Added 04/05/2022 JM 'On Error GoTo 0 ''Added 04/05/2022 JM '''''Dim Hits As Long, oTask As Task '''''For Each oTask In Tasks '''''If Left(oTask.Name, 14) = "Microsoft Word" Then Hits = Hits + 1 '''''Next oTask '''''If Hits = 0 Then '''''Dim MyAppID, ReturnValue 'AppActivate "Word" '''''MyAppID = Shell("C:\Program Files (x86)\Microsoft Office\root\Office16\winword.exe", 0) ''AppActivate MyAppID, True '''ReturnValue = Shell("C:\Program Files (x86)\Microsoft Office\root\Office16\winword.exe", 2) '''AppActivate ReturnValue '''''If Word.Application.Documents.Count = 1 Then '''''Word.Application.Documents.Close '''''End If '''''End If Set Selection = Application.ActiveExplorer.Selection For Each obj In Selection Set Item = obj Dim fso As Object, TmpFolder As Object Dim sName As String Dim ssName As String ''' Dim sSender As String Set fso = CreateObject("Scripting.FileSystemObject") Set tmpFileName = fso.GetSpecialFolder(2) 'This the initial error handler for subjects that force the file path and name over 255 when temporarily saved in a few steps time (27/10/2021). 'With only 13 characters for the From Details, the subject can be 144 characters to equal 255 characters for the temp location and file name. 'I have set the Subject limit at 125, if the Subject is longer than this, it will be cropped to the first 125 characters. 'Some NHS Email senders have a very long From field so this can force the temp path and file name over 255 characters. 'I have added an independent error handler for the Sender details so both will be cropped independently of each other. sName = Item.Subject ReplaceCharsForFileNameU sName, " " If Len(sName) > 124 Then sName = Left(sName, 124) End If sSender = Item.Sender ReplaceCharsForFileNameV sSender, " " If Len(sSender) > 32 Then sSender = Left(sSender, 32) End If dtDate = Item.ReceivedTime ssName = "[Sent]" & Format(dtDate, "dd-mm-yyyy", vbUseSystemDayOfWeek, _ vbUseSystem) & " [Time]" & Format(dtDate, "hh-nn-ss", _ vbUseSystemDayOfWeek, vbUseSystem) & " [From]" & sSender & " [Subject]" & sName & " [Content]" tmpFileName = tmpFileName & "\" & ssName & ".mht" Item.SaveAs tmpFileName, olMHTML 'Word.Application.ScreenUpdating = False Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=True) 'Macro s added by james.martin@birmingham.gov.uk Dim oShape As InlineShape For Each oShape In wrdDoc.InlineShapes If oShape.Width > 430 Then oShape.LockAspectRatio = True oShape.Width = 430 End If If oShape.Height > 660 Then oShape.LockAspectRatio = True oShape.Height = 660 End If Next Set oShape = Nothing ''Error Handler 04/05/2022 JM ''SOURCE: www.msofficeforums.com/word-vba/45531-change-page-size-hundreds-documents.html Dim PaperSize As Object If wrdDoc.pagesetup.PaperSize <> wdPaperA4 Then wrdDoc.pagesetup.PaperSize = wdPaperA4 End If Set PaperSize = Nothing Dim WshShell As Object Dim SpecialPath As String Dim strToSaveAs As String Set WshShell = CreateObject("WScript.Shell") MyDocs = WshShell.SpecialFolders(16) strToSaveAs = "C:\traajsmn" & "\" & "Support Email " & ssName & ".docx" ' check for duplicate filenames ' if matched, add the current time to the file name If fso.fileExists(strToSaveAs) Then ssName = ssName & Format(Now, " hh-mm-ss") strToSaveAs = "C:\traajsmn" & "\" & "Support Email " & ssName & ".docx" End If wrdApp.ActiveDocument.SaveAs2 FileName:= _ strToSaveAs, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _ AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _ EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=True, SaveFormsData _ :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15 Next obj 'MsgBox appears briefly for 300 thousandths of a second, and Closes so Macro L detects the Macro Es usage. 'SOURCE: https://wwwextendoffice.com/documents/excel/3836-excel-message-box-timer-timeout.html Call CustomTimeOffMsgBox(0, "", "OUTLOOK MACRO Es - Save Email in List View to *.docx and Open at C:\traajsmn\", vbInformation, 0, 300) 'wrdDoc.Close 'wrdApp.Quit (this caused a long delay when toggling through with Fn+F8 on 24/10/10, so trying with it commented out, 'seems in wrong order, maybe needs to go after wrdApp = nothing as might be leaving lots of Word Apps in Task Manager) Set wrdDoc = Nothing ''''Changed 10/11/2021 Set WshShell = Nothing ''''Changed 10/11/2021 Set obj = Nothing ''''Changed 10/11/2021 Set Selection = Nothing ''''Changed 10/11/2021 Set Item = Nothing ''''Changed 10/11/2021 'wrdApp.Quit '' 01/11/2021''''Changed 10/11/2021 Set wrdApp = Nothing ''01/11/2021 This adds a duplicate word App so 1 closes but another stays open so don't use this ''Deleted JM 04/05/2022 Word.Application.screenupdating = True ' Word.Application.ScreenUpdating = True '''22/06/2022 End Sub