Solved

VBA Application.FileDialog overwrite without prompt

Posted on 2014-09-05
19
1,251 Views
Last Modified: 2014-09-13
I am having an issue in Microsoft Access 2007.

I wrote some code that takes data and exports it to Excel. When this code runs it prompts the user to enter a file name using Application.Filedialog(2). The problem is when you type in the file name without an extension (.xls or .xlsx) and a file with that same name exists in that folder it will overwrite it without a prompt. If you type in the extension .xls or .xlsx and that file name with that extension exists it does give you the overwrite prompt.

I need a work around for this.

I found this on a forum which describes the same exact problem I am experiencing.
https://bugs.eclipse.org/bugs/show_bug.cgi?id=332178

And Microsoft describes how to work around it here but this is not working for me or I am doing it wrong.
http://msdn.microsoft.com/en-us/library/system.windows.forms.savefiledialog.overwriteprompt(v=vs.110).aspx

I have attached the original code I used which results in the file being overwritten.

Private Sub Command20_Click()
Dim filenm As String, commonDlg As Object
filenm = ""
Set commonDlg = Application.FileDialog(2)
    With commonDlg
        .AllowMultiSelect = False
        .InitialFileName = "F:\Filename"
        .Title = "Please select a folder and give the file a name"
            If .Show = True Then
              filenm = Trim(.SelectedItems.Item(1))
              
                  DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
              
              msgbox "Your spreadsheet was saved successfully"
            Else
               msgbox "You clicked Cancel in the file dialog box."
            End If
End With
End Sub

Open in new window


I tried adding this to my code but it just crashes with the error "Run-time error 438 object doesn't support this property or method"

        .CreatePrompt = True
        .OverwritePrompt = True

Thanks in advance for any help!
Dan
0
Comment
Question by:filtrationproducts
  • 10
  • 7
  • 2
19 Comments
 
LVL 45

Assisted Solution

by:Martin Liss
Martin Liss earned 250 total points
Comment Utility
How about adding filters so there always has to be either an xls or xlsx extension. It would be done like this in Excel VBA

             .Filters.Clear
             .Filters.Add "Excel", "*.xls; *.xlsx"
0
 
LVL 84

Assisted Solution

by:Scott McDaniel (Microsoft Access MVP - EE MVE )
Scott McDaniel (Microsoft Access MVP - EE MVE ) earned 250 total points
Comment Utility
IMO you should check if the file exists, and take action if you find a match.
If .Show = True Then
  filenm = Trim(.SelectedItems.Item(1))
  If Dir(filenm) <> "" Then
    If MsgBox("Overwrite the file?", vbYesNo, "Confirm File Overwrite") = vbYes Then
      Kill filenm
    Else
     Exit Sub
    End If
  End If
  
  DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
  etc etc

Open in new window

0
 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
MartinLiss,

When I add the filter code for the file extension I receive the error "Run-time error 438 - object doesn't support this property or method."

Scott,

I tried your solution as well but the problem is if the extension isn't typed in the filenm does not contain the file extension either (displays "c:\test" only not "c:\test.xls") so it will not tell me that the file exists.

Thanks for your help!
Dan
0
 
LVL 84
Comment Utility
Then add the extension. You can easily check to see if the last 3 or 4 digits match a list of file extensions, and take action as needed:

If Len(filenm) > 4 Then
  Dim sExt as String
  sExt = Right(filenm, 4)
  If sExt = "xlsx" Then
    '/ nothing to do
  Else
    sExt = Right(filenm, 3)
    If sExt = "xls" Then
      '/ nothing to do
    Else
      filenm = filenm & ".xls"
    End If
else
  '/ the length of filenm is less than 4, so there is no file extension, or it's an oddly named file
  Msgbox "You must select a valid file"  
End If

Open in new window

0
 
LVL 45

Expert Comment

by:Martin Liss
Comment Utility
When I add the filter code for the file extension I receive the error "Run-time error 438 - object doesn't support this property or method."

I don't do Access programming but this Microsoft article shows Filters being used.
0
 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
Scott,

I tried adding your code above to my code to check for extensions. But for some reason it is completely skipping over the code and saving anyway.

Private Sub Command20_Click()
Dim filenm As String, commonDlg As Object
filenm = ""
Set commonDlg = Application.FileDialog(2)
With commonDlg
    .AllowMultiSelect = False
    .InitialFileName = "F:\"
    .Title = "Please select a folder and give the file a name"
    
      If .Show = True Then
        filenm = Trim(.SelectedItems.Item(1))
            'Checking for Excel extension
                If Len(filenm) > 4 Then
                  Dim sExt As String
                  sExt = Right(filenm, 4)
                  If sExt = "xlsx" Then
                    '/ nothing to do
                  Else
                    sExt = Right(filenm, 3)
                    If sExt = "xls" Then
                      '/ nothing to do
                    Else
                      filenm = filenm & ".xls"
                    End If
                Else
                  '/ the length of filenm is less than 4, so there is no file extension, or it's an oddly named file
                  msgbox "You must select a valid file"
                End If
                
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
        msgbox "Your spreadsheet was saved successfully"
      Else
         msgbox "You clicked Cancel in the file dialog box."
      End If
