Using vbscript search through all folders on any drive

Microsoft Windows
Post Reply
User avatar
MigrationUser
Posts: 336
Joined: 2021-Jul-12, 1:37 pm
Been thanked: 2 times
Contact:

Using vbscript search through all folders on any drive

Post by MigrationUser »

05 May 2021 15:48
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
HedgeHopper 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?
Perhaps something like that can did the trick wink

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
...But it was much sader that MIcrosoft has deprecated vbscript.
Microsoft have only deprecated/disabled vbscript running in the web browser IE 11 (it's never been supported in other web browsers).

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
Post Reply