I am trying to create code that will essentially "crawl" from subfolder to subfolder, and find and insert a designated picture.
I've got this bit of working code, which inserts the pic:
Set picture = ActiveSheet.Pictures.Insert(path & "\" & picname & ".jpg")
picture.Select
If I were to put this in a loop, what methods would I need? Reading up on this, I have found lots of related topics, but all are very specific cases with long-winded, extraneous code, making it very hard for a beginner like me to isolate the parts relevant to getting from folder to folder.
I appreciate your time, and thanks in advance for the help.
Something like:
Sub CrawlFolder(ByVal path as String, ByVal picname as String)
Dim file
Dim fs As New FileSystemObject
Dim subdir As Folder
Dim thisdir As Folder
file = Dir(path)
While (file <> "")
Set picture = ActiveSheet.Pictures.Insert(path & "\" & picname & ".jpg")
picture.Select
file = Dir
Wend
Set thisdir = fs.GetFolder(path)
For Each subdir In thisdir.SubFolders
CrawlFolder(subdir)
End Sub
Not tested, just ideas for you to explore based on what I read here, with Tim's help :)
Related
I got this code from an online source and cant figure out what I have to change, for it to work, the folders are not being created in the desired location and I am unaware of where they are be created if any where?
Within the excel I have 3 command buttons, one to save the file to a specified location, one to email it to a collegue and lastly the command button which I am having issue with. Ill include images below.
And is it possible to cause a chain reaction between the codes, that once one is completed then the other will begin, as I can get them to work as they are on there own atm.
enter image description here
Mkdir can only create a single directory. You are trying to make two by supplying "9999 William Cox ltd\BRAKEL".
Make "9999 William Cox ltd" first, then make its child directories.
Here is some code that will generate all of the sub directories via a loop:
Add these functions to your code module:
Private Function makeDir(parentDir As String, childDir As String) As String
'Checks if supplied directory name exists in current path, if not then create.
childDir = parentDir & _
IIf(Left(childDir, 1) = "\", "", "\") & _
childDir & _
IIf(Right(childDir, 1) = "\", "", "\")
On Error Resume Next
MkDir childDir
On Error GoTo 0
makeDir = childDir
End Function
Public Sub makePath(parentDir As String, childPath As String)
Dim i As Integer
Dim subDirs As Variant
Dim newdir As String
Dim fPath As String
fPath = parentDir
subDirs = Split(childPath, "\")
For i = 0 To UBound(subDirs)
newdir = subDirs(i)
fPath = makeDir(fPath, newdir)
Next i
End Sub
Then replace this:
MkDir ("T:\Estimating\William Cox Project Enquiries 2018\" & fPath)
If Err.Number <> 0 Then
Err.Clear
End If
With this:
makePath "T:\Estimating\William Cox Project Enquiries 2018\", fpath
You should also remove On Error Resume Next so that you can catch any other errors - Another of which might be in your path (per the screenshot) which has "T:\Estimating" twice at the beginning.
I have a macro that executes and creates a PDF file. Each time the macro is run, a PDF is generated. I would like to move the last version of the report (run three times per day) to a folder titles 'Past Reports'. I have been playing around with the script below but it does not work for me. The Active Report folder only contains the most recent PDF created.
Can anyone offer help? Happy to add more info if needed.
Public Sub transferFile()
On Error GoTo nextIt
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
PDFPath = "D:\####\Pinging Program\Active Report\"
pastPDFPath = "D:\####\Pinging Program\Past Reports"
sSourceFile = PDFPath & Dir(PDFPath & "*.pdf")
sDestinationFile = "D:\####\Pinging Program\Past Reports"
'move file
If Dir(sSourceFile) <> "" Then
fileSystemObject.moveFile sSourceFile, sDestinationFile
End If
nextIt:
End Sub
Your destination folder is missing the final slash. Also as a suggestion for the future the error would have been a lot easier to understand if you weren't bypassing error handling as Victor had suggested. Your code would look like:
Public Sub transferFile()
Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
PDFPath = "C:\test\Active Report\"
pastPDFPath = "C:\test\Past Reports"
sSourceFile = PDFPath & Dir(PDFPath & "*.pdf")
sDestinationFile = "C:\test\Past Reports\"
'move file
If Dir(sSourceFile) <> "" Then
fileSystemObject.moveFile sSourceFile, sDestinationFile
End If
End Sub
I have tested it and it worked as expected. Regards,
This seems so simple and I've had it working multiple times, but something keeps breaking between my Dir call (to iterate through a directory) and opening the current file. Here's the pertinent code:
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
'Start looping through directory
While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceCurrentFile)
What I get with this is a file access error as the Application.Workbooks.Open is trying to open "C:\ExcelWIP\TestSource\\FILENAME" (note extra slash)
However when I take the final slash out of SourceLoc, the results of Dir(SourceLoc) are "" (it doesn't search the directory).
The frustrating thing is that as I've edited the sub in other ways, the functionality of this code has come and gone. I've had it work as-is, and I've had taking the '/' out of the directory path make it work, and at the moment, I just can't get these to work right together.
I've scoured online help and ms articles but nothing seems to point to a reason why this would keep going up and down (without being edited except for when it stops working) and why the format of the directory path will sometimes work with the final '/' and sometimes without.
any ideas?
This would open all .xlxs files in that directory son.
Sub OpenFiles()
Dim SourceCurrentFile As String
Dim FileExtension as String: FileExtension = "*.xlxs"
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
SourceCurrentFile = Dir()
'Start looping through directory
Do While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceLoc &"\"& SourceCurrentFile)
SourceCurrentFile = Dir(FileExtension)
Loop
End Sub
JLILI Aman hit on the answer which was to take the results of Dir() as a string. Using that combined with the path on Application.Open allows for stable behaviors from the code.
New Code:
Dim SourceLoc as String
Dim SourceCurrentFile as String
SourceLoc = "C:\ExcelWIP\TestSource\"
SourceCurrentFile = Dir(SourceLoc)
'Start looping through directory
While (SourceCurrentFile <> "")
Application.Workbooks.Open (SourceLoc & "/" & SourceCurrentFile)
I didn't include the recommended file extension because I'm dealing with xls, xlsx, and xlsm files all in one directory. This code opens all of them.
Warning - this code will set current file to each file in the directory including non-excel files. In my case, I'm only dealing with excel files so that's not a problem.
As to why this happens, it does not appear that Application.Open will accept the full object results of Dir(), so the return of Dir() needs to be a String. I didn't dig deeper into the why of it beyond that.
Consider using VBA's FileSystemObject which includes the folder and file property:
Sub xlFilesOpen()
Dim strPath As String
Dim objFSO As Object, objFolder As Object, xlFile As Object
strPath = "C:\ExcelWIP\TestSource"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
For Each xlFile In objFolder.Files
If Right(xlFile, 4) = "xlsx" Or Right(xlFile, 3) = "xls" Then
Application.Workbooks.Open (xlFile)
End If
Next xlFile
Set objFSO = Nothing
Set objFolder = Nothing
End Sub
I need to read a txt file but I don't have the path. The text file is two directories before the path of the script I'm running. I thought I could use "WScript.ScriptFullName" and then just use an instrRev and make it split the str at "/". But It doesn't work Could you guys help me with that. I have to run this on multiple computers so the path changes but the text file will always be two derictories above the script path
My code so far
Dim strScriptPath
strScriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
WScript.Echo strScriptPath
WScript.Echo(WScript.ScriptFullName)
Dim DashRev
DashRev = instrRev(WScript.ScriptFullName, "/")
wscript.echo DashRev
First replace the "/" with "\"
Then try the following. This seems to work for me:
Dim strScriptPath
strScriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
WScript.Echo strScriptPath
WScript.Echo(WScript.ScriptFullName)
Dim first, sec
first = instrRev(strScriptPath, "\",Len(strScriptPath)-1)
sec = instrRev(WScript.ScriptFullName, "\",first-1)
wscript.Echo "parent = " & Left(strScriptPath,sec)
The idea being that strScriptPath is always going to end in "\" and first is going to exclude that from the instrrev by using the starting position of one less than the length of the path. Same thing essentially with sec.
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
WScript.Echo FSO.GetFile(WScript.ScriptFullName).ParentFolder.ParentFolder.ParentFolder.Path
Hope you are well.
I'm trying to create a mass folder creator using Excel and vba. It's my first time using VBA as I usually focus on web-based languages so forgive me for my lack of knowledge in advance. I have some code already it's just putting the finishing touches that I'm struggling with.
Currently, the user specifies a directory in a given cell and name of the parent file in another cell. Upon clicking a button, the macro creates the parent folder using the directory and name from the parent file cell. It then creates sub folders using the values of any cells the respondent has selected upon running the macro.
I am currently struggling with the next stage of the project which is creating sub-folders (I'll just call them Grandchildren) within the subfolders. This would be easy if all of the subfolders had the same Grandchildren however, this is not the case. What I would like to do is grab the 3 values to the right of each cell which defines the name of the subfolder and use them to create the Grandchildren however I'm currently getting the 'Invalid Qualifier' message with the code I am currently using (see below).
BasePath = Range("folder_path")
'Check if the project folder already exists and if so raise and error and exit
If Dir(BasePath, vbDirectory) <> "" Then
MsgBox BasePath & " already exists", , "Error"
Else
'Create the project folder
MkDir BasePath
MsgBox "Parent folder creation complete"
'Loop through the 1st tier subfolders and create them
For Each c In ActiveWindow.RangeSelection.Cells
'create new folder path
NewFolder = BasePath & "\" & c.Value
'create folder
If fs.folderexists(NewFolder) Then
'do nothing
Else
MkDir NewFolder
End If
Next c
'Create GrandChildren
For Each d In ActiveWindow.RangeSelection.Cells
'Offset the selection to the right
For Each e In d.Offset(0, 1).Resize(1, 3).Cells
Test = e.Value
GrandChild = BasePath & "\" & d.Value & "\" & Test
If fs.folderexists(GrandChild) Then
'do nothing
Else
MkDir GrandChild
End If
Next e
Next d
MsgBox "Sub-folder creation complete"
End If
End Sub
If you require any further information please let me know.
Cheers,
Jason
I think your problem is here
Test = d.Offset(0, 1).Select
Test is a String and you are selecting a cell. You should try this:
Test = d.Offset(0,1).Value
You may find this useful, it's a simple routine I use to make ALL the folders in an entire path fed into the function.
EXAMPLE:
C:\2011\Test\
C:\2012\Test
C:\2013\Test\DeepTest\
C:\2014\Test\DeeperTest\DeeperStill
Based on the list above, this macro will attempt to create 11 directories, ones that exist already...no problem.
Option Explicit
Sub MakeDirectories()
'Author: Jerry Beaucaire, 7/11/2010
'Summary: Create directories and subdirectories based
' on the text strings listed in column A
' Parses parent directories too, no need to list separately
' 10/19/2010 - International compliant
Dim Paths As Range
Dim Path As Range
Dim MyArr As Variant
Dim pNum As Long
Dim pBuf As String
Dim Delim As String
Set Paths = Range("A:A").SpecialCells(xlConstants)
Delim = Application.PathSeparator
On Error Resume Next
For Each Path In Paths
MyArr = Split(Path, Delim)
pBuf = MyArr(LBound(MyArr)) & Delim
For pNum = LBound(MyArr) + 1 To UBound(MyArr)
pBuf = pBuf & MyArr(pNum) & Delim
MkDir pBuf
Next pNum
pBuf = ""
Next Path
Set Paths = Nothing
End Sub
There is a UDF version too and a sample file for testing found here. FYI.