End With
End Sub

Open in new window

0
 
LVL 84
Comment Utility
Move the OpenReport call up a bit:

With commonDlg
    .AllowMultiSelect = False
    .InitialFileName = "F:\"
    .Title = "Please select a folder and give the file a name"
   
      If .Show = True Then
        filenm = Trim(.SelectedItems.Item(1))
            'Checking for Excel extension
                If Len(filenm) > 4 Then
                  Dim sExt As String
                  sExt = Right(filenm, 4)
                  If sExt = "xlsx" Then
                    '/ nothing to do
                  Else
                    sExt = Right(filenm, 3)
                    If sExt = "xls" Then
                      '/ nothing to do
                    Else
                      filenm = filenm & ".xls"
                    End If
                   DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
                   msgbox "Your spreadsheet was saved successfully"
                Else
                  '/ the length of filenm is less than 4, so there is no file extension, or it's an oddly named file
                  msgbox "You must select a valid file"
                End If
                
      Else
         msgbox "You clicked Cancel in the file dialog box."
      End If
End With

Open in new window

0
 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
MartinLiss,

I did it like they did in that post but I was not able to get it to work. I actually tried that prior to posting this question with no success. But I am not sure why it won't accept it.

Dan
Private Sub Command20_Click()
Dim filenm As String, commonDlg As Object
filenm = ""
Set commonDlg = Application.FileDialog(2)
With commonDlg
    .AllowMultiSelect = False
    .InitialFileName = "F:\"
    .Title = "Please select a folder and give the file a name"
    
      If .Show = True Then
        filenm = Trim(.SelectedItems.Item(1))
            'Checking for Excel extension
                If Len(filenm) > 4 Then
                  Dim sExt As String
                  sExt = Right(filenm, 4)
                  If sExt = "xlsx" Then
                    '/ nothing to do
                  Else
                    sExt = Right(filenm, 3)
                    If sExt = "xls" Then
                      '/ nothing to do
                    Else
                      filenm = filenm & ".xls"
                    End If
                Else
                  '/ the length of filenm is less than 4, so there is no file extension, or it's an oddly named file
                  msgbox "You must select a valid file"
                End If
                
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
        msgbox "Your spreadsheet was saved successfully"
      Else
         msgbox "You clicked Cancel in the file dialog box."
      End If
End With
End Sub

Open in new window

0
 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
Scott,

I updated the code like you show but it is still going straight to the "file saved" message box. I added msgbox prompts throughout the code to see if it is triggering anywhere but I am not receiving any of the msgbox windows I addded (check1 through check7).

It is as if the Application.FileDialog command is completely bypassing the code?



Dan

Private Sub Command20_Click()
Dim filenm As String, commonDlg As Object
filenm = ""
Set commonDlg = Application.FileDialog(2)
With commonDlg
    .AllowMultiSelect = False
    .InitialFileName = "F:\"
    .Title = "Please select a folder and give the file a name"
    
      If .Show = True Then
        filenm = Trim(.SelectedItems.Item(1))
            'Checking for Excel extension
                If Len(filenm) > 4 Then
                msgbox "CHECK1"
                  Dim sExt As String
                  sExt = Right(filenm, 4)
                  If sExt = "xlsx" Then
                    msgbox "CHECK2"
                    '/ nothing to do
                  Else
                  msgbox "CHECK3"
                    sExt = Right(filenm, 3)
                    If sExt = "xls" Then
                      '/ nothing to do
                      msgbox "CHECK4"
                    Else
                    msgbox "Check5"
                      filenm = filenm & ".xls"
                    End If
                   DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
                   msgbox "Your spreadsheet was saved successfully"
                Else
                msgbox "Check 6"
                  '/ the length of filenm is less than 4, so there is no file extension, or it's an oddly named file
                  msgbox "You must select a valid file"
                End If
                msgbox "check7"
      Else
         msgbox "You clicked Cancel in the file dialog box."
      End If
End With
End Sub

Open in new window

0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
Scratch that last post. I have two forms that are almost identical and I think I was running the wrong one while I was editing and testing the code.

Let me try it again.
0
 
LVL 84
Comment Utility
May have been missing an End If. Try this:

