I am trying to read through folders on a drive to see which folders I have at least read access to. I have used the DIR function in MS Access VBA. Is there a more accurate way to determine if I have access. Below is how I am using DIR. Thanks
dim path as string
dim HaveAccess as integer
path = "C:\temp\"
If Dir(path) = "" Then
HaveAccess = 1 'no access
Else
HaveAccess = 2 'i have access
End if
You could use FileSystemObject, but you could also use the intrinsic GetAttr method:
Option Explicit
Private Sub Command1_Click()
Const path As String = "c:\"
Dim folder As String
Dim att As Variant
folder = Dir(path, vbDirectory)
Do While folder <> ""
If folder <> "." And folder <> ".." And (GetAttr(path & folder) And vbDirectory) = vbDirectory Then
att = GetAttr(path & folder) And vbReadOnly
If att = vbReadOnly Then Debug.Print folder & " - read only"
End If
folder = Dir()
Loop
End Sub
Related
I used below code to save outlook emails in folders and subfolder to local drive and preserve original directory.
Private objFileSystem As Object
Private Sub ExportFolderWithAllItems()
Dim objFolder As Outlook.Folder
Dim strPath As String
'Specify the local folder where to save the emails
strPath = "C:\Users\qiaoqiao\"
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
'Select a Outlook PST file or Outlook folder
Set objFolder = Outlook.Application.Session.PickFolder
Call ProcessFolders(objFolder, strPath)
MsgBox "Email saving is completed", vbExclamation
End Sub
Private Sub ProcessFolders(objCurrentFolder As Outlook.Folder, strCurrentPath As String)
Dim objItem As Object
Dim strSubject, strFileName, strFilePath As String
Dim objSubfolder As Outlook.Folder
'Create local folder based on Outlook mailbox folder directory
strCurrentPath = strCurrentPath & ModifyName(objCurrentFolder.Name)
objFileSystem.CreateFolder strCurrentPath
For Each objItem In objCurrentFolder.Items
strSubject = ModifyName(objItem.Subject)
strFileName = strSubject & ".msg"
strFilePath = strCurrentPath & "\" & strFileName
i = 0
Do Until False
strFilePath = strCurrentPath & "\" & strFileName
'Check if there exist emails with the same subject
If objFileSystem.FileExists(strFilePath) Then
'Add order number to the end of the subject
i = i + 1
strFileName = strSubject & " (" & i & ").msg"
Else
Exit Do
End If
Loop
'Save as MSG file
'On Error Resume Next
'Debug.Print Len(strFilePath)
objItem.SaveAs strFilePath, olMSG
Next
'Process subfolders recursively
If objCurrentFolder.Folders.Count > 0 Then
For Each objSubfolder In objCurrentFolder.Folders
Call ProcessFolders(objSubfolder, strCurrentPath & "\")
Next
End If
End Sub
Function ModifyName(folderName As String) As String
'Dim folderName As String
'In order to save emails in the same directory as in Outlook,
'when creating the folders in local drive,
'the folder name must not contain some special characters
folderName = Replace(folderName, ":", "")
folderName = Replace(folderName, "|", "")
folderName = Replace(folderName, ",", "")
folderName = Replace(folderName, "'", "")
folderName = Replace(folderName, "(", "")
folderName = Replace(folderName, ")", "")
folderName = Replace(folderName, "~", "")
folderName = Replace(folderName, "*", "")
folderName = Replace(folderName, "?", "")
folderName = Replace(folderName, "/", "")
folderName = Replace(folderName, "\", "")
folderName = Replace(folderName, """", "")
folderName = Trim(folderName)
'folderName = Replace(folderName, Chr(34), "")
ModifyName = folderName
End Function
However, since there are many layers of folders, so the strFilePath become very long, and it gave me a runtime error saying Operation failed.
Can anyone please advise me how to solve this issue? thank you in advance!!!
In Office products there is a limit to the number of characters in the file path. This error message occurs when you save or open a file if the path to the file (including the file name) exceeds 218 characters. This limitation includes three characters representing the drive, the characters in folder names, the backslash character between folders, and the characters in the file name.
Make sure that the path to the file contains fewer than 219 characters. To do this, use one of the following methods:
Rename the file so that it has a shorter name.
Rename one or more folders that contain the file so that they have shorter names.
Move the file to a folder with a shorter path name.
Note that if you enter 255 characters in the File Name box in the
Save As dialog box, and click OK, you will receive the following error message:
The path you entered, "<path>", is too long. Enter a shorter path.
Also, if you attempt to save a file and the path exceeds 255 characters, you will receive the following error message:
The file could not be accessed. Try one of the following:
- Make sure the specified folder exists.
- Make sure the folder that contains the file is not read-only.
- Make sure the file name does not contain any of the following characters: < > ? [ ] : | *.
- Make sure the file/path name doesn't contain more than 218 characters.
The following code does not find the file:
xTempTmtl = "Z:\20.0 Global storage\20.1 Design Packages*" & xNewName
where xNewName = "SLR-D&C-MI0-000-TRS-007199.Pdf"
but
xTempFol = Dir("Z:\20.0 Global storage\20.1 Design Packages\DP01.1 Stops - Zone C (North)\02. Transmittals\" & xNewName)
finds the file.
Problem is that the file xNewName could be in any one of 80 folders(Dp01.1..., DP01.2....) etc, then in \02. Transmittals\
If I put a \ after the *, I get Bad file name error.
Why is the wildcard "*" not recognized?
This happens on two separate machines, one running EXCEL2010 on a Windows& PC and the other running EXCEL365 on a Windows10 laptop.
Wildcards are used to return all file or folder names in a directory. Using the Dir() function with parameters changes the path in which the function will search for files. Subsequent calls to the Dir() function will return the next file or folder after the previous call. The Dir() will not search subdirectories for a file.
You will need to do a recursive set the Dir() Attributes parameter to vbDirectory to return the subfolder names then search each subfolder.
You can find plenty of examples that use the FileSystemObject to recursively search subfolder for a file. I thought that it would be interesting to write one that uses the Dir() function.
Function FindFile(ByVal folderName As String, ByVal FileName As String, Optional ByRef FoundFile As String) As String
Dim search As String
Dim dirList As New Collection
If Not Right(folderName, 1) = "\" Then folderName = folderName & "\"
search = Dir(folderName & "\*", vbDirectory)
While Len(search) > 0
If Not search = "." And Not search = ".." Then
If GetAttr(folderName & search) = 16 Then
dirList.Add folderName & search
Else
If LCase(search) = LCase(FileName) Then
FoundFile = folderName & FileName
FindFile = FoundFile
Exit Function
End If
End If
End If
search = Dir()
Wend
Dim fld
For Each fld In dirList
If Len(FoundFile) > 0 Then
FindFile = FoundFile
Exit Function
Else
FindFile = FindFile(CStr(fld), FileName, FoundFile)
End If
Next
End Function
I wanted to copy a local file to sharepoint library using VBA by clicking an image. Right now seems like I'm unable to check for Folder & Files on SharePoint.
As every time I ran the code(by clicking an image in excel), it returns unable to find the file in SharePoint. And stops at returning the MsgBox Sorry there's no such Folder......
I tried mapping drive, it works perfectly fine, but not an options because end-user need to map the drive by themselves.
So now I'm looking to connecting to SharePoint using the link.
If I copy the SharePointLink to IE & Chrome using \, it works fine. But if I uses /, IE is unable to find the link.
UPDATE
If I uses \ after few tries, IE, will open up the file path in NetWork. Chrome will show the file path on chrome page. Why is this happening?????
The authentication is using windows authentication, so not an issue.
This is my code
Sub imgClicked()
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim FSO As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
SharePointLib = "//company.com/sites/MS/10%20Mg%20Review/"
' create new folder to store the file
copyPath = folderPath + "\copyPath\"
If Not FolderExists(copyPath) Then
FolderCreate (copyPath)
ElseIf Not FolderExists(SharePointLib) Then
MsgBox "Sorry there's no such folder. Folder Path: " & vbNewLine & vbNewLine & SharePointLib & ""
Exit Sub
End If
fileName = "hello.xlsm"
'Copy current excel file and save at the new folder created
ThisWorkbook.SaveCopyAs copyPath & fileName
MsgBox "Save Copy As: " + copyPath & filseName & vbNewLine & vbNewLine & "The file will be uploaded to this address: " + SharePointLib & fileName
' Check whether the file exist in the directory
' If exist error message
' else copy the file from copyPath then paste at the SharePoint directory
If Not Dir(SharePointLib & fileName, vbDirectory) = nbNullString Then
MsgBox "Sorry file already exist!"
Else
Call FileCopy(copyPath & fileName, SharePointLib & fileName)
MsgBox "File has being successfuly created in SharePoint!"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If Right(copyPath, 1) = "\" Then
copyPath = Left(copyPath, Len(copyPath) - 1)
End If
If FSO.FolderExists(copyPath) = False Then
MsgBox copyPath & " doesn't exist"
Exit Sub
End If
FSO.DeleteFolder copyPath
MsgBox "Folder has being deleted successfully!"
End Sub
Function for checking if folder exists
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim FSO As New FileSystemObject
If FSO.FolderExists(path) Then FolderExists = True
End Function
Function for creating Folder
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim FSO As New FileSystemObject
try:
If FSO.FolderExists(path) Then
Exit Function
Else
On Error GoTo catch
FSO.CreateFolder path
Debug.Print "FolderCreate: " & vbTab & path
Exit Function
End If
catch:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Any help and suggestions are appreciated. Let me know if more info is needed. Thanks in advance.
Ensure the WebClient service is running. You can start the WebClient service through code, or you could set the startup type to automatic.
With the WebClient service running, your folder/file tests will work as expected.
Edit: Additionally, if you map the sharepoint url to a drive letter, Windows will start the WebClient service.
Sub mapPath(str_drive as string, str_path as string)
If Not Len(str_drive) = 1 Then Exit Sub
Dim wso As Object
Set wso = CreateObject("WScript.Network")
wso.MapNetworkDrive str_drive & ":", str_path, False
End Sub
In vba, I would like to search through directories for a specific directory name. Ideally the searching time would be fast (similar from a windows search).
from different sources, I could build a script (given bellow) with a recursive sub program. The script works but it is very slow as soon as the hierarchy is a little complex.
Is there a way to make the search faster?
Sub GetFolder(Folder As String, searchF As String, colFolder As Collection)
Dim SubFolder, subF As New Collection, sf As String
If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
If Dir(Folder & searchF, vbDirectory) <> "" Then colFolder.Add Folder & searchF & "\"
sf = Dir(Folder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(Folder & sf) And vbDirectory) <> 0 Then
subF.Add Folder & sf
End If
End If
sf = Dir()
Loop
For Each SubFolder In subF
GetFolder CStr(SubFolder), searchF, colFolder
Next
End Sub
I think you are underestimating the hierarchy size. Change your code to this one to see how many folders you are recursing through.
Option Explicit
Sub GetFolder(Folder As String, searchF As String, colFolder As Collection, ByRef counter As Long)
Dim SubFolder, subF As New Collection, sf As String
If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
If Dir(Folder & searchF, vbDirectory) <> "" Then colFolder.Add Folder & searchF & "\"
sf = Dir(Folder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(Folder & sf) And vbDirectory) <> 0 Then
Debug.Print Folder & sf
counter = counter + 1
subF.Add Folder & sf
End If
End If
sf = Dir()
Loop
For Each SubFolder In subF
GetFolder CStr(SubFolder), searchF, colFolder, counter
Next
End Sub
Public Sub TestMe()
Dim newC As New Collection
Dim colChecked As New Collection
Dim counter As Long
GetFolder "C:\Users\<username>\Desktop\BA Tools", "v", newC, counter
Debug.Print counter
End Sub
What is the number that you get at the end of the code, when you run it?
On a monthly basis I have to aggregate daily files. The issue is I need the files to be in "TXT", but they are sent to me as "WRI".
I am able to do one file at a time if it is hardcoded with the following.
Name "C:\Users\John\Desktop\Folder1\SQLEXEC.WRI" As "C:\Users\John\Desktop\Folder1\SQLEXEC.TXT"
However, I want to be able to loop through the folder. But I am not sure how to change the code to allow it to loop.
Sub ConvertToTXT()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim strPath As String
Dim strFile As String
strPath = "C:\Users\John\Desktop\Folder1\" strFile = Dir(strPath & "*.wri")
Do While strFile <> ""
Name "C:\Users\John\Desktop\Folder1\SQLEXEC.WRI" As "C:\Users\John\Desktop\Folder1\SQLEXEC.TXT"
Loop
End Sub
I'd personally use the Scripting.FileSystemObject for this - it's much less prone to errors than manually building filepath strings. You'll need to add a reference to Microsoft Scripting Runtime:
Private Sub ConvertToTXT(filePath As String)
With New Scripting.FileSystemObject
Dim directory As Folder
Set directory = .GetFolder(filePath)
Dim target As File
For Each target In directory.Files
If LCase$(.GetExtensionName(target.Name)) = "wri" Then
Dim newName As String
newName = .BuildPath(filePath, .GetBaseName(target.Name)) & ".txt"
.MoveFile target.Path, newName
End If
Next
End With
End Sub
Call it by passing it the directory you want to perform the renaming in:
ConvertToTXT "C:\Users\John\Desktop\Folder1"
Note that is doesn't care if there's a trailing \ or not - this also works:
ConvertToTXT "C:\Users\John\Desktop\Folder1\"
Sub ConvertToTXT()
Const strPath As String = "C:\Users\John\Desktop\Folder1"
Dim strFile As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
strFile = Dir(strPath & "\" & "*.wri")
Do While strFile <> ""
Name strPath & "\" & strFile As strPath & "\" & Replace(strFile, ".wri", ".txt")
strFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub