VB6 - Prompt to save as with commonDialog1

Wilder1626
Wilder1626 used Ask the Experts™
on
Hi

While using the below code to create an excel extract, i would like to show a prompt to save the file as so that i can save it anywhere on my PC.

 Dim xlObj As Object    'New Excel.Application -- only used with Excel reference
  Dim wkbOut As Object   'Excel.Workbook
  Dim wksOut As Object   'Excel.Worksheet
  Dim rngOut As Object   'Excel.Range
  Dim sngStart As Single    'forperformance measurement
  Dim start_time As Long
  Dim end_time As Long
  Dim total_time As Long

  'output to Excel workbook
  lblStatus.Caption = "Begin Excel Data Export"
  Set xlObj = CreateObject("Excel.Application")
  Set wkbOut = xlObj.Workbooks.Add
  Set wksOut = wkbOut.Worksheets("Sheet1")  'can skip this step
  Set rngOut = wksOut.Range("A1")           'by replacing with wkbOut.Worksheets("Sheet1").Range("A1")
  
  Me.MousePointer = vbHourglass
  Me.Enabled = False
  
  xlObj.ScreenUpdating = False
  xlObj.Calculation = -4135     '=xlCalculationManual


  'BulkLoad rngOut, sngData
  Clipboard.clear 'Clear the Clipboard
    With MSHFlexGrid_crow_fly_loads
        .Col = 0
        .Row = 0
        .ColSel = .Cols - 1
        .RowSel = .Rows - 1
        Clipboard.SetText .Clip
    End With
     With xlObj.ActiveWorkbook.ActiveSheet
        .Range("A1").Select
        .Range("A1:S1").Interior.Color = RGB(205, 197, 191)
        .Columns("A:S").NumberFormat = "@"
        .Paste
        .Columns("A:S").AutoFit
        .Range("C2").Select
        ActiveWindow.FreezePanes = True
    End With

  xlObj.Calculation = -4105     '=xlCalculationAutomatic
  xlObj.ScreenUpdating = True
  xlObj.Visible = True
  
  Set rngOut = Nothing
  Set wksOut = Nothing
  Set wkbOut = Nothing
  Set xlObj = Nothing
  
  lblStatus.Caption = "Finished Excel Data Export."

  Me.MousePointer = vbDefault
  Me.Enabled = True

Open in new window


I have found this below code, but just can seem to put it in so that it really save.

Can you please help me?

Thanks

Private Sub Command_Click()
On Error GoTo eh
    With CommonDialog1
        .CancelError = True
        .Filter = "Text files (*xls) |*.xls"
        .ShowSave
        Open CommonDialog1.FileName For Output As #1
        Print #1, xlObj
        Close #1
   
    End With
        Exit Sub
eh:
    If Err <> cdlCancel Then
        MsgBox "Error #" & Err.Number & " - " & Err.Description
    End If
End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
You might want to use the save feature in Excel.

Try:
xlObj.ActiveWorkbook.SaveAs("C:\File.xls")

Open in new window


See How to: Programmatically Save Workbooks (MSDN) for more information.

--
Chris
Hi Chris.

Thanks for the information. But i already do this pretty much all the time but it would always save at the same place. I want to be able to save it anywhere i want by selecting the folder i would select based on the commondialog.
How about using the common dialog control to obtain a file path/name from the user, reading it back (via the FileName property if memory serves?) and then passing that to the Excel automation SaveAs method?

--
Chris
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Ok. I'm now able to save it anywhere i want. But i just have a small problem now.

If i click cancel to not save it, it still save it on the desktop.

Do you what what's the problem in my below code?

    Dim xlObj As Object    'New Excel.Application -- only used with Excel reference
    Dim wkbOut As Object   'Excel.Workbook
    Dim wksOut As Object   'Excel.Worksheet
    Dim rngOut As Object   'Excel.Range
    Dim sngStart As Single    'forperformance measurement
    Dim start_time As Long
    Dim end_time As Long
    Dim total_time As Long
    Dim FileNm As Variant

    On Error Resume Next

    'Save file to
    With CommonDialog1
        .Filename = Format(Date, "mmmm dd, yyyy")
        .ShowSave
        .CancelError = True
        FileNm = .Filename
        If Err.number = 32755 Then
            MsgBox "not saved - user pressed cancel or closed the dialog"
            Exit Sub
        Else
            path_link = FileNm & ".xls"
        End If

    End With

    'output to Excel workbook
    lblStatus.Caption = "Begin Excel Data Export"
    Set xlObj = CreateObject("Excel.Application")
    Set wkbOut = xlObj.Workbooks.Add
    Set wksOut = wkbOut.Worksheets("Sheet1")  'can skip this step
    Set rngOut = wksOut.Range("A1")           'by replacing with wkbOut.Worksheets("Sheet1").Range("A1")

    Me.MousePointer = vbHourglass
    Me.Enabled = False

    xlObj.ScreenUpdating = False
    xlObj.Calculation = -4135     '=xlCalculationManual


    'BulkLoad rngOut, sngData
    Clipboard.clear    'Clear the Clipboard
    With MSHFlexGrid_crow_fly_loads
        .Col = 0
        .Row = 0
        .ColSel = .Cols - 1
        .RowSel = .Rows - 1
        Clipboard.SetText .Clip
    End With
    With xlObj.ActiveWorkbook.ActiveSheet
        .Range("A1").Select
        .Range("A1:S1").Interior.Color = RGB(205, 197, 191)
        .Columns("A:S").NumberFormat = "@"
        .Paste
        .Columns("A:S").AutoFit
        .Range("C2").Select
        ActiveWindow.FreezePanes = True
    End With


    xlObj.ActiveWorkbook.SaveAs FileNm



    xlObj.Calculation = -4105     '=xlCalculationAutomatic
    xlObj.ScreenUpdating = True
    xlObj.Visible = True

    Set rngOut = Nothing
    Set wksOut = Nothing
    Set wkbOut = Nothing
    Set xlObj = Nothing



    lblStatus.Caption = "Finished Excel Data Export."

    Me.MousePointer = vbDefault
    Me.Enabled = True

Open in new window

order of commands is a little out. need the CancelError property before calling ShowSave
.FileName is only valid if not error
do you want to specify a file extension as default also ?

 With CommonDialog1
        .Filename = Format(Date, "mmmm dd, yyyy")
         .CancelError = True  '<--moved
        .ShowSave
        
        
        If Err.number = 32755 Then
            MsgBox "not saved - user pressed cancel or closed the dialog"
            Exit Sub
        Else
             FileNm = .Filename
            path_link = FileNm & ".xls"
        End If

Open in new window

Just tried and now it works. I have also added the Excel filter

do you want to specify a file extension as default also ?

That would be good!

    'Save file to
    With CommonDialog1
        .Filename = "Format(Date, "mmmm dd, yyyy")
        .CancelError = True  '<--moved
        .Filter = "Spreadsheet Files (*.xls)|*.xls| 2k7 Excel Files (*.xlsx)|*.xlsx"
        .ShowSave


        If Err.number = 32755 Then
            MsgBox "not saved - user pressed cancel or closed the dialog"
            Exit Sub
        Else
            FileNm = .Filename
            path_link = FileNm & ".xls"
        End If

    End With

Open in new window

add it to .Filename as your current is not a good default in my opinion...

    .Filename = "OUT" &  format(date,"yyyymmdd") & ".xlsx"

Open in new window


by using the naming shown, the files will sort by name correctly in WinExplorer.
That you so much for your help. it works great now.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial