SteveK32
02-16-2012, 07:38 AM
I am running Outlook 2010 / Exchange Server 2010.
Is there any way in Outlook VBA to invoke the Outlook File\SaveAs routine that is available interactively through the user interface? I like the fact that this tool supports the Windows Explorer "Favorites". I have tried the BrowseForFolder function, but can find no way in BrowseForFolder to support the "Windows Explorer" Favorites list. The Favorites accessed by using BrowseForFolder option 6:
BrowseForFolder(0, "Please choose a folder", 0, 6)
is not the same list.
My goal is to invoke the File\SaveAs, populate the File Name field with something other than the default subject line (date-time-sender...), and allow the user to either select the destination from the included Favorites list or browse to the destination folder.
So I need the syntax to call the proper dialog, and the syntax and object name to use for the "File Name" field so I can overwrite the contents.
Alternatively, if I can find a way to support the actual "Windows Explorer Favorites" in the BrowseForFolder function, this approach would also be sufficient.
I have tried copying the new File Name to the clipboard and using SendKeys (%F)(A)(^V), but this is unreliable. I have tried a Wait function to fix timing issues without success. Even though the Wait function is called AFTER the Sendkeys command, the Sendkeys doesn't seem to happen until after the Wait is compete.
I have also tried changing the content of Application.ActiveInspector.currentitem.subject. This changes the email subject line before the %F A is executed to open File\Save As. However, if I subsequently use "myItem.Close olDiscard" to abandon the email and the Subject change, it seems to take effect BEFORE the SendKeys %F A is executed, and the Save As file name is set back to the original Subject line. It seems that no matter what the order of my code, the Sendkeys always happens AFTER everything else.
I know SendKeys is old tech, but I can find no other way to invoke the File\SaveAs tool. Any help would be greatly appreciated.
Below is the portion of code giving me problems. Further down I have included the full code in case anyone wants to test it.
The portion of code at issue:
' Opt 1 changes actual email Subject, not save As file name. If I abandon subject change, the close takes place BEFORE the SendKeys
'objItem.Subject = StrFileTitle
'SendKeys "(%F)(A)"
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
''myItem.Close olDiscard ' If you use this, the text is discarded BEFORE the File \ Save As is invoked!
' Opt 2 - Works but of no use - no Opt to choose path\file and no Windows Explorer Favorites
'ActiveInspector.currentItem.SaveAs "F:\_emailsavetest.msg"
' Opt 3 - Straight SendKeys only - unreliable after about 3 pastes
'Dim DataObj As New MSForms.DataObject
'DataObj.SetText StrFileTitle
'DataObj.PutInClipboard
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
'SendKeys "(%F)(A)", True
'fnWait (2)
'SendKeys "{DEL}", True
'SendKeys "(^V)", True
' This is good for about 3 pastes, but then something goes wrong and it won't paste consistently anymore.
' However manual Ctrl-V always works, so the clipboard is populated correctly.
' When it doesn't work, the {DEL} doesn't work either, so it looks like a timing problem and not a clipboard problem
Public Function fnWait(intNrOfSeconds As Integer)
Dim varStart As Variant
varStart = Timer
Do While Timer < varStart + intNrOfSeconds
Loop
End Function
List of full code for testing
Sub SaveOpenEmailAsMSG()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Dim strFilter As String
Dim strInputFileName As String
Dim InitDir As String
Dim Subject As String
Dim FileYear
Dim FileMonth
Dim FileDay
Dim FileDate
Dim FileMonthDay
Dim FileTime
Dim FileAMPM
Dim StrFileTitle
Dim StrSender
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.currentItem
Subject = objItem.Subject
'InitDir change this to the default directory you would like to point at
InitDir = "m:\Projects"
'************************************************* **
'Company specific filename prefix this section can be Rem'd out
'if need be - it prefixes (yymmdd) 090428 as a date stamp to the filename
'strFileTitle - sets the default filename to be displayed in the dialog box
'FileYear = Right(Year(Now), 2)
'FileMonth = Format(Month(Date), "00")
'FileDay = Format(Day(Now), "00")
FileDate = objItem.ReceivedTime
'MsgBox FileDate
If Mid(FileDate, 2, 1) = "/" Then FileDate = "0" & FileDate 'add 0 to single digit month
If Mid(FileDate, 5, 1) = "/" Then FileDate = Left(FileDate, 3) & "0" & Right(FileDate, Len(FileDate) - 3) 'add 0 to single digit day
If Mid(FileDate, 13, 1) = ":" Then FileDate = Left(FileDate, 11) & "0" & Right(FileDate, Len(FileDate) - 11) 'add 0 to single digit hour
FileYear = Mid(FileDate, 7, 4)
FileMonth = Left(FileDate, 2)
FileDay = Mid(FileDate, 4, 2)
FileTime = Mid(FileDate, 21, 2) & "-" & Mid(FileDate, 12, 2) & "-" & Mid(FileDate, 15, 2) & "-" & Mid(FileDate, 18, 2)
FileDate = FileYear & "-" & FileMonth & "-" & FileDay
StrFileTitle = FileDate & "_" & FileTime & "_" & objItem.SenderName & "~" & Subject
'MsgBox StrFileTitle
'\ / : * ? " < > | (invalid characters to be removed from filename)
'File Title parsing
If Subject <> "" Then
For a = 1 To Len(StrFileTitle)
test = InStr(a, StrFileTitle, "\")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, "/")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, ":")
If test > 0 Then Mid(StrFileTitle, test) = " "
test = InStr(a, StrFileTitle, "*")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, "?")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, """")
If test > 0 Then Mid(StrFileTitle, test) = "'"
test = InStr(a, StrFileTitle, "<")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, ">")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, "|")
If test > 0 Then Mid(StrFileTitle, test) = "-"
Next a
End If
'MsgBox StrFileTitle
If Len(StrFileTitle) > 248 Then StrFileTitle = Left(StrFileTitle, 248) ' 248+ .xxx = 252 (<255 max allowed)
' Opt 1 changes actual email Subject, not save As file name. If I abandon subject change, the close takes place BEFORE the SendKeys
'objItem.Subject = StrFileTitle
'SendKeys "(%F)(A)"
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
''myItem.Close olDiscard ' If you use this the text is discarded BEFORE the File \ Save As is invoked!
' Opt 2 - Works but of no use - no Opt to choose path\file and no Windows Explorer Favorites
'ActiveInspector.currentItem.SaveAs "F:\_emailsavetest.msg"
' Opt 3 - Straight SendKeys only - unreliable after about 3 pastes
'Dim DataObj As New MSForms.DataObject
'DataObj.SetText StrFileTitle
'DataObj.PutInClipboard
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
'SendKeys "(%F)(A)", True
'fnWait (2)
'SendKeys "{DEL}", True
'SendKeys "(^V)", True
' This is good for about 3 pastes, but then something goes wrong and it won't paste anymore. However manual Ctrl V works.
Else
MsgBox "Please double click an email to open it - before saving as an external file", vbInformation + vbOKOnly, "Outlook SaveAs dialog"
End If
'End Function
End Sub
Public Function fnWait(intNrOfSeconds As Integer)
Dim varStart As Variant
varStart = Timer
Do While Timer < varStart + intNrOfSeconds
Loop
End Function
Is there any way in Outlook VBA to invoke the Outlook File\SaveAs routine that is available interactively through the user interface? I like the fact that this tool supports the Windows Explorer "Favorites". I have tried the BrowseForFolder function, but can find no way in BrowseForFolder to support the "Windows Explorer" Favorites list. The Favorites accessed by using BrowseForFolder option 6:
BrowseForFolder(0, "Please choose a folder", 0, 6)
is not the same list.
My goal is to invoke the File\SaveAs, populate the File Name field with something other than the default subject line (date-time-sender...), and allow the user to either select the destination from the included Favorites list or browse to the destination folder.
So I need the syntax to call the proper dialog, and the syntax and object name to use for the "File Name" field so I can overwrite the contents.
Alternatively, if I can find a way to support the actual "Windows Explorer Favorites" in the BrowseForFolder function, this approach would also be sufficient.
I have tried copying the new File Name to the clipboard and using SendKeys (%F)(A)(^V), but this is unreliable. I have tried a Wait function to fix timing issues without success. Even though the Wait function is called AFTER the Sendkeys command, the Sendkeys doesn't seem to happen until after the Wait is compete.
I have also tried changing the content of Application.ActiveInspector.currentitem.subject. This changes the email subject line before the %F A is executed to open File\Save As. However, if I subsequently use "myItem.Close olDiscard" to abandon the email and the Subject change, it seems to take effect BEFORE the SendKeys %F A is executed, and the Save As file name is set back to the original Subject line. It seems that no matter what the order of my code, the Sendkeys always happens AFTER everything else.
I know SendKeys is old tech, but I can find no other way to invoke the File\SaveAs tool. Any help would be greatly appreciated.
Below is the portion of code giving me problems. Further down I have included the full code in case anyone wants to test it.
The portion of code at issue:
' Opt 1 changes actual email Subject, not save As file name. If I abandon subject change, the close takes place BEFORE the SendKeys
'objItem.Subject = StrFileTitle
'SendKeys "(%F)(A)"
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
''myItem.Close olDiscard ' If you use this, the text is discarded BEFORE the File \ Save As is invoked!
' Opt 2 - Works but of no use - no Opt to choose path\file and no Windows Explorer Favorites
'ActiveInspector.currentItem.SaveAs "F:\_emailsavetest.msg"
' Opt 3 - Straight SendKeys only - unreliable after about 3 pastes
'Dim DataObj As New MSForms.DataObject
'DataObj.SetText StrFileTitle
'DataObj.PutInClipboard
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
'SendKeys "(%F)(A)", True
'fnWait (2)
'SendKeys "{DEL}", True
'SendKeys "(^V)", True
' This is good for about 3 pastes, but then something goes wrong and it won't paste consistently anymore.
' However manual Ctrl-V always works, so the clipboard is populated correctly.
' When it doesn't work, the {DEL} doesn't work either, so it looks like a timing problem and not a clipboard problem
Public Function fnWait(intNrOfSeconds As Integer)
Dim varStart As Variant
varStart = Timer
Do While Timer < varStart + intNrOfSeconds
Loop
End Function
List of full code for testing
Sub SaveOpenEmailAsMSG()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Dim strFilter As String
Dim strInputFileName As String
Dim InitDir As String
Dim Subject As String
Dim FileYear
Dim FileMonth
Dim FileDay
Dim FileDate
Dim FileMonthDay
Dim FileTime
Dim FileAMPM
Dim StrFileTitle
Dim StrSender
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.currentItem
Subject = objItem.Subject
'InitDir change this to the default directory you would like to point at
InitDir = "m:\Projects"
'************************************************* **
'Company specific filename prefix this section can be Rem'd out
'if need be - it prefixes (yymmdd) 090428 as a date stamp to the filename
'strFileTitle - sets the default filename to be displayed in the dialog box
'FileYear = Right(Year(Now), 2)
'FileMonth = Format(Month(Date), "00")
'FileDay = Format(Day(Now), "00")
FileDate = objItem.ReceivedTime
'MsgBox FileDate
If Mid(FileDate, 2, 1) = "/" Then FileDate = "0" & FileDate 'add 0 to single digit month
If Mid(FileDate, 5, 1) = "/" Then FileDate = Left(FileDate, 3) & "0" & Right(FileDate, Len(FileDate) - 3) 'add 0 to single digit day
If Mid(FileDate, 13, 1) = ":" Then FileDate = Left(FileDate, 11) & "0" & Right(FileDate, Len(FileDate) - 11) 'add 0 to single digit hour
FileYear = Mid(FileDate, 7, 4)
FileMonth = Left(FileDate, 2)
FileDay = Mid(FileDate, 4, 2)
FileTime = Mid(FileDate, 21, 2) & "-" & Mid(FileDate, 12, 2) & "-" & Mid(FileDate, 15, 2) & "-" & Mid(FileDate, 18, 2)
FileDate = FileYear & "-" & FileMonth & "-" & FileDay
StrFileTitle = FileDate & "_" & FileTime & "_" & objItem.SenderName & "~" & Subject
'MsgBox StrFileTitle
'\ / : * ? " < > | (invalid characters to be removed from filename)
'File Title parsing
If Subject <> "" Then
For a = 1 To Len(StrFileTitle)
test = InStr(a, StrFileTitle, "\")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, "/")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, ":")
If test > 0 Then Mid(StrFileTitle, test) = " "
test = InStr(a, StrFileTitle, "*")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, "?")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, """")
If test > 0 Then Mid(StrFileTitle, test) = "'"
test = InStr(a, StrFileTitle, "<")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, ">")
If test > 0 Then Mid(StrFileTitle, test) = "-"
test = InStr(a, StrFileTitle, "|")
If test > 0 Then Mid(StrFileTitle, test) = "-"
Next a
End If
'MsgBox StrFileTitle
If Len(StrFileTitle) > 248 Then StrFileTitle = Left(StrFileTitle, 248) ' 248+ .xxx = 252 (<255 max allowed)
' Opt 1 changes actual email Subject, not save As file name. If I abandon subject change, the close takes place BEFORE the SendKeys
'objItem.Subject = StrFileTitle
'SendKeys "(%F)(A)"
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
''myItem.Close olDiscard ' If you use this the text is discarded BEFORE the File \ Save As is invoked!
' Opt 2 - Works but of no use - no Opt to choose path\file and no Windows Explorer Favorites
'ActiveInspector.currentItem.SaveAs "F:\_emailsavetest.msg"
' Opt 3 - Straight SendKeys only - unreliable after about 3 pastes
'Dim DataObj As New MSForms.DataObject
'DataObj.SetText StrFileTitle
'DataObj.PutInClipboard
'fnWait (2) ' Wait for ClipBoard to populate before invoking paste
'SendKeys "(%F)(A)", True
'fnWait (2)
'SendKeys "{DEL}", True
'SendKeys "(^V)", True
' This is good for about 3 pastes, but then something goes wrong and it won't paste anymore. However manual Ctrl V works.
Else
MsgBox "Please double click an email to open it - before saving as an external file", vbInformation + vbOKOnly, "Outlook SaveAs dialog"
End If
'End Function
End Sub
Public Function fnWait(intNrOfSeconds As Integer)
Dim varStart As Variant
varStart = Timer
Do While Timer < varStart + intNrOfSeconds
Loop
End Function