Open Save As dialog box in existing VBA Sub

[BKen001]

Hi there,

Below is the macro that I am using to export tasks from Outlook into Excel which I put together using various bits found while googling (See Macro 1). I am trying to merge Macro 1 & Macro 2, so that the user may use the "Save As" dialogue box to save the output file instead of having to manually enter the address in. I am using Office 2010.

tl; Dr : I'd like to do is have the ability to open up a "Save As" dialogue box within the existing macro (Macro 1)





Macro 1. Exports tasks from Outlook into excel:

Sub ExportTasks()
MsgBox "Make sure Outlook is Open.", vbOKOnly, "Task Exporter"

Dim Ns As Outlook.NameSpace

Set Ns = Application.GetNamespace("MAPI")

'use the default folder
Set Items = Ns.GetDefaultFolder(olFolderTasks).Items
Const SCRIPT_NAME = "Export Tasks to Excel"
Dim olkTsk As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
lngRow As Long, _
lngCnt As Long, _
strFilename As String

'manually enter full file address
strFilename = InputBox("Enter a filename (including path) to save the exported tasks to.", SCRIPT_NAME)
If strFilename = "" Then
MsgBox "The filename is blank. Export aborted.", vbInformation + vbOKOnly, SCRIPT_NAME
Else
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet

' Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "StartDate"
.Cells(1, 3) = "DueDate"


End With
lngRow = 2

For Each olkTsk In Ns.GetDefaultFolder(olFolderTasks).Items 'Get data from tasks folder in outlook
excWks.Cells(lngRow, 1) = olkTsk.Subject
excWks.Cells(lngRow, 2) = olkTsk.StartDate
excWks.Cells(lngRow, 3) = olkTsk.DueDate

lngRow = lngRow + 1
lngCnt = lngCnt + 1
Next
Set olkTsk = Nothing
excWkb.saveas strFilename
excWkb.Close
MsgBox "Process complete. A total of " & lngCnt & " tasks were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing

End Sub

Macro 2: Opens Up "Save As"
I am trying to merge the macro below into the macro above. However I can't seem to get it right

Sub SaveAsDialog()
Dim sFolderName As String, fDialog As FileDialog, ret As Long, FileToSave As String, vrtSelectedItems
Set fDialog = Application.FileDialog(msoFileDialogSaveAs)

fDialog.InitialFileName = "test"
ret = fDialog.Show
With Application.FileDialog(msoFileDialogSaveAs)
For Each vrtSelectedItem In .SelectedItems
FileToSave = vrtSelectedItem
ActiveWorkbook.SaveAs FileToSave
Next vrtSelectedItem

End With

End Sub

 

[Fishboy]

Hi BKen001, welcome to the boards.

I may be wrong here but it seems a little over complicated. If I am not mistaken you can simply replace this line from Macro1:

excWkb.saveas strFilename

With this line instead:

Application.Dialogs(xlDialogSaveAs).Show

Ultimately you may want to tidy up the rest of the code as I don't think that any reference to strFilename would be required any further. I believe the amended macro could look something like this (I am a little uncertain what some of the scripts you are referencing are doing so I have left those intact):

Sub ExportTasks()
MsgBox "Make sure Outlook is Open.", vbOKOnly, "Task Exporter"


Dim Ns As Outlook.Namespace


Set Ns = Application.GetNamespace("MAPI")


'use the default folder
Set Items = Ns.GetDefaultFolder(olFolderTasks).Items
Const SCRIPT_NAME = "Export Tasks to Excel"
Dim olkTsk As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
lngRow As Long, _
lngCnt As Long


'manually enter full file address
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet


' Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "StartDate"
.Cells(1, 3) = "DueDate"




End With
lngRow = 2


For Each olkTsk In Ns.GetDefaultFolder(olFolderTasks).Items 'Get data from tasks folder in outlook
excWks.Cells(lngRow, 1) = olkTsk.Subject
excWks.Cells(lngRow, 2) = olkTsk.StartDate
excWks.Cells(lngRow, 3) = olkTsk.DueDate


lngRow = lngRow + 1
lngCnt = lngCnt + 1
Next
Set olkTsk = Nothing
Application.Dialogs(xlDialogSaveAs).Show
excWkb.Close
MsgBox "Process complete. A total of " & lngCnt & " tasks were exported.", vbInformation + vbOKOnly, SCRIPT_NAME
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing


End Sub