Office.FileDialog check if one or more files exist 1

[patriciaxxx]

I need to open the Office.FileDialog folder browser to select a destination to write one or more files to

I need to have a message prompting the user if one or more of the files already exists and offer the option to overwrite or cancel each individual file with the added functionality to overwrite all or cancel all

Below is my code

Private Sub cmdExtract_Click()
On Error GoTo Err_Handler
Dim fDialog As Office.FileDialog
Dim strPath As String

'Set up the File dialog box.
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Browse" 'Set the title of the dialog box.
If .Show = True Then 'Show the dialog box.
ExtractBlobAll strPath
End If
End With

Exit_Handler:
Exit Sub

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Sub

 

[ByteMyzer]

That should be:

Set fDialog = Application.FileDialog([b][COLOR=#008000]msoFileDialogSaveAs[/color][/b])

 

[strongm]

The logic for that would seem to need to go into your ExtractBlobAll function, which you have not presented in this thread.

 

[patriciaxxx]

The ExtractBlobAll function uses the WriteBinaryFile function so I’ve posted that one as well. I don’t know if the ExtractBlobAll and WriteBinaryFile can be written as one to streamline it a bit, anyway here they are.

'Extracts specified Blob to file.
Private Function WriteBinaryFile(varFileBinary As Variant, strFile As String) As Boolean
On Error GoTo Err_Handler
Dim objStream As Object 'ADODB.Stream
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 1 'adTypeBinary
.Open
.Write varFileBinary
.SaveToFile strFile, 2 'adSaveCreateOverWrite
End With

WriteBinaryFile = True

Exit_Handler:
Set objStream = Nothing
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

'Extracts specified Blob to file.
Private Function ExtractBlobAll(strPath As String) As Boolean
On Error GoTo Err_Handler
Dim strSQL As String
Dim rst As Object 'ADODB.Recordset
Dim strFile As String

Set rst = CreateObject("ADODB.Recordset")
strSQL = "SELECT FileName, FileExt, Blob FROM tblBlob WHERE FileExtract = Yes "
rst.Open strSQL, CurrentProject.Connection, 1, 3
Do Until rst.EOF
If Not IsNull(rst!FileExt) Then
strFile = strPath & rst!FileName & "." & rst!FileExt
End If
WriteBinaryFile rst.Fields("Blob").Value, strFile
rst.MoveNext
Loop
MsgBox rst.RecordCount & " records have been extracted."

Exit_Handler:
rst.Close
Set rst = Nothing
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

 

[patriciaxxx]

would this line somehow be used to answer this thread

CreateObject("scripting.filesystemobject").FileExists(strFile)

help anyone please

 

[strongm]

>CreateObject("scripting.filesystemobject").FileExists(strFile)


Yep, that would be one approach. There are a whole number of ways that this might be achieved.

Given your code, you probably want to put the check somewhere in this loop

Do Until rst.EOF
If Not IsNull(rst!FileExt) Then
strFile = strPath & rst!FileName & "." & rst!FileExt
End If
WriteBinaryFile rst.Fields("Blob").Value, strFile
rst.MoveNext
Loop

And then set a flag representing the users chooice (whether to quit/cancel, replace this particular file or replace all). You'll probably need to pass the flag to the WriteBinaryFile function

 

[patriciaxxx]

strongm will you please give me an example of how you would write the code to achieve this as I am at a loss

 

[patriciaxxx]

Is there anyone willing to help me with an example of the code needed to answer my question in this thread pleas if you know the answer post it for me
Thank you

 

[Golom]

I would modify WriteBinaryFile to

Private Function WriteBinaryFile(varFileBinary As Variant, _
                 strFile As String, _
                 Optional WriteOption as Long = 2) As Boolean
If WriteOption = 0 Then Exit Function
[red] ... Rest of the code ... [/red]

And then in your calling routine

Dim WriteOption As Long
Do Until rst.EOF
    [blue]' Presumably you don't want to attempt the write[/blue]
    [blue]' if either FileName or FileExt are NULL[/blue]
    If Not (IsNull(rst!FileName) OR IsNull(rst!FileExt)) Then
    
        strFile = strPath & rst!FileName & "." & rst!FileExt
        With CreateObject("Scripting.FileSystemObject")
            If .FileExists(strFile) Then
                If MsgBox ("File '" & strFile & "' exists." & vbcrlf & _
                   "Replace it?", vbQuestion + vbYesNo, "Replace File?" ) = vbNo Then
                   WriteOption = 0
            Else
                   WriteOption = adSaveCreateOverWrite
            End If
        End With

        WriteBinaryFile rst.Fields("Blob").Value, strFile, WriteOption

    End If
    rst.MoveNext
Loop

 

[patriciaxxx]

I tried the code but it wont compile
Says theirs an End With missing but looking at it I think its an End If that needs to go in somewhere
Am I right

 

[Golom]

Sorry

Dim WriteOption As Long
Do Until rst.EOF
    ' Presumably you don't want to attempt the write
    ' if either FileName or FileExt are NULL
    If Not (IsNull(rst!FileName) OR IsNull(rst!FileExt)) Then
    
        strFile = strPath & rst!FileName & "." & rst!FileExt
        With CreateObject("Scripting.FileSystemObject")
            If .FileExists(strFile) Then
                If MsgBox ("File '" & strFile & "' exists." & vbcrlf & _
                   "Replace it?", vbQuestion + vbYesNo, "Replace File?" ) = vbNo Then
                   WriteOption = 0
                Else
                   WriteOption = adSaveCreateOverWrite
                End If
            [red]End If[/red]
        End With

        WriteBinaryFile rst.Fields("Blob").Value, strFile, WriteOption

    End If
    rst.MoveNext
Loop

 

[patriciaxxx]

It now compiles but errors on the following line

WriteBinaryFile rst.Fields("Blob").Value, strFile, WriteOption

With this error message

ERROR 3265
Item cannot be found in the collection corresponding to the requested name or ordinal.

 

[Golom]

Try it this way

Private Function ExtractBlobAll(strPath As String) As Boolean
On Error GoTo Err_Handler
Dim strSQL                     As String
Dim rst                        As ADODB.Recordset
Dim cn                         As ADODB.Connection
Dim strFile                    As String
Dim WriteOption                As Boolean
Dim TheBlob                    As Variant
Dim nWrite                     As Long

Set cn = CurrentProject.Connection
Set rst = New ADODB.Recordset
strSQL = "SELECT FileName, FileExt, Blob FROM tblBlob WHERE FileExtract = Yes "
rst.Open strSQL, cn, adOpenForwardOnly, adLockOptimistic

Do Until rst.EOF

    TheBlob = rst!["Blob"]

    If Not (IsNull(rst!Filename) Or IsNull(rst!FileExt)) Then

        strFile = strPath & rst!Filename & "." & rst!FileExt
        WriteOption = True
        
        With CreateObject("Scripting.FileSystemObject")
            If .FileExists(strFile) Then
                If MsgBox("File '" & strFile & "' exists." & vbCrLf & _
                          "Replace it?", _
                          vbQuestion + vbYesNo, "Replace File?") = vbNo Then
                    WriteOption = False
                End If
            End If
        End With

        If WriteOption Then
            If WriteBinaryFile(TheBlob, strFile) Then nWrite = nWrite + 1
        End If

    End If
    rst.MoveNext
Loop

MsgBox rst.RecordCount & " records were extracted." & vbCrLf & _
       nWrite & " records written to file.", vbInformation, "Extract Complete"

Exit_Handler:
If Not (rst Is Nothing) Then rst.Close
Set rst = Nothing
Set cn = Nothing
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function


'Extracts specified Blob to file.
Private Function WriteBinaryFile(varFileBinary As Variant, _
                                 strFile As String) As Boolean

On Error GoTo Err_Handler
Dim objStream                  As ADODB.Stream

Set objStream = New ADODB.Stream
With objStream
    .Type = adTypeBinary
    .Open
    .Write varFileBinary
    .SaveToFile strFile, adSaveCreateOverWrite
End With

WriteBinaryFile = True

Exit_Handler:
Set objStream = Nothing
Exit Function

Err_Handler:
MsgBox "WriteBinaryFile Error" & vbCrLf & _
        Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
WriteBinaryFile = False
Resume Exit_Handler

End Function

 

[patriciaxxx]

I tried it but it gives exactly the same error

Its a tricky one this

 

[PHV]

Replace this:
TheBlob = rst!["Blob"]
with this:
TheBlob = rst![Blob]
or this:
TheBlob = rst.Fields("Blob")

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[Golom]

Gotta be some problem with [blue]adTypeBinary[/blue] and/or [blue]adSaveCreateOverWrite[/blue]. Let's go back to the way you had it.

'Extracts specified Blob to file.
Private Function WriteBinaryFile(varFileBinary As Variant, _
                                 strFile As String) As Boolean
                                 
On Error GoTo Err_Handler
Dim objStream As Object 'ADODB.Stream
Set objStream = CreateObject("ADODB.Stream")
With objStream
    .Type = 1 'adTypeBinary
    .Open
    .Write varFileBinary
    .SaveToFile strFile, 2 'adSaveCreateOverWrite
End With

WriteBinaryFile = True

Exit_Handler:
Set objStream = Nothing
Exit Function

Err_Handler:
MsgBox "WriteBinaryFile Error" & vbCrLf & _
        Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

 

[patriciaxxx]

Hello Golom

I kept on trying your first code and yes I had an error in a variable your first code does kind of work let me explain in the hope you can correct it for me.

Heres what happens with the code

Basically it only shows the yes/no msgbox to extract files if they already exist in the chosen location it wont extract files if they don’t already exist try it out and you’ll see what I mean. Hope you know how to correct it as we’re close now to resolving this.

Below is the code to work from

'Extracts specified Blob to file.
Private Function WriteBinaryFile(varFileBinary As Variant, _
strFile As String, _
Optional WriteOption As Long = 2) As Boolean
If WriteOption = 0 Then Exit Function
On Error GoTo Err_Handler
Dim objStream As Object 'ADODB.Stream
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 1 'adTypeBinary
.Open
.Write varFileBinary
.SaveToFile strFile, 2 'adSaveCreateOverWrite
End With

WriteBinaryFile = True

Exit_Handler:
Set objStream = Nothing
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

'Extracts specified Blob to file.
Private Function ExtractBlobAll(strPath As String) As Boolean
On Error GoTo Err_Handler
Dim strSQL As String
Dim rst As Object 'ADODB.Recordset
Dim strFile As String

Set rst = CreateObject("ADODB.Recordset")
strSQL = "SELECT FileName, FileExt, FileBinary FROM tblFileBinary WHERE FileExtract = Yes "
rst.Open strSQL, CurrentProject.Connection, 1, 3
Dim WriteOption As Long
Do Until rst.EOF
' Presumably you don't want to attempt the write
' if either FileName or FileExt are NULL
If Not (IsNull(rst!FileName) Or IsNull(rst!FileExt)) Then

strFile = strPath & rst!FileName & "." & rst!FileExt
With CreateObject("Scripting.FileSystemObject")
If .FileExists(strFile) Then
If MsgBox("File '" & strFile & "' exists." & vbCrLf & _
"Replace it?", vbQuestion + vbYesNo, "Replace File?") = vbNo Then
WriteOption = 0
Else
WriteOption = adSaveCreateOverWrite
End If
End If
End With

WriteBinaryFile rst.Fields("FileBinary").Value, strFile, WriteOption

End If
rst.MoveNext
Loop
MsgBox rst.RecordCount & " records have been extracted."

Exit_Handler:
rst.Close
Set rst = Nothing
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

 

[patriciaxxx]

Also the msgbox displaying record count needs tying in with your new code to display correct number of files extracted

 

[Golom]

Just need to re-initialize "WriteOption" on each pass through the loop.

'Extracts specified Blob to file.
Private Function ExtractBlobAll(strPath As String) As Boolean
On Error GoTo Err_Handler
Dim strSQL                     As String
Dim rst                        As Object    'ADODB.Recordset
Dim strFile                    As String
Dim WriteOption                As Long
Dim nWritten                   As Long

Set rst = CreateObject("ADODB.Recordset")
strSQL = "SELECT FileName, FileExt, FileBinary FROM tblFileBinary WHERE FileExtract = Yes "
rst.Open strSQL, CurrentProject.Connection, 1, 3

Do Until rst.EOF
    ' Presumably you don't want to attempt the write
    ' if either FileName or FileExt are NULL
    If Not (IsNull(rst!Filename) Or IsNull(rst!FileExt)) Then

        strFile = strPath & rst!Filename & "." & rst!FileExt
        [red]WriteOption = adSaveCreateOverWrite[/red]
        
        With CreateObject("Scripting.FileSystemObject")
            If .FileExists(strFile) Then
                If MsgBox("File '" & strFile & "' exists." & vbCrLf & _
                          "Replace it?", vbQuestion + vbYesNo, "Replace File?") = vbNo Then
                    WriteOption = 0
                Else
                    WriteOption = adSaveCreateOverWrite
                End If
            End If
        End With

        WriteBinaryFile rst.Fields("FileBinary").Value, strFile, WriteOption
        If WriteOption > 0 Then nWritten = nWritten + 1

    End If
    rst.MoveNext
Loop
MsgBox rst.RecordCount & " records were extracted." & vbCrLf & _
       nWritten & " records written to file.", vbInformation, "Extract Complete"

Exit_Handler:
rst.Close
Set rst = Nothing
Exit Function

Err_Handler:
MsgBox Err.Description, vbOKOnly + vbExclamation, "ERROR: " & Err.Number
Resume Exit_Handler

End Function

 

[patriciaxxx]

Golom thank you so very much for both your excellent code and for your patience in sticking with me and providing the solution to my problem.

It works like a dream.