I'm trying to select around 17k files in a specific folder containing around 22k from a list in excel. The list has the name and extension of all files and nothing more.
I've tried this code but no luck.
Sub DeletePics()
Dim picRNG As Range, pic As Range, picPATH As String
picPATH = "path"
Set picRNG = Sheets("Sheet1").Range("A1:A17108").SpecialCells(xlConstants)
On Error Resume Next
For Each pic In picRNG
If pic.Offset(, 1) = "Delete" Then
If Len(Dir(picPATH & pic.Value)) > 0 Then
Kill picPATH & pic.Value
pic.Offset(, 2).Value = "Deleted"
Else
pic.Offset(, 2).Value = "Not Found"
End If
End If
Next pic
End Sub
Related
Original question:
I am quite unskillful with VBScript but would need an efficient solution for saving me lots of time selecting and copying files manually:
I have a folder with thousands raster files containing values of daily temperature for a certain area, altogether covering a period of 30 years.
In order to calculate monthly means out of 30 or 31 files per month (within a programme for geospatial data), I need to copy them into separate folders, e. g. the files from 2000 January 1 to 31 (named tx_20000101, tx_20000102 and so forth) into a folder named T_01_Jan_2000 and accordingly for all other months and years.
So I need a script, that searches for different text strings (YYYYMM) within all file names and moves the matched files into the given folder (for each search string a separate folder).
How could that be accomplished with VBScript?
With examples found in forums (mainly this: https://stackoverflow.com/a/29001051/6093207), I have come so far:
Option Explicit
Sub Dateien_verschieben()
Dim i
Dim FSO : Set fso = CreateObject("Scripting.FileSystemObject")
Dim Quelle : Set Quelle = FSO.GetFolder("C:\Users\…\Temperature")
Dim Ziel1 : Set Ziel1 = FSO.GetFolder("C:\Users\…\Temperature\T_01_Jan\T_01_Jan_2000")
Dim Ziel2 : Set Ziel2 = FSO.GetFolder("C:\Users\…\Temperature\T_02_Feb\T_02_Feb_2000")
…
Dim Ziel12 : Set Ziel12 = FSO.GetFolder("C:\Users\…\Temperature\T_12_Dez\T_12_Dez_2000")
Dim Str1, Str2, Str3, Str4, Str5, Str6, Str7, Str8, Str9, Str10, Str11, Str12
Str1 = "200001"
Str2 = "200002"
…
Str12 = "200012"
i = 0
For Each file in Quelle.files
x = fso.getbasename(file)
If instr(lcase(x), Str1) Then
i = i+1
If fso.fileexists(Ziel1 & "\" & file.name) Then
fso.deletefile Ziel1 & "\" & file.name, True
End If
fso.movefile Quelle & "\" & file.name, Ziel1
ElseIf instr(lcase(x), Str12) Then 'I have omitted the other ElseIf statements here for reasons of clarity
i = i+1
If fso.fileexists(Ziel12 & "\" & file.name) Then
fso.deletefile Ziel12 & "\" & file.name, True
End If
fso.movefile Quelle & "\" & file.name, Ziel12
End If
Next
If i>0 Then
wscript.echo i&" files moved to path " & vbcrlf & Quelle
wscript.quit()
End If
wscript.echo "No matches found"
End Sub
However, I get different errors like 800A0414 and 800A0046, and did not get the script running yet as intended.
Any suggestions for correcting the code or for more efficent ways of scripting are welcome.
Edited question:
Having a folder with several thousands netCDF-files containing values of daily temperature for a certain area, altogether covering a period of 30 years, how is it possible to move them into separate folders monthwise?
The month folders should contain subfolders for the respective year.
So the files are named tx_20000101.nc, tx_20000102.nc and so forth and are altogether in the folder Temperature.
Now all files from January should come into a folder name T_01, which contains subfolders named T_01_1991, T_01_1992 and so on, accordingly for all other months and years.
How can this be accomplished by VBScript?
The solution (thanks to #Les Ferch):
Move = True 'Set to False for Copy
SrcDir = ".\Temperature" Set oFSO = CreateObject("Scripting.FileSystemObject")
Set Source = oFSO.GetFolder(SrcDir)
For Each File in Source.Files
FileName = Right(File,11)
YYYY = Mid(FileName,1,4)
MM = Mid(FileName,5,2)
MonthDir = SrcDir & "\T_" & MM & "\"
YearDir = MonthDir & "T_" & MM & "_" & YYYY & "\"
If Not oFSO.FolderExists(MonthDir) Then oFSO.CreateFolder(MonthDir)
If Not oFSO.FolderExists(YearDir) Then oFSO.CreateFolder(YearDir)
If Move Then oFSO.MoveFile(File),YearDir Else oFSO.CopyFile(File),YearDir
Next
I accidentally delete my email account and so all of the emails in that account. Is there a chance to recover the emails? How can I recover it? Thanks.
Four months ago I would have agreed with Om3r's comment giving the location of the Outlook stores. But I bought a new laptop in December and now the Outlook files are not where all the documentation says they should be. Worse, I cannot reach the folders containing the Outlook files using File Explorer although I can find them with VBA.
The macro below searches drive C for files with an extension of OST or PST. I cannot promise this macro will find your lost store but, if it is still on your disc, it will find it. If you find the missing store, you will probably have to use VBA to move it to somewhere accessible.
Copy the macro below to a macro-enabled workbook and run it. While it is running the active worksheet will look like:
1923 Folders to search
327 Folders searched
Store Size Date Folder
$ILJARJ0.pst 212 28Mar20 C:\$Recycle.Bin\S-1-5-21-3957073674-21115239-22921093-1001
$IMS96DJ.pst 212 28Mar20 C:\$Recycle.Bin\S-1-5-21-3957073674-21115239-22921093-1001
The top two rows give a crude progress indicator. On my laptop, the routine ends with 69190 folders searched. I do not know why there are PST files in my recycle bin. I did nothing relevant on 28 March. When the routine has finished, there will be a auto-fitted list of every store the macro found. On my laptop none are where I would expect and some are duplicates. I hope you find your store.
Option Explicit
Sub SearchForStoresOnC()
' Searches drive C for files with an extension of PST or OST
' Warning: overwrites the active workbook
Dim ErrNum As Long
Dim FileAttr As Long
Dim FileName As String
Dim FldrName As String
Dim RowCrnt As Long
Dim ToSearch As Collection
Cells.EntireRow.Delete
Range("A1").Value = 0
Range("A2").Value = 0
Range("B1").Value = "Folders to search"
Range("B2").Value = "Folders searched"
Range("B4").Value = "Store"
With Range("C4")
.Value = "Size"
.HorizontalAlignment = xlRight
End With
With Range("D4")
.Value = "Date"
.HorizontalAlignment = xlRight
End With
Range("E4") = "Folder"
RowCrnt = 5
Set ToSearch = New Collection
' Load ToSearch with drive to search.
ToSearch.Add "C:"
Do While ToSearch.Count > 0
FldrName = ToSearch(1)
ToSearch.Remove 1
Err.Clear
ErrNum = 0
On Error Resume Next
' Stores are unlikely to be hidden but can be in folders that are hidden
FileName = Dir$(FldrName & "\*.*", vbDirectory + vbHidden + vbSystem)
ErrNum = Err.Number
On Error GoTo 0
If ErrNum <> 0 Then
'Debug.Print "Dir error: " & FldrName
Else
Do While FileName <> ""
If FileName = "." Or FileName = ".." Then
' Ignore pointers
Else
Err.Clear
On Error Resume Next
FileAttr = GetAttr(FldrName & "\" & FileName)
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Ignore file and folders which give errors
If (FileAttr And vbDirectory) = 0 Then
' File
'Debug.Assert False
Select Case Right$(FileName, 4)
Case ".pst", ".ost"
Cells(RowCrnt, "B").Value = FileName
With Cells(RowCrnt, "C")
.Value = FileLen(FldrName & "\" & FileName)
.NumberFormat = "#,##0"
End With
With Cells(RowCrnt, "D")
.Value = FileDateTime(FldrName & "\" & FileName)
.NumberFormat = "dmmmyy"
End With
Cells(RowCrnt, "E").Value = FldrName
RowCrnt = RowCrnt + 1
End Select
Else
' Directory
ToSearch.Add FldrName & "\" & FileName
End If ' File or Directory
Else
'Debug.Print "FileAttr error: " & FldrName & "\" & FileName
End If ' FileAttr does not give an error
End If ' Pointer or (File or Directory)
FileName = Dir$
Loop ' For each pointer, file and sub-directory in folder
End If ' Dir$ gives error
Range("A1") = ToSearch.Count
Range("A2") = Range("A2") + 1
DoEvents
Loop 'until ToSearch empty
Columns.AutoFit
End Sub
A previous team where I work created a vbs script that can automatically start a restore of a Macrium Image File located on inserted optical media. The problem is that the Macrium Image File is now too big for one disc, and now we have it split onto 2 separate discs, so now the vbs script doesn't function the way it should.
When Automatic Restore is launched, it should detect disc 1, which ends in 00.00.mrimg and know that it is part of a multi-disc install, at which point it asks for the next disc, ending in 00-01.mrimg.
I know this probably makes no sense, especially if anyone reading is not familiar with Macrium. But I will do my best to answer any questions.
I would normally plug away and try to figure it out myself, but i'm not very familiar with VBS and the problem is pretty time sensitive. Any help I can get will be much appreciated.
Opened AutoRestore.vbs script to see if I could fix the issue, but I don't know enough about vbs to fix it.
'AutoRestore.vbs
Dim fso, d, dc, s, n , Root, u, racine, folder, folderName, restoreString, foundFile, cdDrive
Dim wipe
Dim objShell
Set objShell = WScript.CreateObject("WScript.shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set dc = fso.Drives
foundFile = false
restoreString = "00-00.mrimg"
For Each d in dc
Root = d.Driveletter & ":"
racine = d.Driveletter & ":\"
u= Detect(Root)
if (( u="CD-ROM") ) then
cdDrive = cdDrive & racine & " "
if (d.isReady) then
folderName = racine & "IAS\"
Set folder = fso.GetFolder(folderName)
end if
end if
Next
If IsNull(folder) or IsEmpty(folder) Then
MsgBox "Could not locate IAS folder containing restore image." & vbCrLf & "The following optical disk drives were searched: " & cdDrive & vbCrLf & "Please verify the media is the drive or use manual restore.", 48, "Folder Not Found"
Else
For each file in folder.Files
If instr(1,file.Name, restoreString, vbTextCompare) > 0 Then
return = objShell.run("""%ProgramFiles%\macrium\diskrestore.exe""" & folderName & file.Name & " -r -g -u --targetnum 0 --reboot --eject",1,false)
foundFile = true
Exit For
End If
Next
if (foundFile = false) Then
MsgBox "Cannot locate .mrimg file in " & folderName & "." & vbCrLf & "Please use manual restore.", 48, "File Not Found"
End If
End If
Function Detect(DrivePath)
Dim fso, d, s, t
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = fso.GetDrive(fso.GetDriveName(fso.GetAbsolutePathName(DrivePath)))
Select Case d.DriveType
Case 0: t = "Unknown"
Case 1: t = "Removable"
Case 2: t = "Fixed"
Case 3: t = "Network"
Case 4: t = "CD-ROM"
Case 5: t = "RAM Disk"
End Select
Detect = t
End Function
Expected Results: Run AutoRestore.vbs, the script sees the 00-00.mrimg file in IAS folder of the optical media, then prompts to insert the optical media containing the 00-01.mrimg file.
Actual Results: Run AutoRestore.vbs, then Macrium states "Backup set is not complete. At least one file may be missing."
You could first copy all the mrimg files to a temporary folder on the machine's hard drive. Once you have them all, you can then run Disk Restore with that folder instead of the CD-ROM drive.
Most of your existing code would work. After the For Each d in dc loop, you know the drive where the discs are being inserted. You could add another loop:
Dim tempFolder
Set tempFolder = fso.GetFolder("C:\AutoRestore\")
Do While MsgBox("Please insert disc and click OK. When all discs have been inserted, click Cancel", vbOKCancel, "Auto Restore") = vbOK
For Each file In folder.Files
If InStr(1, file.Name, ".mrimg") > 0 Then
' Copy file to Temp folder
fso.CopyFile file.Path, tempFolder.Path & "\", True
End If
Next
Loop
After this, you should have all the mrimg files in the tempFolder location. I am not familiar with the parameters the Marcium command expects but this is where you would specify the new folder:
objShell.run("""%ProgramFiles%\macrium\diskrestore.exe""" & tempFolder.Path & "\" & file.Name & " -r -g -u --targetnum 0 --reboot --eject",1,false)
I am using the script listed below (I honestly stole this probably from this very site) for a browse button on a form. The task is simply to start up MS File Dialog box so that a file (in this case an image file) can be selected. Once you select the record and click ok it then pastes the file name and location into a field.
Viewing the table the file name and location is pasted just as it should be. The problem comes in with a report I built. I have an image set to display with the control source linked back to that file address field. It will not display the image though.
However, if I manually type the same address character for character or even “copy”, delete, and then “paste” the same exact entry into the field the image then displays just fine on the report.
I have checked to make sure there are no spaces or characters anywhere there shouldn’t be. I am at a loss here.
Any help would be greatly appreciated and I will gladly give you my first born. Ok maybe not the first I like him but you can have the second one, she’s hell.
Private Sub Command67_Click()
On Error GoTo SubError
'Add "Microsoft Office 14.0 Object Library" in references
Const msoFileDialogFilePicker As Long = 3
'Dim FD As Office.FileDialog
Dim FDialog As Object
Dim varfile As Variant
Set FDialog = Application.FileDialog(msoFileDialogFilePicker)
EmployeePicture = ""
' Set up the File Dialog
Set FDialog = Application.FileDialog(msoFileDialogFilePicker)
With FDialog
.Title = "Choose the spreadsheet you would like to import"
.AllowMultiSelect = False
.InitialFileName = "C:\Users\" 'Folder picker needs trailing slash
.Filters.Clear
.Filters.Add "All", "*.*"
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)
'EmployeePicture = varFile
'Needed when MultiSelect = True
For Each varfile In .SelectedItems
EmployeePicture = EmployeePicture & varfile & vbCrLf
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:
MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
I'm making a script to list all files within a folder.
The intention is to list all files within a specific folder on every server we have.
So I have an excel file with as first line every servername.
Of course I don't have rights on every server or there is no scripts folder; so sometimes i get a "path not found" error.
Eventhough I used On Error Resume Next it still throws the error.
I would need something like try - catch, but that doens't exists in vbs.
How can I try to connect to folders and ignore when there's an error?
The offending lines is the Set folder = ...
Do While objSheet.Cells(1, intCol).Value <> ""
intRow = 2
sFolder ="\\" & objSheet.Cells(1, intCol).Value & "\C$\Scripts"
'msgbox sFolder
Set folder = fso.GetFolder(sFolder)
Set files = folder.Files
...
The full code: https://gist.github.com/076501c940e8388b5b39
You can check if a folder exists with fso.FolderExists(sFolder):
If fso.FolderExists(sFolder) then
Set folder = fso.GetFolder(sFolder)
Set files = folder.Files
For each file In files
'msgbox file.name
objSheet.Cells(intRow, intCol).Value = file.Name
introw = introw + 1
Next
objExcel.ActiveWorkbook.Save
intCol = intcol+1
End if