Option Compare Database
Option Explicit
Public fs As FileSystemObject, strOrigDir As String, strDestDir As String
Public Function InstallEMTSCompRpt() As String
Set fs = New FileSystemObject
strOrigDir = CurrentProject.Path & "\"
strDestDir = fFolderDialog
Debug.Print fCopyFile("testprog.txt")
End Function
Public Function fFolderDialog() As String
'Requires reference to Microsoft Office 10.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
'Clear listbox contents.
'Me.FileList.RowSource = ""
'Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
'Allow user to select only one EMTSReports Database
.AllowMultiSelect = False
'Set the title of the dialog box.
.Title = "Please select the EMTSReports Database to receive objects"
'Clear out the current filters, and add our own.
.Filters.Clear
.InitialFileName = "\\okc-svr01\obishare$\Access Applications\EMTS\"
.InitialView = msoFileDialogViewList
'Show the dialog box. If the .Show method returns True, the
'user picked at least one file. If the .Show method returns
'False, the user clicked Cancel.
If .Show = True Then
'Loop through each file selected and add it to our list box.
For Each varFile In .SelectedItems
fFolderDialog = varFile
Next
Else
fFolderDialog = ""
End If
End With
End Function
Public Function fCopyFile(strFileName As String) As String
Dim lstrSource As String
On Error GoTo ErrfCopyFile
lstrSource = strOrigDir & strFileName
fs.CopyFile lstrSource, strDestDir
fCopyFile = "File " & strFileName & " copied successfully to " & strDestDir & "."
ExitfCopyFile:
Exit Function
ErrfCopyFile:
fCopyFile = "File " & strFileName & " failed to copy to " & strDestDir & ". "
fCopyFile = fCopyFile & "Error is " & Err.Number & " - " & Err.Description & "."
MsgBox fCopyFile, vbExclamation, "InstallEMTSCompRpt Error:"
Resume ExitfCopyFile
End Function
|