Browse Dialog Box Showing Up Behind Application

[WeiszMCITP]

Hello,

I use the following macro to help our end users save emails messages as a .msg file in Outlook as an archive on our file server. The issue is that sometimes the Browse dialog box shows up behind Outlook which causes the users to think Outlook is hung. Can someone help me force the Browse dialog box to the front each and every time?

Thanks!

-----------------------------------------------------------------

Sub SaveEmailDateFirst()

Dim olkItem As Object
Dim filePath As String
Dim ReceivedTime As String
Dim strPathname As String
Dim Response As VbMsgBoxResult
Dim fd As Object

'Processes selected emails for saving
With Application.ActiveExplorer
If .Selection.Count = 0 Then
' Nothing was selected!
MsgBox "Please select an email first!"
Exit Sub
Else
Set MailItems = .Selection
End If

'Uses Excel Browse Folder dialog because Outlook doesn't have functionality
Set objX = CreateObject("Word.Application")
If Err.Number = 0 Then
Set fd = objX.Application.FileDialog(msoFileDialogFolderPicker)
With fd

If .Show = -1 Then

'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
strPathname = vrtSelectedItem
For Each mail In MailItems
msgSubject = mail.Subject
msgTime = mail.ReceivedTime
Next
Next
End If
End With

'Closes the Excel Application
objX.Application.Quit
End If
End With

'Detects if user has selected a save destination. If not, it will re-prompt the user.
If strPathname = "" Then
Response = MsgBox("You did not select a save destination. Please click OK to try again or Cancel to exit.", vbOKCancel)
If Response = vbOK Then
Call SaveEmailDateFirst
ElseIf Response = vbCancel Then
Exit Sub
End If
Else
'Save email process
Response = MsgBox("Are you sure you want to save to " & strPathname & " ?", vbYesNo Or vbDefaultButton2)
If Response = vbYes Then
For Each olkItem In Application.ActiveExplorer.Selection
If olkItem.Class = olMail Then
ReceivedTime = olkItem.ReceivedTime
ReceivedTime = Format(ReceivedTime, "yyyy_MM_dd hh:mm:ss")
filePath = ReceivedTime & " " & olkItem.Subject
olkItem.SaveAs strPathname & "\" & ReplaceIllegalCharacters(filePath) & ".msg", olMSG
olkItem.Delete
End If
Next
msgPrompt = MsgBox("The messages were saved to: " & strPathname & "." & vbCrLf _
& "They have also been moved to the Delete Items folder.", vbOKOnly)
Else
End If
End If

End Sub

'Function to replace illegal characters in the file name
Function ReplaceIllegalCharacters(strSubject As String) As String
Dim strBuffer As String
strBuffer = Replace(strSubject, ":", "")
strBuffer = Replace(strBuffer, "\", "")
strBuffer = Replace(strBuffer, "/", "")
strBuffer = Replace(strBuffer, "?", "")
strBuffer = Replace(strBuffer, Chr(34), "'")
strBuffer = Replace(strBuffer, "|", "")
strBuffer = Replace(strBuffer, " ", " ")
ReplaceIllegalCharacters = strBuffer
End Function

 

[MazeWorX]

set the focus to the form first

HTH << MaZeWorX >> "I have not failed I have only found ten thousand ways that don't work" <<Edison>>

 

[WeiszMCITP]

Could you please provide me the code on how to do that?

 

[WeiszMCITP]

Anyone have any ideas?