My goal is to read the FileNames of all png files in a given folder.
I've Windows VBA code which uses the ActiveX FileSystemObject.
On a MAC This code results in
"runtime error 429 activex component can't create object"
Function ReadFileNames(ByVal sPath As String) As Integer
Dim oFSO, oFolder, oFile As Object
Dim sFileName As String
Set oFSO = CreateObject("scripting.FileSystemObject")
Set oFolder = oFSO.getfolder(sPath)
For Each oFile In oFolder.Files
If Not oFile Is Nothing And Right(LCase(oFile.Name), 4) = ".png" Then ' read only PNG-Files
sFileName = oFile.Name
' do something with the FileName ...
End If
Next oFile
End Function
Here is a sub, using the native VBA DIR command, listing EXCEL workbooks in a folder by printing their names on the debug window:
Public Sub DirXlList()
Const cstrPath As String = "c:\users\xxxx\misc\"
Dim strDirItem As String
strDirItem = Dir(cstrPath & "*.xlsx")
While strDirItem <> ""
Debug.Print "FileName: " & strDirItem, "FullPath: " & cstrPath & strDirItem
strDirItem = Dir()
DoEvents
Wend
End Sub
Does this help? In
Update: doevents command allows Excel to process other pending user interface activities, such as window refreshes, mouse-clicks. If you have lots of files (thousands) in a folder, Excel may appear unresponsive/frozen in a loop like this. It is not necessary, as it will become responsive again, once it completes the loop. If you have only a few hundred files then it is an overkill. Remove and try.
VBA for Mac can link to the entire c standard library, like this example:
Private Declare PtrSafe Function CopyMemory_byPtr Lib "libc.dylib" Alias "memmove" (ByVal dest As LongPtr, ByVal src As LongPtr, ByVal size As Long) As LongPtr
I'm too lazy to write out relevant examples for you, but if, by chance, you are familiar with using the c standard library for file manipulation, you can just do it that way.
Related
So here's the scenario. Everyday, there is a Zip file created called "Bundle_06112018063917" (The numbers are the date and time at which the zip is created, therefore they change everyday).
The code below extracts all the files into a separate folder beautifully!
Sub UnzipAFile(zippedFileFullName As Variant, unzipToPath As Variant)
Dim ShellApp As Object
'Copy the files & folders from the zip into a folder
Set ShellApp = CreateObject("Shell.Application")
ShellApp.Namespace(unzipToPath).CopyHere
ShellApp.Namespace(zippedFileFullName).items
End Sub
Sub Dump()
Call UnzipAFile("G:\DP\Mstanley\history\JUN18\WESTROCK\Bundle_06112018063917.zip", _
"G:\DP\Mstanley\history\JUN18\WESTROCK\Dump")
End Sub
The Problem:
The name of the zip file changes everyday based on the date and time in which the zip is created. Therefore I need a way to refer to zip file with just "Bundle_".
Below is what I tried, but still no luck.
Sub doingstuff()
Dim pSTR As String
Dim strFile As String
Dim WB As Workbook
Dim dirFile As String
pSTR = "G:\DP\Mstanley\history\JUN18\WESTROCK\"
strFile = "Bundle_" & "*" & ".zip"
dirFile = Dir(pSTR & strFile)
Call UnzipAFile(dirFile, "G:\DP\Mstanley\history\JUN18\WESTROCK\Dump")
End Sub
Any ideas/help would be much appreciated!
You need to loop through all the files and do whatever you want to the files that you want to handle.
When you're done, move the file to an archive folder.
Dim di As DirectoryInfo = New DirectoryInfo("C:\ExampleDir\")
For Each fi In di.GetFiles()
' Unzip file file
' do stuff to the contents
' move the file to an archive folder
Next
I changed the signature of your UnzipAFile sub. Do you really want to accept any variable type or do you want strings?
This will search a folder for the latest "Bundles_" file and unzip that one. I couldn't make sense of the "date" at the end of the bundles files so I'm using the Date Modified on the zip file itself.
This solution required a reference to Microsoft Scripting Runtime (the scrrun.dll file)
Sub UnzipLatest(bundlesFolder As String, unzipToPath As String)
Dim fil As File, fol As Folder
Dim fso As New FileSystemObject
Dim latestDate As Date, latestFile As String, latestBundleFileFound As Boolean
If Not fso.FolderExists(bundlesFolder) Then Exit Sub
Set fol = fso.GetFolder(bundlesFolder)
For Each fil In fol.Files
If fil.Name Like "*Bundles_*" Then
latestBundleFileFound = True
If fil.DateLastModified > latestDate Then
latestDate = fil.DateLastModified
latestFile = fil.path
End If
End If
Next
If latestBundleFileFound Then
UnzipAFile latestFile, unzipToPath
End If
End Sub
Sub UnzipAFile(zippedFileFullName As String, unzipToPath As String)
End Sub
I am trying to search through a directory for Shortcuts, get the path for the Shortcut, and add those paths to a collection, for later usage. However subsequent calls to Dir() returns the same file over and over again. I have isolated the problem to being caused by calling the Function Getlnkpath defined below. This function I haven't written myself, so I am unsure exactly what is causing this behaviour, or how to fix it.
tempPath = Dir(startPath & "*.lnk")
Do Until tempPath = vbNullString
myCollection.Add Getlnkpath(startPath & tempPath) & "\"
tempPath = Dir()
Loop
Function Getlnkpath(ByVal Lnk As String)
On Error Resume Next
With CreateObject("Wscript.Shell").CreateShortcut(Lnk)
Getlnkpath = .TargetPath
.Close
End With
End Function
It might be safer to
first: collect all links paths
then: collect all link target paths
so that the first collection stays stable whatever the subsequent operations may do (unless they delete some link or some folder...)
moreover I'd suggest to initialize one Wscript.Shell object only and handle all calls to its CreateShortcut() with it, instead of instantiating one object for each link
finally I myself am drifting towards the use of FileSystemObject in lieu of Dir() function, due to problems I sometimes meet with the latter. this at the only expense of adding the reference to Microsoft Scripting Runtime library
for what above I propose the following code:
Option Explicit
Sub main()
Dim startPath As String
Dim myLinkTargetPaths As New Collection, myLinkFilePaths As Collection
startPath = "C:\myPath\"
Set myLinkFilePaths = GetLinksPaths(startPath) 'first get the collection of all links path
Set myLinkTargetPaths = GetLinksTarget(myLinkFilePaths) ' then get the collection of all links TargetPaths
End Sub
Function GetLinksTarget(myLinkFilePaths As Collection) As Collection
Dim myColl As New Collection
Dim element As Variant
With CreateObject("Wscript.Shell")
For Each element In myLinkFilePaths
myColl.Add .CreateShortcut(element).TargetPath & "\"
Next element
End With
Set GetLinksTarget = myColl
End Function
Function GetLinksPaths(startPath As String) As Collection
Dim objFso As FileSystemObject '<~~ requires adding reference to `Microsoft Scripting Runtime` library
Dim objFile As File
Dim objFolder As Folder
Dim myColl As New Collection
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(startPath)
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) = "lnk" Then myColl.Add objFile.Path
Next
Set GetLinksPaths = myColl
End Function
instead, should you want to go on with Dir() function then just change the GetLinksPaths() function as follows:
Function GetLinksPaths(startPath As String) As Collection
Dim tempPath As String
Dim myColl As New Collection
tempPath = Dir(startPath & "*.lnk")
Do Until tempPath = vbNullString
myColl.Add startPath & tempPath
tempPath = Dir()
Loop
Set GetLinksPaths = myColl
End Function
BTW: the CreateObject("Wscript.Shell").CreateShortcut(Lnk) method returns and object (either a WshShortcut or a WshURLShortcut one) that doesn't support any Close() method as you have in your Getlnkpath() function. So remove it to remove the necessity of On Error Resume Nextstatement
Looks like you are creating a new .lnk file with your function and your dir command finds that newly created link (that has overwritten the old one) next. Try to use GetShortcut instead of CreateShortcut in your function.
I need to add text string to all files on a folder, as a footer
For example, on the folder on the path and called C:\mobatchscripts\
I have a random number of txt files, with text.
I want to add a line for example "text" on each of the text files on the folder
I have little knowledge of vba programming, but for what I have read I can use append, but I need something that loop on the files on the folder, and modify them.
So far I tried this:
Sub footer()
Dim FolderPath As String
Dim FileName As String
Dim wb As Excel.Workbook
FolderPath = "C:\mobatchscripts\"
FileName = Dir(FolderPath)
Do While FileName <> ""
Open FileName For Append As #1
Print #1, "test"
Close #1
FileName = Dir
Loop
End Sub
But seems that its not looking into the files, or appending the text.
On the assumption that you're writing to text files (I see "batchscripts" in the path), you need a reference to the Microsoft Scripting Runtime (Within the VBE you'll find it in Tools, References)
Option Explicit
Public Sub AppendTextToFiles(strFolderPath As String, _
strAppendText As String, _
blnAddLine As Boolean)
Dim objFSO As FileSystemObject
Dim fldOutput As Folder
Dim filCurrent As File
Dim txsOutput As TextStream
Set objFSO = New FileSystemObject
If objFSO.FolderExists(strFolderPath) Then
Set fldOutput = objFSO.GetFolder(strFolderPath)
For Each filCurrent In fldOutput.Files
Set txsOutput = filCurrent.OpenAsTextStream(ForAppending)
If blnAddLine Then
txsOutput.WriteLine strAppendText
Else
txsOutput.Write strAppendText
End If
txsOutput.Close
Next
MsgBox "Wrote text to " & fldOutput.Files.Count & " files", vbInformation
Else
MsgBox "Path not found", vbExclamation, "Invalid path"
End If
End Sub
I'd recommend adding error handling as well and possibly a check for the file extension to ensure that you're writing only to those files that you want to.
To add a line it would be called like this:
AppendTextToFiles "C:\mobatchscripts", "Test", True
To just add text to the file - no new line:
AppendTextToFiles "C:\mobatchscripts", "Test", False
Alternatively, forget the params and convert them to constants at the beginning of the proc. Next time I'd recommend working on the wording of your question as it's not really very clear what you're trying to achieve.
I need to read all the item titles for all the documents in a SharePoint document library directly into an Array using Excel VBA. I can't seem to successfully use FileSystemObject and I do not want to map the document library to a drive letter as the macro will be distributed and widely used.
The SharePoint site has an https address
I have looked at this thread about referencing scrrun.dll but it does not work because I cannot change the trust settings on my local domain
This thread looked promising, but again it seems to use FileSystemObject which might be my hang up.
This thread on the SharePoint stackexchange site works well for reading in a list of files as a worksheet object, but I don't know how it could be adapted to be pushed directly into an array.
I tend to receive Error 76 "Bad Path", but I am easily able to execute on local (C:) files.
I have tried using a WebDAV address - like the answer I gave to this thread - but it too encounters a "Bad Path" error.
There must be a way to read in the contents of a SharePoint document library directly into an array that does not violate my local security policies and doesn't depend upon an excel worksheet.
Ok I am going to self answer. I'm not 100% thrilled with my solution, but it does suffice within my constraints. Here are the high level points:
Use VBA to create BAT files that have the "Net Use" command within them.
Reference the WebDAV address of the document library and find an available drive letter
I doubt that any of my users already have 26 mapped drives...).
Once the document library is mapped it can be iterated through using FileSystemObject commands and the item titles can be loaded into a two dimensional array.
The code will have to be modified to allow for 3 the listing of subfolders
The location of the file count in the ListMyFiles sub would have to be changed or another dimension would have to be added to the array.
Here is the code - I will try to credit all Stack solutions that were integrated into this answer:
Private Sub List_Files()
Const MY_FILENAME = "C:\BAT.BAT"
Const MY_FILENAME2 = "C:\DELETE.BAT"
Dim i As Integer
Dim FileNumber As Integer
Dim FileNumber2 As Integer
Dim retVal As Variant
Dim DriveLetter As String
Dim TitleArray()
FileNumber = FreeFile
'create batch file
For i = Asc("Z") To Asc("A") Step -1
DriveLetter = Chr(i)
If Not oFSO.DriveExists(DriveLetter) Then
Open MY_FILENAME For Output As #FileNumber
'Use CHR(34) to add escape quotes to the command prompt line
Print #FileNumber, "net use " & DriveLetter & ": " & Chr(34) & "\\sharepoint.site.com#SSL\DavWWWRoot\cybertron\HR\test\the_lab\Shared Documents" & Chr(34) & " > H:\Log.txt"
Close #FileNumber
Exit For
End If
Next i
'run batch file
retVal = Shell(MY_FILENAME, vbNormalFocus)
' NOTE THE BATCH FILE WILL RUN, BUT THE CODE WILL CONTINUE TO RUN.
'This area can be used to evaluate return values from the bat file
If retVal = 0 Then
MsgBox "An Error Occured"
Close #FileNumber
End
End If
'This calls a function that will return the array of item titles and other metadata
ListMyFiles DriveLetter & ":\", False, TitleArray()
'Create code here to work with the data contained in TitleArray()
'Now remove the network drive and delete the bat files
FileNumber2 = FreeFile
Open MY_FILENAME2 For Output As #FileNumber2
Print #FileNumber2, "net use " & DriveLetter & ": /delete > H:\Log2.txt"
Close #FileNumber2
retVal = Shell(MY_FILENAME2, vbNormalFocus)
'Delete batch file
Kill MY_FILENAME
Kill MY_FILENAME2
End Sub
Here is the function that will read through the directory and return the array of file information:
Sub ListMyFiles(mySourcePath As String, IncludeSubFolders As Boolean, TitleArray())
Dim MyObject As Object
Dim mySource As Object
Dim myFile As File
Dim mySubFolder As folder
Dim FileCount As Integer
Dim CurrentFile As Integer
'Dim TitleArray()
Dim PropertyCount As Integer
CurrentFile = 0
Set MyObject = New Scripting.FileSystemObject
Set mySource = MyObject.GetFolder(mySourcePath)
FileCount = mySource.Files.Count
ReDim TitleArray(0 To FileCount - 1, 4)
'On Error Resume Next
For Each myFile In mySource.Files
PropertyCount = 1
TitleArray(CurrentFile, PropertyCount) = myFile.Path
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.Name
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.Size
PropertyCount = PropertyCount + 1
TitleArray(CurrentFile, PropertyCount) = myFile.DateLastModified
CurrentFile = CurrentFile + 1
Next
'The current status of this code does not support subfolders.
'An additional dimension or a different counting method would have to be used
If IncludeSubFolders = True Then
For Each mySubFolder In mySource.SubFolders
Call ListMyFiles(mySubFolder.Path, True, TitleArray())
Next
End If
End Sub
Thank you to Chris Hayes for his answer to find empty network drives; thank you to Kenneth Hobson on ozgrid for his expanded answer on listing files in a directory. The rest of the code is ancient and I dredged it out of a folder I last touched in 2010.
Not sure why but the following code has begun to throw an unknown error. When the macro is run Excel stops responding.
Why is this error occuring?
What is an alternative route with the same functionality?
This code is located within an Excel 2010 xlsm file on a Windows 7 machine.
Sub CopyFolderToCasinoDirectory()
'reference Microsoft Scripting Runtime
On Error Resume Next
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
fso.CopyFolder _
"\\xxxfileserve\department$\DBA\Opers\All Operators\yyy", _
"\\xxxfileserve\department$\DBA\Cas\yyy", _
True
On Error GoTo 0
Set fso = Nothing
End Sub
ok - I've changed the pathways so that it is attempting to move less files - and it hesitates but does eventually run through. I suspect that the above is failing because there are too many files in the directory specified? Currently there are 753 files - maybe too much?
RonDeBruin has given me lots of ideas of how to test or alter the logic. One possibility might be to use DeleteFolder first on the destination folder, and then CopyFolder the target folder over?
Sorry for replying so late. I was not able to get hold of network directories and I wanted to test the code before posting it :)
Try this. Run the Sub Sample() Does it still hang? You will also see the Files getting transferred in a Windows Dialog Box.
Private Declare Function SHFileOperation _
Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Private Const FO_COPY = &H2
Sub Sample()
Dim path1 As String, path2 As String
path1 = "\\xxxfileserve\department$\DBA\Opers\All Operators\yyy"
path2 = "\\xxxfileserve\department$\DBA\Opers\All Operators\yyy"
If CopyFolder(path1, path2) Then
MsgBox "Copied"
Else
MsgBox "Not copied"
End If
End Sub
Private Function CopyFolder(ByVal sFrom As String, _
ByVal sTo As String) As Boolean
Dim SHFileOp As SHFILEOPSTRUCT
On Error GoTo Whoa
CopyFolder = False
With SHFileOp
.wFunc = FO_COPY
.pFrom = sFrom
.pTo = sTo
End With
SHFileOperation SHFileOp
CopyFolder = True
Exit Function
Whoa:
MsgBox "Following error occurred while copying folder " & sFrom & vbCrLf & _
Err.Description, vbExclamation, "Error message"
End Function
There are some points regarding the fso.CopyFolder method:
If destination does not exist, the source folder and all its contents gets copied. This is the usual case.
If destination is an existing file, an error occurs.
If destination is a directory, an attempt is made to copy the folder and all its contents.
If a file contained in source already exists in destination, an error occurs if overwrite is False. Otherwise, it will attempt to copy the file over the existing file.
If destination is a read-only directory, an error occurs if an attempt is made to copy an existing read-only file into that directory and overwrite is False.
Make sure not any of these are becoming hindrance for your sub.
But test it another way like this
fso.CopyFolder _
"\\xxxfileserve\department$\DBA\Opers\All Operators\yyy\*", _
"\\xxxfileserve\department$\DBA\Cas\yyy", _
True
Hope this helps.