HedgeHopper
I'd be grateful if anyone could help me out with some coding. The script I have is not my own although I have modified it slightly. It started off with Maran Raj and attracted subsequent additions from Hackoo and Wicky.
I would like to modify it further so that it could search through all folders on drives C: and D: or any other. I have searched online in vain for a solution as to what coding is necessary to achieve this so I would appreciate any help. Here is the script:
Code: Select all
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
path = objFSO.GetParentFolderName(wscript.ScriptFullName)
strOutputFile = path & "\result.txt"
If objFSO.FileExists(strOutputFile) Then
objFSO.DeleteFile(strOutputFile)
End if
inputFldr = BrowseForFolder()
Set fldr = objFSO.getFolder(inputFldr)
strTextToFind = Inputbox("Enter The Search Text Below","Search Dialogue","Enter Keyword Here")
For Each file In fldr.Files
Call Search(file,strTextToFind)
Next
If objFSO.FileExists(strOutputFile) Then
else
wscript.echo "No Matches Found"
wscript.Quit
end if
ws.run strOutputFile
'***************************************************************************************************************
Sub Search(inputFile,strTextToFind)
strInputFile = inputFile
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Set objInputFile = objFSO.OpenTextFile(strInputFile,intForReading, False)
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending, True)
objOutputFile.WriteLine "File And Folder Path: "& DblQuote(strInputFile) & VbCRLF &_
"Search Term Used: " & DblQuote(strTextToFind) & vbCRLF &_
"Search Outcome: "& DblQuote(strFoundText) & VbCRLF & String(100,"*")
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
loop
objInputFile.Close
Set objInputFile = Nothing
End sub
'***************************************************************************************************************
Function BrowseForFolder()
Dim ws,objFolder,Copyright
Set ws = CreateObject("Shell.Application")
Set objFolder = ws.BrowseForFolder(0,"Choose the folder to search on it ",1,"c:\Programs")
If objFolder Is Nothing Then
Wscript.Quit
End If
BrowseForFolder = objFolder.self.path
end Function
'****************************************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'*****************************************************
#2 27 May 2021 16:59
Hackoo
Hi wink
Just give a try for this modification :
Code: Select all
If AppPrevInstance() Then
MsgBox "The script is already Running" & vbCrlf &_
CommandLineLike(WScript.ScriptName),VbExclamation,"The script is already Running"
WScript.Quit
Else
strTextToFind = Inputbox("Enter The Search Text Below","Search Dialogue","Enter Keyword Here")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
path = objFSO.GetParentFolderName(wscript.ScriptFullName)
strOutputFile = path & "\Search-Result.txt"
If objFSO.FileExists(strOutputFile) Then
objFSO.DeleteFile(strOutputFile)
End if
REM Just to play some music because the task can be take a long time
Call Play("http://94.23.221.158:9197/stream")
REM If you don't want listen to music just comment the line above
StartTime = Timer
Set dc = objFSO.Drives
For Each d in dc
If d.IsReady Then
RootDrive = d.Driveletter & ":"
FindWantedFiles(RootDrive)
End If
Next
If objFSO.FileExists(strOutputFile) Then
StopMusic
Duration = FormatNumber(Timer - StartTime, 0)
WS.Popup "The task had taken a run time until its completion about :" & vbCrlf &_
vbTab & convertTime(Duration) & vbCrlf & _
vbTab & WScript.ScriptName,10,Title,vbExclamation + vbSystemModal
ws.run strOutputFile
else
StopMusic
wscript.echo "No Matches Found"
wscript.Quit
end if
End If
'--------------------------------------------------------------------------------------------------------------
Sub FindWantedFiles(sFolder)
On Error Resume Next
Set ObjFolder = objFSO.getFolder(sFolder)
For Each File In ObjFolder.Files
Call Search(File,strTextToFind)
Next
' Recurse into it's sub folders
For Each oFDR In ObjFolder.SubFolders
Call FindWantedFiles(oFDR.Path)
Next
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub Search(inputFile,strTextToFind)
strInputFile = inputFile
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Set objInputFile = objFSO.OpenTextFile(strInputFile,intForReading, False)
Dim strOutputFile : strOutputFile = objFSO.GetParentFolderName(wscript.ScriptFullName) & "\Search-Result.txt"
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending,True)
objOutputFile.WriteLine "File And Folder Path: "& DblQuote(strInputFile) & VbCRLF &_
"Search Term Used: " & DblQuote(strTextToFind) & vbCRLF &_
"Search Outcome: "& DblQuote(strFoundText) & VbCRLF & String(100,"*")
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
Loop
objInputFile.Close
Set objInputFile = Nothing
End sub
'--------------------------------------------------------------------------------------------------------------
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'--------------------------------------------------------------------------------------------------------------
Sub Play(URL)
Dim ws,fso,f,TempFile,TempFolder
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
TempFolder = WS.ExpandEnvironmentStrings("%Temp%")
TempFile = TempFolder & "\RadioEuroDance90.vbs"
Set f = fso.OpenTextFile(Tempfile,2,True)
f.Writeline "Call Play(" & chr(34) & URL & chr(34) & ")"
f.Writeline "Sub Play(URL)"
f.Writeline "Set Sound = CreateObject(""WMPlayer.OCX"")"
f.Writeline "Sound.URL = URL"
f.Writeline "Sound.settings.volume = 100"
f.Writeline "Sound.Controls.play"
f.Writeline "While Sound.playState <> 1"
f.Writeline "wscript.sleep 100"
f.Writeline "Wend"
f.Writeline "End Sub"
f.close
ws.run "cmd /c Start ""Playing Music"" /Min cscript //NoLogo " & Tempfile & "",1,True
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub StopMusic()
Set ws = CreateObject("wscript.Shell")
ws.run "Taskkill /F /IM ""cscript.exe""",0,True
End Sub
'---------------------------------------------------------------------------------------------------------------
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'---------------------------------------------------------------------------------------------------------------
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'---------------------------------------------------------------------------------------------------------------
Function convertTime(seconds)
Dim ConvSec,ConvHour,ConvMin
ConvSec = seconds Mod 60
If Len(ConvSec) = 1 Then
ConvSec = "0" & ConvSec
End If
ConvMin = (seconds Mod 3600) \ 60
If Len(ConvMin) = 1 Then
ConvMin = "0" & ConvMin
End If
ConvHour = seconds \ 3600
If Len(ConvHour) = 1 Then
ConvHour = "0" & ConvHour
End If
convertTime = ConvHour & ":" & ConvMin & ":" & ConvSec
End Function
'-------------------------------------------------------------------------------------------------------------
Last edited by Hackoo (28 May 2021 20:26)
#3 28 May 2021 20:13
HedgeHopper
Hi Hackoo, that would work. But instead of checking all available drives, I want to be able to specify in the script which particular drive should be checked?
----------------------------
#4 29 May 2021 07:13
Hackoo
Perhaps something like that can did the trick winkHedgeHopper wrote:
Hi Hackoo, that would work. But instead of checking all available drives, I want to be able to specify in the script which particular drive should be checked?
Code: Select all
Option Explicit
Dim Title,objFSO,d,dc,RootDrive,Ready_Drives
Dim Choose_Drive,Message,Array_Drives
Array_Drives = Array()
Title = "Search Key Word"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set dc = objFSO.Drives
For Each d in dc
If d.IsReady Then
RootDrive = d.Driveletter & ":"
ReDim Preserve Array_Drives(UBound(Array_Drives) + 1)
Array_Drives(UBound(Array_Drives)) = RootDrive
Ready_Drives = Ready_Drives & RootDrive & vbcrlf
End If
Next
Message = "You should choose one drive for scanning :" & vbCrlf & Ready_Drives
Do
Choose_Drive = Inputbox(Message,Title,Array_Drives(0))
If Choose_Drive = "" Then Wscript.Quit
If inArray(Array_Drives,Choose_Drive) Then
MsgBox "You chosen for scanning this Drive " & chr(34) & UCase(Choose_Drive) & chr(34),vbInformation,Title
Else
MsgBox "ERROR ==> " & chr(34) & UCase(Choose_Drive) & chr(34) & " does not exists ",vbCritical,Title
End If
Loop Until inArray(Array_Drives,Choose_Drive)
'-----------------------------------------------------------------------
Function inArray(arr,obj)
Dim value
inArray = False
For Each value in arr
If UCase(value) = UCase(obj) Then
inArray = True
Exit For
End If
Next
End Function
'-----------------------------------------------------------------------
Last edited by Hackoo (29 May 2021 15:53)
#5 31 May 2021 18:35
HedgeHopper
Hi Hackoo, I'm afraid that I've not been able to get this script to run successfully. I have attached what I've done so far below. The outcome I get is always "No Matches". I think the problem is that there has to be a hand over between the variables RootDrive and Choose_Drive (Choose_Drive = RootDrive perhaps is what is required) and precisely where that handover should be entered in the script. I've tried various places without success. Can you help please?
Code: Select all
Option Explicit
Dim Title,objFSO,d,dc,RootDrive,Ready_Drives
Dim Choose_Drive,Message,Array_Drives
Dim strTextToFind, ws,StartTime,Path,strOutputFile
Array_Drives = Array()
Title = "Drive Option Dialogue"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If AppPrevInstance() Then
MsgBox "The script is already Running" & vbCrlf &_
CommandLineLike(WScript.ScriptName),VbExclamation,"The script is already Running"
WScript.Quit
Else
strTextToFind = Inputbox("Enter The Search Text Below","Search Dialogue","Enter Keyword Here")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
path = objFSO.GetParentFolderName(wscript.ScriptFullName)
strOutputFile = path & "\Search-Result.txt"
If objFSO.FileExists(strOutputFile) Then
objFSO.DeleteFile(strOutputFile)
End if
REM Just to play some music because the task can be take a long time
'Call Play("http://94.23.221.158:9197/stream")
REM If you want don't listen to music just comment the line above
StartTime = Timer
Set dc = objFSO.Drives
For Each d in dc
If d.IsReady Then
RootDrive = d.Driveletter & ":"
ReDim Preserve Array_Drives(UBound(Array_Drives) + 1)
Array_Drives(UBound(Array_Drives)) = RootDrive
Ready_Drives = Ready_Drives & RootDrive & vbcrlf
End If
Next
Message = "Choose One Of The Following Drives:" & vbCrLf & vbCrLf & Ready_Drives
Do
Choose_Drive = Inputbox(Message,Title,Array_Drives(0))
If Choose_Drive = "" Then Wscript.Quit
If inArray(Array_Drives,Choose_Drive) Then
'MsgBox "You Have Chosen This Drive For Scanning " & chr(34) & UCase(Choose_Drive) & chr(34),vbInformation,Title
MsgBox "You Have Opted To Scan Drive " & chr(34) & UCase(Choose_Drive) & chr(34),vbInformation,Title
Else
MsgBox "ERROR ==> " & chr(34) & UCase(Choose_Drive) & chr(34) & " does not exists ",vbCritical,Title
End If
Loop Until inArray(Array_Drives,Choose_Drive)
'-----------------------------------------------------------------------
If objFSO.FileExists(strOutputFile) Then
StopMusic
Duration = FormatNumber(Timer - StartTime, 0)
WS.Popup "The task had taken a run time until its completion about :" & vbCrlf &_
vbTab & convertTime(Duration) & vbCrlf & _
vbTab & WScript.ScriptName,10,Title,vbExclamation + vbSystemModal
ws.run strOutputFile
else
StopMusic
wscript.echo "No Matches Found"
wscript.Quit
end if
End If
'--------------------------------------------------------------------------------------------------------------
Sub FindWantedFiles(sFolder)
On Error Resume Next
Set ObjFolder = objFSO.getFolder(sFolder)
For Each File In ObjFolder.Files
Call Search(File,strTextToFind)
Next
' Recurse into it's sub folders
For Each oFDR In ObjFolder.SubFolders
Call FindWantedFiles(oFDR.Path)
Next
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub Search(inputFile,strTextToFind)
strInputFile = inputFile
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Set objInputFile = objFSO.OpenTextFile(strInputFile,intForReading, False)
strOutputFile = objFSO.GetParentFolderName(wscript.ScriptFullName) & "\Search-Result.txt"
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending,True)
objOutputFile.WriteLine "File And Folder Path: "& DblQuote(strInputFile) & VbCRLF &_
"Search Term Used: " & DblQuote(strTextToFind) & vbCRLF &_
"Search Outcome: "& DblQuote(strFoundText) & VbCRLF & String(100,"*")
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
Loop
objInputFile.Close
Set objInputFile = Nothing
End sub
'--------------------------------------------------------------------------------------------------------------
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'--------------------------------------------------------------------------------------------------------------
Sub Play(URL)
Dim ws,fso,f,TempFile,TempFolder
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
TempFolder = WS.ExpandEnvironmentStrings("%Temp%")
TempFile = TempFolder & "\RadioEuroDance90.vbs"
Set f = fso.OpenTextFile(Tempfile,2,True)
f.Writeline "Call Play(" & chr(34) & URL & chr(34) & ")"
f.Writeline "Sub Play(URL)"
f.Writeline "Set Sound = CreateObject(""WMPlayer.OCX"")"
f.Writeline "Sound.URL = URL"
f.Writeline "Sound.settings.volume = 100"
f.Writeline "Sound.Controls.play"
f.Writeline "While Sound.playState <> 1"
f.Writeline "wscript.sleep 100"
f.Writeline "Wend"
f.Writeline "End Sub"
f.close
ws.run "cmd /c Start ""Playing Music"" /Min cscript //NoLogo " & Tempfile & "",1,True
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub StopMusic()
Set ws = CreateObject("wscript.Shell")
ws.run "Taskkill /F /IM ""cscript.exe""",0,True
End Sub
'---------------------------------------------------------------------------------------------------------------
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'---------------------------------------------------------------------------------------------------------------
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'---------------------------------------------------------------------------------------------------------------
Function convertTime(seconds)
Dim ConvSec,ConvHour,ConvMin
ConvSec = seconds Mod 60
If Len(ConvSec) = 1 Then
ConvSec = "0" & ConvSec
End If
ConvMin = (seconds Mod 3600) \ 60
If Len(ConvMin) = 1 Then
ConvMin = "0" & ConvMin
End If
ConvHour = seconds \ 3600
If Len(ConvHour) = 1 Then
ConvHour = "0" & ConvHour
End If
convertTime = ConvHour & ":" & ConvMin & ":" & ConvSec
End Function
'-------------------------------------------------------------------------------------------------------------
Function inArray(arr,obj)
Dim value
inArray = False
For Each value in arr
If UCase(value) = UCase(obj) Then
inArray = True
Exit For
End If
Next
End Function
'-----------------------------------------------------------------------
#6 31 May 2021 21:34
Hackoo
Code: Select all
Option Explicit
If AppPrevInstance() Then
MsgBox "The script is already Running" & vbCrlf &_
CommandLineLike(WScript.ScriptName),VbExclamation,"The script is already Running"
WScript.Quit
Else
Dim Title,objFSO,d,dc,RootDrive,Ready_Drives
Dim Choose_Drive,Message,Array_Drives
Dim strTextToFind, ws,StartTime,Path,strOutputFile
Array_Drives = Array()
Title = "Drive Option Dialogue"
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTextToFind = Inputbox("Enter The Search Text Below","Search Dialogue","Enter Keyword Here")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
path = objFSO.GetParentFolderName(wscript.ScriptFullName)
strOutputFile = path & "\Search_Result_"& strTextToFind &".txt"
If objFSO.FileExists(strOutputFile) Then
objFSO.DeleteFile(strOutputFile)
End if
Set dc = objFSO.Drives
For Each d in dc
If d.IsReady Then
RootDrive = d.Driveletter & ":"
ReDim Preserve Array_Drives(UBound(Array_Drives) + 1)
Array_Drives(UBound(Array_Drives)) = RootDrive
Ready_Drives = Ready_Drives & RootDrive & vbcrlf
End If
Next
Message = "Choose One Of The Following Drives:" & vbCrLf & vbCrLf & Ready_Drives
Do
Choose_Drive = Inputbox(Message,Title,Array_Drives(0))
If Choose_Drive = "" Then Wscript.Quit
If inArray(Array_Drives,Choose_Drive) Then
MsgBox "You Have Opted To Scan Drive " & chr(34) & UCase(Choose_Drive) & chr(34),vbInformation,Title
Else
MsgBox "ERROR ==> " & chr(34) & UCase(Choose_Drive) & chr(34) & " does not exists ",vbCritical,Title
End If
Loop Until inArray(Array_Drives,Choose_Drive)
REM Just to play some music because the task can be take a long time
'Call Play("http://94.23.221.158:9197/stream")
REM If you want don't listen to music just comment the line above
StartTime = Timer
Call FindWantedFiles(Choose_Drive)
If objFSO.FileExists(strOutputFile) Then
StopMusic
Duration = FormatNumber(Timer - StartTime, 0)
WS.Popup "The task had taken a run time until its completion about :" & vbCrlf &_
vbTab & convertTime(Duration) & vbCrlf & _
vbTab & WScript.ScriptName,10,Title,vbExclamation + vbSystemModal
ws.run strOutputFile
else
StopMusic
wscript.echo "No Matches Found"
wscript.Quit
end if
End If
'--------------------------------------------------------------------------------------------------------------
Sub FindWantedFiles(sFolder)
Dim ObjFolder,File,oFDR
On Error Resume Next
Set ObjFolder = objFSO.getFolder(sFolder)
For Each File In ObjFolder.Files
Call Search(File,strTextToFind)
Next
' Recurse into it's sub folders
For Each oFDR In ObjFolder.SubFolders
Call FindWantedFiles(oFDR.Path)
Next
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub Search(inputFile,strTextToFind)
strInputFile = inputFile
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Dim strInputFile,objInputFile,strOutputFile,strLine,strFoundText,objOutputFile
Set objInputFile = objFSO.OpenTextFile(strInputFile,intForReading, False)
strOutputFile = objFSO.GetParentFolderName(wscript.ScriptFullName) & "\Search_Result_"& strTextToFind &".txt"
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending,True,-1)
objOutputFile.WriteLine "File And Folder Path: "& DblQuote(strInputFile) & VbCRLF &_
"Search Term Used: " & DblQuote(strTextToFind) & vbCRLF &_
"Search Outcome: "& DblQuote(strFoundText) & VbCRLF & String(100,"*")
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
Loop
objInputFile.Close
Set objInputFile = Nothing
End sub
'--------------------------------------------------------------------------------------------------------------
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'--------------------------------------------------------------------------------------------------------------
Sub Play(URL)
Dim ws,fso,f,TempFile,TempFolder
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
TempFolder = WS.ExpandEnvironmentStrings("%Temp%")
TempFile = TempFolder & "\RadioEuroDance90.vbs"
Set f = fso.OpenTextFile(Tempfile,2,True)
f.Writeline "Call Play(" & chr(34) & URL & chr(34) & ")"
f.Writeline "Sub Play(URL)"
f.Writeline "Set Sound = CreateObject(""WMPlayer.OCX"")"
f.Writeline "Sound.URL = URL"
f.Writeline "Sound.settings.volume = 100"
f.Writeline "Sound.Controls.play"
f.Writeline "While Sound.playState <> 1"
f.Writeline "wscript.sleep 100"
f.Writeline "Wend"
f.Writeline "End Sub"
f.close
ws.run "cmd /c Start ""Playing Music"" /Min cscript //NoLogo " & Tempfile & "",1,True
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub StopMusic()
Set ws = CreateObject("wscript.Shell")
ws.run "Taskkill /F /IM ""cscript.exe""",0,True
End Sub
'---------------------------------------------------------------------------------------------------------------
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'---------------------------------------------------------------------------------------------------------------
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'---------------------------------------------------------------------------------------------------------------
Function convertTime(seconds)
Dim ConvSec,ConvHour,ConvMin
ConvSec = seconds Mod 60
If Len(ConvSec) = 1 Then
ConvSec = "0" & ConvSec
End If
ConvMin = (seconds Mod 3600) \ 60
If Len(ConvMin) = 1 Then
ConvMin = "0" & ConvMin
End If
ConvHour = seconds \ 3600
If Len(ConvHour) = 1 Then
ConvHour = "0" & ConvHour
End If
convertTime = ConvHour & ":" & ConvMin & ":" & ConvSec
End Function
'-------------------------------------------------------------------------------------------------------------
Function inArray(arr,obj)
Dim value
inArray = False
For Each value in arr
If UCase(value) = UCase(obj) Then
inArray = True
Exit For
End If
Next
End Function
'-----------------------------------------------------------------------
#7 06 Jun 2021 16:02
HedgeHopper
Hi, Hackoo, very many thanks for your assistance with the script. I have added a "Still Searching" repeating message as an alternative to listening to online music. Not very sophisticated I know but it was the best I could do as otherwise I wouldn't know if the script was active or not unless I checked through Task Manager. Unfortunately, I don't have the expertise to add a Progression Bar or display the file name as it is being searched.
This is not the first time you have helped me and I am always amazed at the depth of your knowledge of vbscript. The last time was on computing.net where as ColDon I had a problem with google image search results for "steam drifters". Sadly I never did get it finally sorted out. Each search page result kept duplicating up to 10 images already included in the previous search page results. It was sad to see computing.net has now ceased to exist. Now I need to find a replacement forum. But it was much sader that MIcrosoft has deprecated vbscript. Although not very adept in using it I was very fond of it.
Thank you so much once again
Keep well and stay covid safe!
Code: Select all
Option Explicit
If AppPrevInstance() Then
MsgBox "The script is already Running" & vbCrlf &_
CommandLineLike(WScript.ScriptName),VbExclamation,"The script is already Running"
WScript.Quit
Else
Dim Title1,Title2,Title3,Title4,objFSO,d,dc,RootDrive,Ready_Drives
Dim Choose_Drive,Message,Array_Drives
Dim strTextToFind, ws,StartTime,Path,strOutputFile
Dim Duration
Duration = 1
Array_Drives = Array()
Title1 = "Drive Option Dialogue"
Title2 = "Drive Choice Confirmation"
Title3 = "Drive Error Message"
Title4 = "Search Result Data"
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTextToFind = Inputbox("Enter The Search Text Below","Search Dialogue","Enter Keyword Here")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
path = objFSO.GetParentFolderName(wscript.ScriptFullName)
strOutputFile = path & "\Search_Result_"& strTextToFind &".txt"
If objFSO.FileExists(strOutputFile) Then
objFSO.DeleteFile(strOutputFile)
End if
Set dc = objFSO.Drives
For Each d in dc
If d.IsReady Then
RootDrive = d.Driveletter & ":"
ReDim Preserve Array_Drives(UBound(Array_Drives) + 1)
Array_Drives(UBound(Array_Drives)) = RootDrive
Ready_Drives = Ready_Drives & RootDrive & vbcrlf
End If
Next
Message = "Choose One Of The Following Drives:" & vbCrLf & vbCrLf & Ready_Drives
Do
Choose_Drive = Inputbox(Message,Title1,Array_Drives(0))
If Choose_Drive = "" Then Wscript.Quit
If inArray(Array_Drives,Choose_Drive) Then
MsgBox "You Have Opted To Scan Drive " & chr(34) & UCase(Choose_Drive) & chr(34),vbInformation,Title2
Else
MsgBox "ERROR ==> " & chr(34) & UCase(Choose_Drive) & chr(34) & " does not exists ",vbCritical,Title3
End If
Loop Until inArray(Array_Drives,Choose_Drive)
REM Just to play some music because the task can be take a long time
'Call Play("http://94.23.221.158:9197/stream")
REM If you want don't listen to music just comment the line above
StartTime = Timer
Call FindWantedFiles(Choose_Drive)
If objFSO.FileExists(strOutputFile) Then
StopMusic
Duration = FormatNumber(Timer - StartTime, 0)
WS.Popup "Time Taken To Complete This Task Was About :" & vbCrlf &_
vbTab & Space(10) & convertTime(Duration) & vbCrlf & _
vbTab & WScript.ScriptName,10,Title4,vbExclamation + vbSystemModal
ws.run strOutputFile
else
StopMusic
wscript.echo "No Matches Found"
wscript.Quit
end if
End If
'--------------------------------------------------------------------------------------------------------------
Sub FindWantedFiles(sFolder)
Dim ObjFolder,File,oFDR
On Error Resume Next
Set ObjFolder = objFSO.getFolder(sFolder)
For Each File In ObjFolder.Files
Call Search(File,strTextToFind)
Next
' Recurse into it's sub folders
For Each oFDR In ObjFolder.SubFolders
Call FindWantedFiles(oFDR.Path)
Next
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub Search(inputFile,strTextToFind)
strInputFile = inputFile
Const intForReading = 1
Const intForWriting = 2
Const intForAppending = 8
Dim strInputFile,objInputFile,strOutputFile,strLine,strFoundText,objOutputFile
Set objInputFile = objFSO.OpenTextFile(strInputFile,intForReading, False)
strOutputFile = objFSO.GetParentFolderName(wscript.ScriptFullName) & "\Search_Result_"& strTextToFind &".txt"
Do until objInputFile.atEndOfStream
strLine = objInputFile.ReadLine
Message = CreateObject("WScript.Shell").PopUp(" Still Searching!", Duration, "")
If InStr(strLine,strTextToFind) > 0 Then
strFoundText = strLine
If strFoundText <> "" Then
Set objOutputFile = objFSO.OpenTextFile(strOutputFile,intForAppending,True,-1)
objOutputFile.WriteLine "File And Folder Path: "& DblQuote(strInputFile) & VbCRLF &_
"Search Term Used: " & DblQuote(strTextToFind) & vbCRLF &_
"Search Outcome: "& DblQuote(strFoundText) & VbCRLF & String(100,"*")
objOutputFile.Close
Set objOutputFile = Nothing
End If
End If
'Message = CreateObject("WScript.Shell").PopUp(" Still Searching!", Duration, "")
Loop
objInputFile.Close
Set objInputFile = Nothing
End sub
'--------------------------------------------------------------------------------------------------------------
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'--------------------------------------------------------------------------------------------------------------
Sub Play(URL)
Dim ws,fso,f,TempFile,TempFolder
Set ws = CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
TempFolder = WS.ExpandEnvironmentStrings("%Temp%")
TempFile = TempFolder & "\RadioEuroDance90.vbs"
Set f = fso.OpenTextFile(Tempfile,2,True)
f.Writeline "Call Play(" & chr(34) & URL & chr(34) & ")"
f.Writeline "Sub Play(URL)"
f.Writeline "Set Sound = CreateObject(""WMPlayer.OCX"")"
f.Writeline "Sound.URL = URL"
f.Writeline "Sound.settings.volume = 100"
f.Writeline "Sound.Controls.play"
f.Writeline "While Sound.playState <> 1"
f.Writeline "wscript.sleep 100"
f.Writeline "Wend"
f.Writeline "End Sub"
f.close
ws.run "cmd /c Start ""Playing Music"" /Min cscript //NoLogo " & Tempfile & "",1,True
End Sub
'--------------------------------------------------------------------------------------------------------------
Sub StopMusic()
Set ws = CreateObject("wscript.Shell")
ws.run "Taskkill /F /IM ""cscript.exe""",0,True
End Sub
'---------------------------------------------------------------------------------------------------------------
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'---------------------------------------------------------------------------------------------------------------
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'---------------------------------------------------------------------------------------------------------------
Function convertTime(seconds)
Dim ConvSec,ConvHour,ConvMin
ConvSec = seconds Mod 60
If Len(ConvSec) = 1 Then
ConvSec = "0" & ConvSec
End If
ConvMin = (seconds Mod 3600) \ 60
If Len(ConvMin) = 1 Then
ConvMin = "0" & ConvMin
End If
ConvHour = seconds \ 3600
If Len(ConvHour) = 1 Then
ConvHour = "0" & ConvHour
End If
convertTime = ConvHour & ":" & ConvMin & ":" & ConvSec
End Function
'-------------------------------------------------------------------------------------------------------------
Function inArray(arr,obj)
Dim value
inArray = False
For Each value in arr
If UCase(value) = UCase(obj) Then
inArray = True
Exit For
End If
Next
End Function
'-----------------------------------------------------------------------
#8 06 Jun 2021 16:20
Simon Sheppard
Microsoft have only deprecated/disabled vbscript running in the web browser IE 11 (it's never been supported in other web browsers)....But it was much sader that MIcrosoft has deprecated vbscript.
I think its fair to say it's in maintenance mode as all new development effort is on PowerShell, but it's still available and likely to work for many years into the future.
original thread: https://ss64.org/oldforum/viewtopic.php?id=2582