Code:
Option Compare Database
Option Explicit
Private Sub cmdOpenPlantFile_Click()
'7 Select Licensor or Cultivar. Automatic read from Mother Form for Plant information andPermit Information.
' Show File Picker to select a file path.
' http://accessjitsu.com/2015/09/13/code-listing-using-the-microsoft-office-file-dialog-in-ms-access/
' https://www.youtube.com/watch?v=DTtDchA4XQ4
On Error GoTo SubError
'Add "Microsoft Office 16.0 Object Library" in references
Dim fDialog As Office.FileDialog
Dim Varfile As Variant
Dim SourceFile As String
Dim Formname As String
Dim Filterstring As String
Formname = Me.Name
Filterstring = Me.[cmbSelectDirectory] & Me.[txtLicensor] & "*"
'https://chandoo.org/forum/threads/filter-file-name-in-application-filedialog-msofiledialogfilepicker.43634/
txtOpenedFile = ""
' Set up the File Dialog
'
Set fDialog = Application.FileDialog(msoFileDialogFilePicker) 'Pick a file.When entering the formula you enter
' the left"(" you get four options.
' Set fDialog = Application.FileDialog(msoFileDialogOpen)
With fDialog
.Title = "Choose the file you would like to open"
.AllowMultiSelect = False
.InitialFileName = Filterstring
If .Show = True Then
If .SelectedItems.Count = 0 Then
'User clicked open but didn't select a file
GoTo SubExit
End If
For Each Varfile In .SelectedItems
' txtSelectedName = txtSelectedName & Varfile & vbCrLf ' & vbCrLf sit 'n linefeed in wat ons ni ewil hê nie.
txtOpenedFile = Varfile
Next
Else
'user cancelled dialog without choosing!
'Do you need to react?
End If
End With
If Formname = "frmCultivarPropFileStore" Then
SourceFile = [Forms]![frmCultivarPropFileStore]![txtOpenedFile]
ElseIf Formname = "frmCultivarPermitFileStore" Then
SourceFile = [Forms]![frmCultivarPermitFileStore]![txtOpenedFile]
End If
Application.FollowHyperlink SourceFile
SubExit:
On Error Resume Next
Set fDialog = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Private Sub cmdSelectOrigenDirectory_Click()
'2 Select Origen Folder if Different
' https://www.youtube.com/watch?v=WmRhSDcwf1k
' http://accessjitsu.com/2015/09/13/code-listing-using-the-microsoft-office-file-dialog-in-ms-access/
' https://www.youtube.com/watch?v=DTtDchA4XQ4
Dim Formname As String
Formname = Me.Name
On Error GoTo SubError
'Add "Microsoft Office 14.0 Object Library" in references
Dim fDialog As Office.FileDialog
Dim Varfile As Variant
txtBeginningDirectory = ""
' Set up the File Dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Choose the directory you would like to import from"
.AllowMultiSelect = False
.InitialFileName = Me.txtBeginningDirectory.Value 'Folder picker needs trailing slash
If .Show = True Then
If .SelectedItems.Count = 0 Then
'User clicked open but didn't select a file
GoTo SubExit
End If
For Each Varfile In .SelectedItems
' txtBeginningDirectory = txtBeginningDirectory & Varfile & vbCrLf & "\" 'vbCrLf = Linefeed. Wil dit nie hê nie.
txtBeginningDirectory = txtBeginningDirectory & Varfile & "\"
DoCmd.SetWarnings False '-------------------------
If Formname = "frmClientFileStore" Then
DoCmd.OpenQuery "qryUpdatetblLastFolder"
ElseIf Formname = "frmCultivarPropFileStore" Then
DoCmd.OpenQuery "qryUpdatetblLastFolderOrigenProp"
ElseIf Formname = "frmCultivarPemitFileStore" Then
DoCmd.OpenQuery "qryUpdatetblLastFolderOrigenPermit"
'
End If
' DoCmd.OpenQuery "qryUpdatetblLastFolder"
DoCmd.SetWarnings True '---------------------
Next
Else
'user cancelled dialog without choosing!
'Do you need to react?
End If
End With
SubExit:
On Error Resume Next
Set fDialog = Nothing
Exit Sub
SubError:
DoCmd.SetWarnings True
MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Private Sub cmdShow_Click()
' Show File Picker to select a file path.
' http://accessjitsu.com/2015/09/13/code-listing-using-the-microsoft-office-file-dialog-in-ms-access/
' https://www.youtube.com/watch?v=DTtDchA4XQ4
On Error GoTo SubError
'Add "Microsoft Office 16.0 Object Library" in references
Dim fDialog As Office.FileDialog
Dim Varfile As Variant
txtSelectedName = ""
' Set up the File Dialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker) 'Pick a file.When entering the formula you enter the left"(" you get four options.
' Set fDialog = Application.FileDialog(msoFileDialogOpen)
With fDialog
.Title = "Choose the file you would like to import"
.AllowMultiSelect = False
.InitialFileName = Me.txtBeginningDirectory.Value 'Folder picker needs trailing slash
.Filters.Clear
.Filters.Add "All files", "*.*", 1
.Filters.Add "Excel files", "*.xls*", 2
.Filters.Add "Excel files", "*.doc*", 3
.Filters.Add "Various files", "*.doc* ;*.xls*", 4
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 5
' .Filters.Add "Excel files", "*.xls"
' .Filters.Add "Excel files", "*.xlsx"
' .Filters.Add "Excel macro-enabled", "*.xlsm"
.FilterIndex = 1 ' Or 2 for Excel files and 3 for Word Files etc.
If .Show = True Then
If .SelectedItems.Count = 0 Then
'User clicked open but didn't select a file
GoTo SubExit
End If
'An option for MultiSelect = False
'varFile = .SelectedItems(1)
'txtSelectedName = varFile
'Needed when MultiSelect = True
For Each Varfile In .SelectedItems
' txtSelectedName = txtSelectedName & Varfile & vbCrLf ' & vbCrLf sit 'n linefeed in wat ons ni ewil hê nie.
txtSelectedName = txtSelectedName & Varfile
Next
Else
'user cancelled dialog without choosing!
'Do you need to react?
End If
End With
'xxxxxxx ' Determine Name from txtSelectedName and enter into txtNewFileName
' GetFilenameFromPath(txtSelectedName)
' Varfile = GetFilenameFromPath(SourceFile)
'SourceFile = [Forms]![frmCultivarPropFileStore]![txtSelectedName]
Varfile = GetFilenameFromPath([Forms]![frmCultivarPermitFileStore]![txtSelectedName])
txtNewFileName = GetFileNamepart(Varfile)
SubExit:
On Error Resume Next
Set fDialog = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Private Sub cmdSaveFile_Click() 'xxxxxxxxxxx
' See https://howtoexcelatexcel.com/vba/copy-a-file-from-one-folder-to-another-macro/
Dim SourceFile As String
Dim DestFile As String
Dim DestDir As String
Dim DestDir1 As String
Dim DestDir2 As String
Dim DestDir3 As String
Dim Varfile As String
Dim FolderExists As String
txtSavedPath = ""
DestDir = cmbSelectDirectory & "\"
' DestDir1 = "J:\IP Clients\"
' DestDir2 = "C:\SAPO\PlantPropertiesDocuments\"
' DestDir3 = "\\Sapofs01\ip\IP Clients\"
' DestDir3 = "C:\ip\IP Clients\"
GoTo SubFolderExistsforLicensor 'Cut tests for directories out
TestForDestDir1:
If Len(Dir(DestDir1, vbDirectory)) > 0 Then
' MsgBox "This directory does exist." & DestDir1
DestDir = DestDir1
GoTo ProceedDestDir
Else
MsgBox "This directory does NOT exist. " & DestDir1 & "This one is the normal one for SAPO users. Click OK to try the next one."
End If
If Len(Dir(DestDir2, vbDirectory)) > 0 Then
' MsgBox "This directory does exist." & DestDir2
DestDir = DestDir2
GoTo ProceedDestDir
Else
MsgBox "This directory does NOT exist. " & DestDir2 & "This is the normal one on Fritz's Laptop. Try the next one."
End If
If Len(Dir(DestDir3, vbDirectory)) > 0 Then
' MsgBox "This file does exist." & DestDir3
DestDir = DestDir3
GoTo ProceedDestDir
Else
MsgBox "None of the directories exist. Not " & DestDir1 & " NOR " & DestDir2 & " NOR " & DestDir3 & "Please ensure one exist. The first one is the normal for SAPO users."
GoTo ExitSub
End If
ProceedDestDir:
DestDir = DestDir & Me.txtLicensor.Value & "\"
If Len(Dir(DestDir, vbDirectory)) > 0 Then
' MsgBox "This file does exist." & DestDir
Else
MsgBox "None of the directories exist. Not " & DestDir1 & " NOR " & DestDir2 & " NOR " & DestDir3
GoTo ExitSub
End If
FolderExistsforLicensor:
DestDir = DestDir & cmbSelectDirectory & "\"
If Len(Dir(DestDir, vbDirectory)) > 0 Then
' MsgBox "This file does exist." & DestDir
Else
MsgBox "The sub directory for Plant Properties does not exist" & DestDir
GoTo ExitSub
End If
SubFolderExistsforLicensor:
SourceFile = [Forms]![frmCultivarPermitFileStore]![txtSelectedName] 'Korrek
Varfile = GetFilenameFromPath(SourceFile)
DestFile = DestDir & [Forms]![frmCultivarPermitFileStore]![txtLicensor] & ";" & [Forms]![frmCultivarPermitFileStore]![txtNewFileName] & "." & GetFileExt(Varfile)
If SourceFile = DestFile Then
MsgBox "Source and Destination is the same. Please change."
GoTo ExitSub
End If
txtSavedPath = DestFile
FileCopy SourceFile, DestFile
MsgBox "File successfully saved to path shown on the right. " & txtSavedPath
ExitSub:
End Sub
Sub SelectDestinationDirectory()
'Not used. May expand to this later.
'OPEN FILE PICKER TO SELECT DESTINATION DIRECTORY AND SAVE FILE
'#####################
'1. OPEN FILE PICKER TO SELECT DESTINATION DIRECTORY
' Show File Picker to select a file path.
' http://accessjitsu.com/2015/09/13/code-listing-using-the-microsoft-office-file-dialog-in-ms-access/
' https://www.youtube.com/watch?v=DTtDchA4XQ4
On Error GoTo SubError
'Add "Microsoft Office 16.0 Object Library" in references
Dim fDialog As Office.FileDialog
Dim Varfile As Variant
Dim TargetFolder As String
'Stop '1
TargetFolder = "C:\SAPO\IP Database Module\" & Me.txtLicensor.Value & "\" & cmbSelectDirectory & "\"
txtSelectedName = "" 'This is to clearfile picker file name.
' Set up the File Dialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Stop '2
' Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
'Pick a file.When entering the formula you enter the left"(" you get four options.
With fDialog
.Title = "Choose the folder where you want to save the file"
.AllowMultiSelect = False
.InitialFileName = TargetFolder 'Folder picker needs trailing slash
.Filters.Clear ' No filters for save.
Stop '3
' Moet hier 'n directory select
If .Show = True Then
If .SelectedItems.Count = 0 Then
'User clicked open but didn't select a file
GoTo SubExit
End If
'An option for MultiSelect = False
TargetFolder = .SelectedItems(1) & "\"
'txtSelectedName = varFile
Stop '4
'Needed when MultiSelect = True
For Each Varfile In .SelectedItems
' txtSelectedName = txtSelectedName & Varfile & vbCrLf ' & vbCrLf sit 'n linefeed in wat ons ni ewil hê nie.
txtSelectedName = txtSelectedName & Varfile
Next
Else
'user cancelled dialog without choosing!
'Do you need to react?
End If
End With
Stop '5
'xxxxxxx ' Determine Name from txtSelectedName and enter into txtNewFileName
' GetFilenameFromPath(txtSelectedName)
' Varfile = GetFilenameFromPath(SourceFile)
'SourceFile = [Forms]![frmClientFileStore]![txtSelectedName]
Varfile = GetFilenameFromPath([Forms]![frmClientFileStore]![txtSelectedName])
txtNewFileName = GetFileNamepart(Varfile)
SubExit:
On Error Resume Next
Stop '6
Set fDialog = Nothing
Exit Sub
SubError:
Stop '7
MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
'VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV
Function GetFilenameFromPath(ByVal strPath As String) As String
' https://stackoverflow.com/questions/1743328/how-to-extract-file-name-from-path
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
Function GetFileExt(ByVal strFileWPath As String)
'See https://www.devhut.net/2013/02/26/ms-access-vba-determine-a-files-extension/
On Error GoTo Error_Handler
GetFileExt = Right(strFileWPath, Len(strFileWPath) - InStrRev(strFileWPath, "."))
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetFileExt" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Function GetFileNamepart(ByVal myPath As String)
'See https://www.devhut.net/2013/02/26/ms-access-vba-determine-a-files-extension/
On Error GoTo Error_Handler
'GetFilenameFromPath(ByVal strPath As String)
'Left(myPath, InStrRev(myPath, ".") - 1)
'https://www.thespreadsheetguru.com/the-code-vault/2014/3/2/retrieving-the-file-name-extension-from-a-file-path-string
GetFileNamepart = Left(myPath, InStrRev(myPath, ".") - 1)
GetFileNamepart = GetFileNamepart
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occurred." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetFileExt" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Private Sub Form_Close()
txtSavedPath = ""
txtNewFileName = ""
txtSelectedName = ""
' txtLicensor = ""
txtOpenedFile = ""
End Sub
Private Sub Form_Current()
DoCmd.MoveSize 1200, 400, 16500, 11500
txtBeginningDirectory = DLast("LastOrigenFolderPermit", "tblLastFolder", "ID = 1")
End Sub