I am having difficulty figuring out how to put the Folder Path in Cell C49. I'd like to have the Path there for the User to understand where they are searching and if they have to change said Path.
I got this VBA code from,
http://learnexcelmacro.com/wp/2016/12/how-to-open-file-explorer-in-vba/
Private Sub cmd_button_BROWSEforFolder_Click()
On Error GoTo err
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show = -1 Then 'Any folder is selected
[folderPath] = .SelectedItems.Item(1)
ThisWorkbook.Sheets("Home").Range("C49") = .SelectedItems.Item(1)
Else ' else dialog is cancelled
MsgBox "You have cancelled the dialogue"
[folderPath] = "" ' when cancelled set blank as file path.
End If
End With
err:
Exit Sub
End Sub
I've tried rearranging the location of,
ThisWorkbook.Sheets("Home").Range("C49") = .SelectedItems.Item(1)
and tried changing
.SelectedItems.Item(1)
to,
[folderPath]
with no prevail.
what am I missing?
all I need is the path to be displayed above the txtbox and if it needs to be changed then the User used the button to redirect the search. (this button will not initiate the search Macro)
Private Sub cmd_button_BROWSEforFolder_Click()
On Error GoTo err
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)
Dim folderPath As String
'To allow or disable to multi select
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show = -1 Then 'Any folder is selected
folderPath = .SelectedItems.Item(1)
Else ' else dialog is cancelled
MsgBox "You have cancelled the dialogue"
folderPath = "NONE" ' when cancelled set blank as file path.
End If
End With
err:
ThisWorkbook.Sheets("Home").Range("C49") = folderPath
End Sub
Related
I'm trying to create a VBA code to do this:
Open a dialog box to choose a word file in the path: C:\Add-in\Company A\Templates in docx format
Select as active sheet Navette the file: "Checklist - Navette" if there's no open file with this name appear a message: "ERROR Please push the comand checklist first" and quit the macro
Populate all the bookmarks of the word file with content cells that have name equal as the bookmarks (use sheet Navette)
If the Navette sheet has a cell named "Civilité" and the content is equal to "Female" must go to the excel file in the path: C:\Add-in\Mapping.xlsx on the Replace sheet and search all the words in the column A throught the word file and replace with words in the column B otherwise replace with the words in the column C
Open a dialog box to input the path to save the word with the name TEST in word and pdf format
Close the initial files without saving
Quit all aplications
I'm stucked in the code and it's even working. When I try to run It also get stucked :(
Sub TestProcess()
'Initial process
Dim fd As FileDialog
Dim strFile As String
Dim wdDoc As Document
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim SaveAsFileName As String
Dim SaveAsFileFormat As Integer
'Dialog box to pickup the docx file
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = "C:\Add-in\Company\Templates"
.Filters.Add "Word Files", "*.docx", 1
If .Show = -1 Then
strFile = .SelectedItems(1)
End If
End With
Set wdDoc = Documents.Open(strFile)
'Identify the checklist
On Error Resume Next
Set wb = Workbooks("Company - Navette.xlsx")
On Error GoTo 0
'Handling with errors
If wb Is Nothing Then
MsgBox "ERROR 'Please select the command *Open Navette*first"
wdDoc.Close
Set wdDoc = Nothing
Exit Sub
End If
'Active Worksheet
On Error Resume Next
Set ws = wb.Sheets("Navette")
On Error GoTo 0
'Handling with errors
If ws Is Nothing Then
MsgBox "Sheet 'Navette' not found in the workbook."
'For each Bookmark equal name cell replace with the content
For Each wdBookmark In wdDoc.Bookmarks
wdBookmark.Range.Text = ws.Range(wdBookmark.Name).Value
Next
'Save file
'Open a dialog box to input the path to save the Word file
SaveAsFileName = Application.GetSaveAsFilename(FileFilter:="Word Files (*.docx), .docx; PDF Files (.pdf), *.pdf", Title:="Save As", InitialFileName:=strFile)
'Check if a file name and format are selected
If SaveAsFileName <> "False" Then
'Determine the selected file format
If Right(SaveAsFileName, 4) = ".pdf" Then
SaveAsFileFormat = 17
Else
SaveAsFileFormat = 0
End If
'Save the file in the selected format
objDoc.SaveAs SaveAsFileName, FileFormat:=SaveAsFileFormat
End If
'Close Doc & Excel
wdDoc.Close
wb.Close
'Reset the documents
Set wdDoc = Nothing
Set wb = Nothing
Exit Sub
End If
End Sub
I am trying to check all of the permissions that I can so that people can choose any file and before it fails later on in the program they can get an error message that directly responds to why they cannot save to that location. The two that work right now that I have covered are "No Folder Selected," and "This File does NOT exist". Saying that it is readonly is not working and if anyone has any helpful tips that would be greatly appreciated or any ideas of more checks that I could do about the files. I am testing it using the program files file on my computer.
Sub CreateFile()
Dim BaseDirectory As String
Dim FS As FileSystemObject
Set FS = New FileSystemObject
BaseDirectory = GetFolder()
If (BaseDirectory = vbNullString) Then
MsgBox "No Folder Selected", vbExclamation, "Error"
GoTo EndProgram
End If
'Not Working
With FS.GetFolder(BaseDirectory)
If (.Attributes And ReadOnly) Then
MsgBox .Name & " is readonly!"
GoTo EndProgram
End If
End With
If Len(Dir(BaseDirectory)) = 0 Then
MsgBox "This file does NOT exist."
GoTo EndProgram
End If
EndProgram:
End Sub
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
I'm expecting this to say .Name is readonly!, but it does not work at .attributes and readonly. It just says This file does NOT exist
Here is a function that checks if the current user has write access to a folder. It works by creating a temp file in that folder for writing, if it's able to create it then it will return true. Otherwise, this function will return false.
'CHECK TO SEE IF CURRENT USER HAS WRITE ACCESS TO FOLDER
Public Function HasWriteAccessToFolder(ByVal FolderPath As String) As Boolean
'#example: HasWriteAccessToFolder("C:\Program Files") -> True || False
'MAKE SURE FOLDER EXISTS, THIS FUNCTION RETURNS FALSE IF IT DOES NOT
Dim Fso As Scripting.FileSystemObject
Set Fso = New Scripting.FileSystemObject
If Not Fso.FolderExists(FolderPath) Then
Exit Function
End If
'GET UNIQUE TEMP FilePath, DON'T WANT TO OVERWRITE SOMETHING THAT ALREADY EXISTS
Do
Dim Count As Integer
Dim FilePath As String
FilePath = Fso.BuildPath(FolderPath, "TestWriteAccess" & Count & ".tmp")
Count = Count + 1
Loop Until Not Fso.FileExists(FilePath)
'ATTEMPT TO CREATE THE TMP FILE, ERROR RETURNS FALSE
On Error GoTo Catch
Fso.CreateTextFile(FilePath).Write ("Test Folder Access")
Kill FilePath
'NO ERROR, ABLE TO WRITE TO FILE; RETURN TRUE!
HasWriteAccessToFolder = True
Catch:
End Function
Leverage the function? I'm using VBS (not VBA) but someone may still find this a useful observation. If you run the fso commands on a path that doesn't exist or perms issue it will return the function and error code, use that to determine if the user has access to that folder:
'VBS Example:
Function TestDirectory(FullDirPath)
'Purpose: test creation, if path doesn't exist or permissions issue, function will return error code
strDir = fso.GetAbsolutePathName(FullDirPath)
strDir = strDir & "\_randfoldercrtplsdelthis"
fso.CreateFolder strDir
If fso.FolderExists(strDir) Then
fso.DeleteFolder strDir, TRUE
End If
End Function
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set Shell = CreateObject("WScript.Shell")
FilePath = "C:\Restricted Start Menu Locked\"
If TestDirectory(FilePath) <> 0 Then
WScript.Echo "Folder Access Denied? Error = " & Err.Number
Else
WScript.Echo "Woot!"
End If
I am trying to have an user select a file and choose a to upload to another location ( like a shared drive). I am using the name function but I realized I am having trouble getting the file name and put into the "toPath" since it is up to the user. Below is my completed code and please any advice or suggestions would help.
At the same time, I hope my codes may help someone is trying to do the samething. Thanks
To Pick a file to upload:
Private Sub Command2_Click()
Dim fDialog As Variant
' Clear listbox contents. '
Me.Path1.Value = ""
' Set up the File Dialog. '
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow user to make multiple selections in dialog box '
.AllowMultiSelect = False
' Set the title of the dialog box. '
.Title = "Please select one file"
' Clear out the current filters, and add our own.'
.Filters.Clear
.Filters.Add "All Files", "*.*"
' 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
'add selected path to text box
Me.Path1.Value = .SelectedItems(1)
Else
MsgBox "No File Selected."
End If
End With
End Sub
To Pick a upload path to upload the file:
Private Sub Command10_Click()
Dim FromPath As String
Dim ToPath As String
Dim fDialog2 As Variant
' Clear listbox contents. '
Me.Path2.Value = ""
FromPath = Me.Path1
ToPath = Me.Path2
' Set up the File Dialog. '
Set fDialog2 = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog2
If .Show = True Then
'add selected path to text box
Me.Path2.Value = .SelectedItems(1)
Else
MsgBox "No file uploaded."
End If
End With
Name FromPath As ToPath & "\" & 'ummmmmmmmmmm I am stucked :(
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub
Refactor the end of Command10_Click as shown below. User can pick new file name.
....
End With
Dim ToName as String
ToName = InputBox("Please Enter New File Name","New File Name")
Name FromPath As ToPath & "\" & ToName
....
I am not sure which file types you are relocating, but you can grab the extension type from FromPath and add to end of ToName
Im new to Access and VBA.
I created a form in which i can select a file via fileDialog.
Here the code for the fileDialog:
Public Function DateiAuswaehlen()
Dim objFiledialog As FileDialog
Set objFiledialog = _
Application.FileDialog(msoFileDialogOpen)
With objFiledialog
.AllowMultiSelect = False
If .Show = True Then
DateiAuswaehlen = .SelectedItems(1)
End If
End With
Set objFiledialog = Nothing
End Function
How can I import the selected Excel File into an access table?
I found the DoCmd.TransferSpreadsheet Method but it has not worked, tbh i dont even know where to place it. Im sorry as I mentioned im very new to VBA
Here you go!!
Sub btn_GetFileName_Click()
'************************************************************************
'Lets get the file name
Debug.Print "Getting File Name"
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Set the starting look location
Dim strComPath As String
strComPath = "C:\"
Dim strFilePath As String
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
'of each selected item. Even though the path is a String,
'the variable must be a Variant because For Each...Next
'routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
.InitialFileName = strComPath
.AllowMultiSelect = False
.Filters.Clear
'Add filter to only show excel files.
.Filters.Add "Excel files", "*.xlsm", 1
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If .Show = -1 Then
strFilePath = .SelectedItems(1)
'Step through each string in the FileDialogSelectedItems collection.
'For Each vrtSelectedItem In .SelectedItems
'vrtSelectedItem is a String that contains the path of each selected item.
'You can use any file I/O functions that you want to work with this path.
'This example simply displays the path in a message box.
' strFilePath: " & vrtSelectedItem
'Next vrtSelectedItem
Else
'The user pressed Cancel.
DoCmd.Hourglass (False)
MsgBox "You must select a file to import before proceeding", vbOKOnly + vbExclamation, "No file Selected, exiting"
Set fd = Nothing
Exit Sub
End If
End With
tblFileName = strFilePath
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "tblTest", tblFileName, True
Set fd = Nothing
End Sub
I need the browse button in input box to find file - VB A - EXCEL Macro][1]
need to find the folder path via browse button instead of typing in input box
is it possible?
|-------------------|
|-------------------| Browse
by clicking a cell it should ask for file browse.
should not be edited manually. i mean , i want to lock the particular cell locked. and only able to edit via macro.
Alternately:
Sub tgr()
Dim strFilePath As String
strFilePath = Application.GetOpenFilename
If strFilePath = "False" Then Exit Sub 'Pressed cancel
MsgBox strFilePath
End Sub
You can use this to find a file. Modify the filter if you need to. the variable fldr will have your data. Then you can set your textbox to that value.
Sub File_Picker()
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add "Text", "*.txt", 1
.InitialFileName = ActiveWorkbook.Path & "\"
.Show
If .SelectedItems.Count = 0 Then GoTo 1
fldr = .SelectedItems(1)
End With
End Sub
or:
Sub Folder_Picker()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ActiveWorkbook.Path & "\"
.Show
If .SelectedItems.Count = 0 Then GoTo 1
fldr = .SelectedItems(1)
End With
End Sub
I have more helpful pieces of code like this at My GitHub