Outlook code to save attachments from selected messages to folder

SaveAttachmentsToDisk.vba

Option Explicit
Private Const SW_RESTORE = 9

#If VBA7 Then
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function IsIconic Lib "user32.dll" (ByVal hwnd As Long) As Long
#Else
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function IsIconic Lib "user32.dll" (ByVal hwnd As Long) As Long
#End If

Sub SaveAttachmentsToDisk()
Dim MItem As Outlook.MailItem
Dim oAttachment As Outlook.Attachment
Dim enviro As String
Dim tempfold As String
  
enviro = CStr(Environ("USERPROFILE"))
tempfold = enviro & "\documents\tempmsgs\"
If Dir(tempfold, vbDirectory) = "" Then MkDir tempfold

For Each MItem In ActiveExplorer.Selection
    For Each oAttachment In MItem.Attachments
        oAttachment.SaveAsFile tempfold & oAttachment.DisplayName
    Next
Next

Call OpenFolder(tempfold)

End Sub

Private Sub OpenFolder(strDirectory As String)
'DESCRIPTION: Open folder if not already open. Otherwise, activate the already opened window
'INPUT: Pass the procedure a string representing the directory you want to open
Dim pID As Variant
Dim sh As Variant
Dim w As Variant
On Error GoTo 102:
Set sh = CreateObject("shell.application")
For Each w In sh.Windows
    If w.Name = "Windows Explorer" Or w.Name = "File Explorer" Then
        If w.document.Folder.self.Path = strDirectory Then
            'if already open, bring it front
            If CBool(IsIconic(w.hwnd)) Then ' If it's minimized, show it
                w.Visible = False
                w.Visible = True
                ShowWindow w.hwnd, SW_RESTORE
            Else
                w.Visible = False
                w.Visible = True
            End If
            Exit Sub
        End If
    End If
Next
'if you get here, the folder isn't open so open it
pID = Shell("explorer.exe " & strDirectory, vbNormalFocus)
102:
End Sub