I need to make a vbs file that asks for the minimum file size when you drag and drop a folder to it. It's a little wierd. But then, it should return the input as a string that will be turned into an integer. Then it should look for files that are bigger than this minimum file size(all, i guess) and list their folder(if it's in a sub-folder), name and size.
I found some stuff on the internet but I'm a bit lost
Option Explicit
Dim FolderPath, objFSO, objFolder, objFile, input, objArgs
input = InputBox("Minimum size: ")
Set objArgs = Wscript.Arguments
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 0 to objArgs.count
on error resume next
Set objFolder = objFSO.GetFolder(objArgs(i))
If err.number <> 0 then
ProcessFile(objArgs(i))
Else
For Each file In folder.Files
ProcessFile(file.path)
Next
End if
On Error Goto 0
Next
Function ProcessFile(sFilePath)
msgbox "Now processing file: " & sFilePath
For each objFile in objFolder.Files
WScript.Echo objFile.Name, objFile.Size & "bytes" & VbCR_
& "created: " & objFile.DateCreated & VbCR_
& "modified: " & objFile.DateLastModified
Next
You've got some issues in your code. You're using folder.files but you don't have folder declared (or defined) anywhere. The only reason you're not getting an error is because you have On Error Resume Next specified. There's no need to use On Error here and it should be removed so that you can properly debug your script. Here's a starting point for you.
' Get the folder dropped onto our script...
strFolder = WScript.Arguments(0)
' Ask for minimum file size...
intMinSize = InputBox("Minimum size: ")
' Recursively check each file with the folder and its subfolders...
DoFolder strFolder
Sub DoFolder(strFolder)
' Check each file...
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Size >= intMinSize Then
WScript.Echo "Path: " & objFile.Path & vbCrLf & "Size: " & objFile.Size
End If
Next
' Recursively check each subfolder...
For Each objFolder In objFSO.GetFolder(strFolder).SubFolders
DoFolder objFolder.Path
Next
End Sub
This isn't a complete script. Notice I haven't declared objFSO anywhere. I haven't checked that strFolder is a valid folder or that intMinSize is actually a number. I'll leave it up to you to fill in the missing pieces. But this should get you going.
Related
I have a script to list the files in a directory including their length:
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set txtOut = objFSO.CreateTextFile("d:\FileNameLength.csv")
FoldersRec "d:\MyData"
Sub FoldersRec(Startfolder)
Set objFolder = objFSO.GetFolder(Startfolder)
Set colSubfolders = objFolder.Subfolders
For Each objSubfolder In colSubfolders
FoldersRec(objSubfolder)
Next
For Each file In objFolder.Files
strZeile = file & ";" & Len(file)
txtOut.WriteLine strZeile
Next
''MsgBox "Done"
End Sub
It works fine. What I would like to change is to convert it to an explicit loop after which I can add something, like for instance a message box.
If I just enter MsgBox "Done" just before End Sub it would appear for each file.
Therefore, the idea is to add something like loop while file exists or loop while Len(file)>0. But I am not quite sure about the syntax.
Why not like this:
Set txtOut = objFSO.CreateTextFile("d:\FileNameLength.csv")
FoldersRec "d:\MyData"
MsgBox "Done"
I would rewrite your code like this:
Set fso = CreateObject("Scripting.FileSystemObject")
ListSizes fso.GetFolder("D:\MyData"), fso.CreateTextFile("d:\FileNameLength.csv")
MsgBox "Done"
Sub ListSizes(folder, outStream)
Dim subfolder, file
For Each subfolder In folder.Subfolders
ListSizes subfolder, outStream
Next
For Each file In folder.Files
outStream.WriteLine file & ";" & file.Size
Next
End Sub
This way you can pass any Stream object to ListSizes, for example the console (when called through cscript.exe):
ListSizes fso.GetFolder("D:\MyData"), WScript.StdOut
Also, I suspect want the file .Size (in bytes), and not the length of the file path?
So, here is the best solution for my problem:
Set fso = CreateObject("Scripting.FileSystemObject")
ListSizes fso.GetFolder("s:"), fso.CreateTextFile("r:\FileNameLength.csv")
MsgBox "Done"
Sub ListSizes(folder, outStream)
Dim subfolder, file
For Each subfolder In folder.Subfolders
On Error Resume Next
ListSizes subfolder, outStream
Next
For Each file In folder.Files
outStream.WriteLine file & ";" & file.Size & ";" & len(file)
Next
End Sub
With this solution I get both file name length and file size.
Im writing a batch script to help me collect some bandwidth data about numerous offices on our WAN. It uses random data file creator to help me avoid wan optimisers affecting the results.
How can I copy a file by spawning a standard windows copy window that shows transfer rate?
If i use the 'copy' method, it just copies silently in the cmd window and i cant see the rate.
if not exist "C:\temp\xfertest" mkdir C:\test\xfertest
rdfc C:\test\xfertest\random100.dat 100000000
copy C:\test\xfertest\random100.dat \\nat-srv-007\Deliver
exit
This vbscript wrappped in a batch file will do what you want. Save it with a .bat/.cmd extension. Or without the first line with a .vbs extension.
The technic used is based on com and works with every script language supporting it.
Just to see start/end date time, total bytes and bytes per/s it outputs these values to the console after the copy dialog window has vanished.
rem^ &#cscript //nologo //e:vbscript "%~f0" %* & exit /b
' Copy with the windows dialog box
Option Explicit
Dim cArgs : Set cArgs = WScript.Arguments
Dim iArgCnt : iArgCnt = cArgs.Count
Dim sSource : sSource = cArgs.Item(0)
Dim sDest : sDest = cArgs.Item(1)
Dim oFS : Set oFS = CreateObject("Scripting.FileSystemObject")
Dim oSH : Set oSH = CreateObject("shell.application")
Dim oFile, Size, dStart, dEnd
If iArgCnt <> 2 Then
Wscript.Echo "Wrong args, need SourceFile and DestFolder"
Wscript.Quit
End if
If oFS.FileExists(sSource) Then
Set oFile = oFS.GetFile(sSource)
Size = oFile.Size
If oFS.FolderExists(sDest) Then
dStart = Now()
Wscript.Echo "Copy : " & sSource & " " & sDest
Wscript.Echo "Start: " & dStart & " Size : " & Size
FolderCopyHere sSource, sDest
dEnd = Now()
Wscript.Echo "End : " & dEnd & " per/s: " & _
Int(Size / DateDiff("s", dStart, dEnd))
Else
Wscript.Echo "Destination Folder doesn't exist" & sDest
End if
Else
Wscript.Echo "Source file doesn't exist" & sSource
End if
Wscript.Quit
function FolderCopyHere(sSource,sDest)
dim oFld
set oFld = oSH.NameSpace(sDest)
if not oFld is nothing then
oFld.CopyHere(sSource)
end if
set oFld = nothing
end function
Returning this output on my pc
20:28:24 C:\Test________________________________________
> k:\Bat\CopyExpl.cmd c:\test\big.file Q:\Test
20:28:36 C:\Test________________________________________
> rem &
Copy : c:\test\big.file Q:\Test
Start: 2016-10-30 20:28:36 Size : 2147483648
End : 2016-10-30 20:29:10 per/s: 63161283
20:29:10 C:\Test________________________________________
The Rem stems from the wrapper the dialog box is widely known. HTH
I needed to copy all of my photos from my old laptop to my new laptop. This is a quick and dirty script that I put together (based on other scripts on this site) to copy files from one network location to another. I wanted the process to be able to recover in case of a network copy error because the total time to copy all of my photos was 40 hours.
sourceRoot and targetRoot is the beginning part of the file path to replace between locations. lastFileLog is a file used to keep track of the last file that was copied. This is needed to recover from a partial copy. Windows seems to allocate the full file size even when the file fails to copy. So I just keep track of the last file to copy it again on failure. objStartFolder is the starting path on the source network location.
'initialize paths
objStartFolder = "\\owner-pc\d\pics"
lastFileLog = "c:\Files\misc\archive.log"
sourceRoot = "\\owner-pc\d"
targetRoot = "c:\Files"
Set objFSO = CreateObject("Scripting.FileSystemObject")
'read log
Set objFile = objFSO.OpenTextFile(lastFileLog)
Do Until objFile.AtEndOfStream
replacefile= objFile.ReadLine
Wscript.Echo "This file will be replaced: " & replacefile
Loop
objFile.Close
'copy files
Set objFolder = objFSO.GetFolder(objStartFolder)
ShowSubfolders objFSO.GetFolder(objStartFolder)
'clear log
Set objFileLog = objFSO.CreateTextFile(lastFileLog,True)
objFileLog.Write ""
objFileLog.Close
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
Wscript.Echo Subfolder.Path
if not(objFSO.FolderExists(replace(Subfolder.Path,sourceRoot,targetRoot))) then
objFSO.CreateFolder(replace(Subfolder.Path,sourceRoot,targetRoot))
end if
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile in colFiles
if not(objFSO.FileExists(replace(Subfolder.Path & "\" & objFile.Name,sourceRoot,targetRoot))) then
Wscript.Echo Subfolder.Path & "\" & objFile.Name
Set objFileLog = objFSO.CreateTextFile(lastFileLog,True)
objFileLog.Write Subfolder.Path & "\" & objFile.Name
objFileLog.Close
objFSO.CopyFile Subfolder.Path & "\" & objFile.Name, replace(Subfolder.Path & "\" & objFile.Name,sourceRoot,targetRoot)
elseif replacefile = Subfolder.Path & "\" & objFile.Name then
Wscript.Echo "Replacing ... " & Subfolder.Path & "\" & objFile.Name
objFSO.CopyFile Subfolder.Path & "\" & objFile.Name, replace(Subfolder.Path & "\" & objFile.Name,sourceRoot,targetRoot),true
else
Wscript.Echo "Skip ... " & Subfolder.Path & "\" & objFile.Name
end if
Next
ShowSubFolders Subfolder
Next
end sub
For Folder: Try This.
Option Explicit
Dim obj,Itemcoll1,a,b
Set obj=CreateObject("Shell.Application")
Function SelectFold1(Desc)
Set SelectFold1=obj.BrowseForFolder(0,Desc,0,"C:\Users\Mohammed Sajjad\Desktop\")
End Function
Set Itemcoll1=SelectFold1("Copy: ").Items
SelectFold1("Paste: ").CopyHere Itemcoll1 'Use MoveHere if you want to move
MsgBox "Completed"
For File:
Option Explicit
Dim objApp : Set objApp = CreateObject("Shell.Application")
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objSHL : Set objSHL = CreateObject("WScript.Shell")
'Browse for Folder
'----------------------------------------------------------
Function SelectFold()
Dim objFolder
Set objFolder = objApp.BrowseForFolder(0,"Select a Folder",0,0)
If objFolder Is Nothing Then
MsgBox "Canceled"
WScript.Quit
Else
SelectFold = objFolder.Self.Path & "\"
End If
End Function
'----------------------------------------------------------
'Browse for file
'----------------------------------------------------------
Function SelectFile()
Dim tempFolder : Set tempFolder = objFSO.GetSpecialFolder(2)
Dim tempFile : tempFile = objFSO.GetTempName() & ".hta"
Dim path : path = "HKCU\Volatile Environment\MsgResp"
With tempFolder.CreateTextFile(tempFile)
.Write "<input type=file name=f>" & _
"<script>f.click();(new ActiveXObject('WScript.Shell'))" & _
".RegWrite('HKCU\\Volatile Environment\\MsgResp', f.value);" & _
"close();</script>"
.Close
End With
objSHL.Run tempFolder & "\" & tempFile, 0, True
If objSHL.RegRead(path) = "" Then
objSHL.RegDelete path
objFSO.DeleteFile tempFolder & "\" & tempFile
WScript.Quit
End If
SelectFile = objSHL.RegRead(path)
objSHL.RegDelete path
objFSO.DeleteFile tempFolder & "\" & tempFile
End Function
'----------------------------------------------------------
objFSO.CopyFile SelectFile, SelectFold
I have a system that's running an old FoxPro program which generates 8 character long DBF files. We make a back up of the program folder each day, but at 5pm the program has generated so many of these garbage dbf's that it's a nuisance. I would just set a del *.dbf in the back up script but there are a few dbf with letters in their name that are needed to run the program.
Files are located in F:\Clean This\
Any numerically titled .dbf files need to be deleted
Any alphabetically titled .dbf file should be left alone
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "F:\Clean This\"
Set objFolder = objFSO.GetFolder(objStartFolder)
Set colFiles = objFolder.Files
collide = "ABCEDFGHIJKLMNOPQRSTUVWXYZ"
For Each objFile in colFiles
If UCase(objFSO.GetExtensionName(objFile.name)) = "DBF" Then
num = 1
For num = 1 to 26 'find files with names start with # 0-9
If Left(objFile.Name,1) = Left(collide,num) Then
Wscript.Echo "Save " & objFile.Name
Else If int(Left(objFile.Name,1)) > 0 Then
Wscript.Echo "Delete!"
End IF
End If
Next
End If
Next
As you can tell the If statements can be done better, I'm unsure how to better work it out. The two Wscript.Echo commands are just placeholders because if anything else I can't get find a suitable delete function that would work in a dos environment (I've already tried kill, no).
Suggestions and improvements would be much appreciated!
Use IsNumeric() to check for file names consisting of digits only:
>> For Each sN In Split("abc 123 1O1 101")
>> If IsNumeric(sN) Then
>> WScript.Echo "delete", sN
>> Else
>> WScript.Echo "keep", sN
>> End If
>> Next
>>
keep abc
delete 123
keep 1O1
delete 101
Your check fails, because you use Left() where you should use Mid():
>> collide = "ABCEDFGHIJKLMNOPQRSTUVWXYZ"
>> num = 5
>> WScript.Echo Left(collide,num)
>> WScript.Echo Mid(collide,num,1)
>>
ABCED
D
and even then Left(objFile.Name,1) will look at only the first character of the file name.
Update (wrt comments):
Apply IsNumeric() to the base name:
Dim oFile
For Each oFile In goFS.GetFolder("..\testdata\17817161").Files
WScript.Stdout.Write oFile.Name
If "dbf" = LCase(goFS.GetExtensionName(oFile.Name)) Then
If IsNumeric(goFS.GetBaseName(oFile.Name)) Then
WScript.Stdout.WriteLine " delete"
Else
WScript.Stdout.WriteLine " keep"
End If
Else
WScript.Stdout.WriteLine " ignore"
End If
Next
output:
123.dbf delete
123.txt ignore
abc.dbf keep
I did finally got it working, and here's what the end result was. It works wonderfully and the higher ups and others were rather impress that it worked better than the built in utility of the program we're backing up. Score!
Set objFSO = CreateObject("Scripting.FileSystemObject")
objStartFolder = "..\System Folder"
Set objFolder = objFSO.GetFolder(objStartFolder)
Set DirFiles = objFolder.Files
Dim oFile
For Each objFile in DirFiles
If "dbf" = LCase(objFSO.GetExtensionName(objFile.Name)) Then
If IsNumeric(objFSO.GetBaseName(objFile.Name)) Then
objFSO.DeleteFile(objFile)
End If
End If
Next
I'm really new to Access VBA. I have a problem in Access code could you help me with a request mentioned below?
I have file with names like ex.zip. In this example, the Zip file contains only one file with the same name(ie. `ex.txt'), which is quite large file. I don't want to extract the zip file every time.Hence I need to read the content of the file(ex.txt) without extracting the zip file. I tried some code like below But i can't read the content of the file and can't stores the content in the variable in Access VBA.
How do I read the content of the file and stores it in the variable?
I have tried some code in VBA to read the zipped text But i didn't make any sense..
Here's the code for zipping & unzipping. If you look at it the unzip part, you'll see where it reads the zip file like a directory. Then you can choose if you want to extract that file.
Private Declare Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As Long _
)
Public Sub Zip( _
ZipFile As String, _
InputFile As String _
)
On Error GoTo ErrHandler
Dim FSO As Object 'Scripting.FileSystemObject
Dim oApp As Object 'Shell32.Shell
Dim oFld As Object 'Shell32.Folder
Dim oShl As Object 'WScript.Shell
Dim I As Long
Dim l As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(ZipFile) Then
'Create empty ZIP file
FSO.CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
End If
Set oApp = CreateObject("Shell.Application")
Set oFld = oApp.NameSpace(CVar(ZipFile))
I = oFld.Items.Count
oFld.CopyHere (InputFile)
Set oShl = CreateObject("WScript.Shell")
'Search for a Compressing dialog
Do While oShl.AppActivate("Compressing...") = False
If oFld.Items.Count > I Then
'There's a file in the zip file now, but
'compressing may not be done just yet
Exit Do
End If
If l > 30 Then
'3 seconds has elapsed and no Compressing dialog
'The zip may have completed too quickly so exiting
Exit Do
End If
DoEvents
Sleep 100
l = l + 1
Loop
' Wait for compression to complete before exiting
Do While oShl.AppActivate("Compressing...") = True
DoEvents
Sleep 100
Loop
ExitProc:
On Error Resume Next
Set FSO = Nothing
Set oFld = Nothing
Set oApp = Nothing
Set oShl = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub
Public Sub UnZip( _
ZipFile As String, _
Optional TargetFolderPath As String = vbNullString, _
Optional OverwriteFile As Boolean = False _
)
'On Error GoTo ErrHandler
Dim oApp As Object
Dim FSO As Object
Dim fil As Object
Dim DefPath As String
Dim strDate As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Len(TargetFolderPath) = 0 Then
DefPath = CurrentProject.Path & "\"
Else
If Not FSO.FolderExists(TargetFolderPath) Then
MkDir TargetFolderPath
End If
DefPath = TargetFolderPath & "\"
End If
If FSO.FileExists(ZipFile) = False Then
MsgBox "System could not find " & ZipFile & " upgrade cancelled.", vbInformation, "Error Unziping File"
Exit Sub
Else
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
With oApp.NameSpace(ZipFile & "\")
If OverwriteFile Then
For Each fil In .Items
If FSO.FileExists(DefPath & fil.Name) Then
Kill DefPath & fil.Name
End If
Next
End If
oApp.NameSpace(CVar(DefPath)).CopyHere .Items
End With
On Error Resume Next
Kill Environ("Temp") & "\Temporary Directory*"
'Kill zip file
Kill ZipFile
End If
ExitProc:
On Error Resume Next
Set oApp = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Sub