Solved

VBA Application.FileDialog overwrite without prompt

Posted on 2014-09-05
19
1,333 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 46

Assisted Solution

by:Martin Liss
Martin Liss earned 250 total points
ID: 40306911
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
ID: 40307445
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
ID: 40309768
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
Enterprise Mobility and BYOD For Dummies

Like “For Dummies” books, you can read this in whatever order you choose and learn about mobility and BYOD; and how to put a competitive mobile infrastructure in place. Developed for SMBs and large enterprises alike, you will find helpful use cases, planning, and implementation.

 
LVL 84
ID: 40310017
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 46

Expert Comment

by:Martin Liss
ID: 40310165
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
ID: 40310193
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
ID: 40310392
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
ID: 40310460
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
ID: 40310475
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
 
LVL 1

Author Comment

by:filtrationproducts
ID: 40310482
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
ID: 40310495
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
ID: 40310497
You're still missing an End If ... be sure to use the new code I posted.
0
 
LVL 1

Author Comment

by:filtrationproducts
ID: 40310513
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
ID: 40310520
Did you use the new code I posted? It contains the missing statement ...
0
 
LVL 1

Author Comment

by:filtrationproducts
ID: 40310547
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
ID: 40310738
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
ID: 40310778
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
ID: 40310815
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
ID: 40320684
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

Three Reasons Why Backup is Strategic

Backup is strategic to your business because your data is strategic to your business. Without backup, your business will fail. This white paper explains why it is vital for you to design and immediately execute a backup strategy to protect 100 percent of your data.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Office Picture Manager was included in Office 2003, 2007, and 2010, but not in Office 2013. Users had hopes that it would be in Office 2016/Office 365, but it is not. Fortunately, the same zero-cost technique that works to install it with …
Preparing an email is something we should all take special care with – especially when the email is for somebody you may not know very well. The pressures of everyday working life stacked with a hectic office environment can make this a real challen…
With Microsoft Access, learn how to specify relationships between tables and set various options on the relationship. Add the tables: Create the relationship: Decide if you’re going to set referential integrity: Decide if you want cascade upda…
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.

776 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