Private Sub Command20_Click()
    Dim filenm As String, commonDlg As Object
    filenm = ""
    Set commonDlg = Application.FileDialog(2)
    With commonDlg

        .AllowMultiSelect = False
        .InitialFileName = "F:\"
        .Title = "Please select a folder and give the file a name"

        If .Show = True Then
            filenm = Trim(.SelectedItems.Item(1))
            'Checking for Excel extension
            If Len(filenm) > 4 Then
                MsgBox "CHECK1"
                Dim sExt As String
                sExt = Right(filenm, 4)
                If sExt = "xlsx" Then
                    MsgBox "CHECK2"
                    '/ nothing to do
                Else
                    MsgBox "CHECK3"
                    sExt = Right(filenm, 3)
                    If sExt = "xls" Then
                        '/ nothing to do
                        MsgBox "CHECK4"
                    Else
                        MsgBox "Check5"
                        filenm = filenm & ".xls"
                    End If
                    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
                    MsgBox "Your spreadsheet was saved successfully"
                End If
            Else
                MsgBox "Check 6"
                '/ the length of filenm is less than 4, so there is no file extension, or it's an oddly named file
                MsgBox "You must select a valid file"
            End If
            MsgBox "check7"
        Else
            MsgBox "You clicked Cancel in the file dialog box."
        End If
    End With
End Sub

Open in new window

Also, I'm not sure you should use SelectedItems.Item(1). I don't know off-hand, but most arrays and collections are zero-based, so try SelectedItems.Item(0) instead.
0
 
LVL 84
Comment Utility
You're still missing an End If ... be sure to use the new code I posted.
0
 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
Ok. Now I am receiving a "else without if" on the line that says "Else" just before this line;

         msgbox "You clicked Cancel in the file dialog box."

Sorry if I am being a pain but all the If statements in this code are confusing me. I put it into word and highlighted to try and figure it out but I am not seeing where i am missing something.



Private Sub Command20_Click()
Dim filenm As String, commonDlg As Object
filenm = ""
Set commonDlg = Application.FileDialog(2)
With commonDlg
    .AllowMultiSelect = False
    .InitialFileName = "F:\"
    .Title = "Please select a folder and give the file a name"
    
      If .Show = True Then
        filenm = Trim(.SelectedItems.Item(1))
            'Checking for Excel extension
                If Len(filenm) > 4 Then
                  Dim sExt As String
                  sExt = Right(filenm, 4)
                  If sExt = "xlsx" Then
                    '/ nothing to do
                  Else
                    sExt = Right(filenm, 3)
                    If sExt = "xls" Then
                      '/ nothing to do
                    Else
                      filenm = filenm & ".xls"
                        End If
                        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", filenm
                            msgbox "Your spreadsheet was saved successfully"
      Else
         msgbox "You clicked Cancel in the file dialog box."
      End If
                Else
                  '/ the length of filenm is less than 4, so there is no file extension, or it's an oddly named file
                  msgbox "You must select a valid file"
                End If
            
End With
End Sub

Open in new window

Capture.GIF
0
 
LVL 84
Comment Utility
Did you use the new code I posted? It contains the missing statement ...
0
 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
Yes, I updated it. It appears to be triggering now but it is still overwriting the files without prompt.

I added a msgbox filenm after filenm = filenm & ".xls" just to make sure it is adding the extension to the string and it is. But I type the name of a file that exists and click save and it still says it saved successfully and overwrites the file.

Dan
0
 
LVL 1

Accepted Solution

by:
filtrationproducts earned 0 total points
Comment Utility
I came across this posting;

http://www.access-programmers.co.uk/forums/showthread.php?t=203721

So I reprogrammed it using the API version and it works like it should.

http://access.mvps.org/access/api/api0001.htm

It now restricts the file name to excel format and prompts for overwrite even if the .XLS is not listed.

I had to create a module using the code on the second link then used this code to call and save the file.

Private Sub Command32_Click()

Dim mystrfilter As String

strFilter = ahtAddFilterItem(mystrfilter, "Excel Files (*.xls)", "*.xls")
strSaveFileName = ahtCommonFileOpenSave( _
                                    OpenFile:=False, _
                                    Filter:=strFilter, _
                    Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY)
                    
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QRY_SearchAll2", strSaveFileName
                    
End Sub

Open in new window


Thanks for the help!
Dan
0
 
LVL 84
Comment Utility
FWIW: In my suggestion, if you wanted to prompt the user to overwrite you'd have to include code for that:

<AFTER adding the extension>
If Dir(filenm) <> "" Then
  If Msgbox("Do you want to overwrite " &filenm & "?", vbYesNo, "Confirm Overwrite") = vbNo Then
    Exit Sub
  End If
End If

'/ now do the transferspreadsheet
0
 
LVL 1

Author Comment

by:filtrationproducts
Comment Utility
Scott,

When I add that code technically it works but then I receive two prompts to overwrite (if the user chose to yes to overwrite). The one we programmed in manually then the one we get from the application.filedialog.

Dan
0
 
LVL 1

Author Closing Comment

by:filtrationproducts
Comment Utility
Gave points to both of you because your solutions should have worked if Application.FileDialog worked as Microsoft says it should. But since Application.FileDialog appears to be problematic/flawed I used the API version instead.

Thanks for your help!
Dan
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Suggested Solutions

This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
In Microsoft Access, learn different ways of passing a string value within a string argument. Also learn what a “Type Mis-match” error is about.
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …

763 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

6 Experts available now in Live!

Get 1:1 Help Now