asked on

VB6 - Prompt to save as with commonDialog1

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

advfinance

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

Wilder1626

ASKER

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.

advfinance

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

Wilder1626

ASKER

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

ASKER CERTIFIED SOLUTION

Robberbaron (robr)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Wilder1626

ASKER

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

Robberbaron (robr)

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.

Wilder1626

ASKER

That you so much for your help. it works great now.