Posts Tagged ‘windows script host’

h1

A Flexible Progress Window in VBScript

19/07/2009

This post has now been migrated to ThoughtAsylum.com.

Follow this link to go directly to the article.

Advertisements
h1

Self Installing VB Scripts

18/07/2009

I like using VB Scripts and the Windows Script Host to resolve issues as it has proved quick and flexible for most tasks.  One thing I have found problematic on occasion is the installation of the scripts on a user’s PC.  It takes time to do if it is not being deployed using logon scripts, group policy, etc.  To this end I decided to write a function to allow a script to install itself.   The script below is primarily made up from three functions/routines.

Starting from the bottom, the BuildFolderPath() function just takes a file path and adds a backslash to the end if it needs one.

The next function is a little more interesting.  ScriptPath() returns the folder in which the script is being run from.  Note that if it is being run from a shortcut it is the target folder.  This script works by removing the name of the script from the full file path of the script file.

The last chunk of code is the sub routine InstallScript() and does the majority of the work so to speak.  This checks to see if the script is in the correct location.  If it is not it asks the user for permission to copy it from the current location to the one against which it checked.  This does of course rely on the user having appropriate file permissions to copy the script there in the first place, but if we need anything more then some sort of executable or direct access by an administrator is always going to be best otherwise you’ll be handing out administrator passwords verbally or in plain text in script files.  Once installed (or if the user chose not to install) there is a bit of feedback to the user and the script ends.  If the script is running from the right location, no further action is taken and the script continues.

Option Explicit

Const INSTALL_TO = "%UserProfile%\SendTo"

InstallScript INSTALL_TO

Msgbox "The script is being run from the right place..."

'This routine checks if the script is in the right folder location and if it
'isn't it will give the user the option of copying the script to the right location
Sub InstallScript(p_strInstallTo)
 Dim strInstallToFolder
 Dim objShell, objFSO

 'Set the installation folder
 Set objShell = CreateObject( "WScript.Shell" )
 strInstallToFolder = BuildFolderPath(objShell.ExpandEnvironmentStrings(p_strInstallTo))

 If Not strInstallToFolder = ScriptPath Then
 'Copy the script to the correct folder if the user agrees
 If Msgbox ("This script is not being run from the expected location." & vbCrLf & _
 "Would you like to install it to " & strInstallToFolder & " now?", _
 vbYesNo + vbQuestion, "Install Script") = vbYes Then

 Set objFSO = CreateObject("Scripting.FileSystemObject")
 objFSO.CopyFile WScript.ScriptFullName, strInstallToFolder & WScript.ScriptName

 MsgBox "The script has been installed/updated.", vbOkOnly & vbInformation, "Install Complete"
 Else
 MsgBox "The script has not been installed and will not run.", vbOkOnly + vbExclamation, "Install Cancelled"
 End If

 'Finish the script at this point
 WScript.Quit
 End If

End Sub

'This function returns the path which the script is running from
Function ScriptPath()
 ScriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
End Function

'This function just adds a trailing backslash if there isn't one
Function BuildFolderPath(p_strPath)
 If Right(p_strPath,1) = "\" Then
 BuildFolderPath = p_strPath
 Else
 BuildFolderPath = p_strPath & "\"
 End If
End Function

An interesting thing to note is that I’ve passed folder paths through the ExpandEnvironmentStrings() function.  This converts any environment variables in the string and allows them to be converted to their full path.  If you want to know more about environment variables I’d recommend a few minutes browsing this page on environment variables in Windows XP.

So all you have to do is decide on a folder where you want the script run from and then pop these functions into your script.  Personally I like to create shortcuts for scripts too (e.g. in the user’s send to folder, start menu or the desktop).  I’ll be posting a little later on how to add that to your toolbox – particularly useful for installations like this.

h1

VBS – Duplicate Folder Structure

28/03/2009

Armed with my folder browser script I finally finished rounding out my script to clone / duplicate a folder structure.

On occasion I produce a folder/directory structure which I’d like to be able to reuse as a template – e.g. on a project.  The problem is that it already has lots of files in and I have to copy the whole thing and then use an ‘open’ search to list the files in the new structure so that they can be deleted, but if there are lots of big files this operation can be slow and the inefficiency of it grates against my programmer’s nature.

Thus came about the writing of a little bit of VBScript to copy an existing folder structure and effectively clone it to another area on a file system.  So here’s the script … I hope you find it useful.

Option Explicit

'Defintions
Const ForReading = 1
Const ForWriting = 2
Const MAKE_FILE = "BuildFolders.txt"

Dim objFSO, objFolder, objFile
Dim strSourceFolder, strDestinationFolder, strBuildFoldersFile
Dim intFolders

'Initialise and capture folder paths
intFolders = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
strSourceFolder = SelectFolder("Select a source folder")
strDestinationFolder = SelectFolder("Select a destination folder")
strBuildFoldersFile = strDestinationFolder & "\" & MAKE_FILE

'Read, store and then build the new folder struture
CreatestrDestinationFolder
CreateBuildFile
MakeFromBuildFile

'Finalise
DeleteBuildFile
MsgBox "Created " & intFolders & " folders", vbOKOnly & vbInformation, "Folder Generation complete"

'-------------
'SUB ROUTINES
'-------------

'Read the source folder structure and store it
Sub CreateBuildFile()
	objFSO.CreateTextFile(strBuildFoldersFile)
	Set objFile = objFSO.CreateTextFile(strBuildFoldersFile, True)
	ReadstrSourceFolders(strSourceFolder)
	objFile.Close
End Sub

'Create the destination folder - should exist from the selection ... but just in case
'I (or someone else) wants to parameterise this script later on...
Sub CreatestrDestinationFolder()
	If Not objFSO.FolderExists(strDestinationFolder) Then
		objFSO.CreateFolder(strDestinationFolder)
		intFolders = intFolders +1
	End If
End Sub

'Create the new folder structure
Sub MakeFromBuildFile()
	Set objFile = objFSO.OpenTextFile(strBuildFoldersFile, ForReading)
	Do While Not objFile.AtEndOfStream
		objFSO.CreateFolder(strDestinationFolder & objFile.ReadLine)
		intFolders = intFolders +1
	Loop
	objFile.Close
End Sub

'Remove the file that was holiding the data structure
Sub DeleteBuildFile()
	objFSO.DeleteFile(strBuildFoldersFile)
End Sub

'Write a folder structure to the build file
Sub ReadstrSourceFolders(p_strSource)
	Dim colSubFolders
	Dim objSubFolder

	Set objFolder = objFSO.GetFolder(p_strSource)
	Set colSubfolders = objFolder.Subfolders
	For Each objSubfolder in colSubfolders
		objFile.WriteLine(StripstrSourceFolder(objSubfolder.Path))
		ReadstrSourceFolders(objSubfolder.Path)
	Next
End Sub

'Remove the source folder path from a string (i.e. a sub folder's path)
Function StripstrSourceFolder(p_strFolder)
	StripstrSourceFolder = Right(p_strFolder,(Len(p_strFolder)-Len(strSourceFolder)))
End Function

'----------
'FUNCTIONS
'----------
'Select a folder
Function SelectFolder(pstrDialogLabel)
	'Select a folder
	Const BIF_returnonlyfsdirs   = &H0001
	Const BIF_editbox            = &H0010

	Dim objBrowseFolderDialog, objFolder, objFSO, objSelection
	Dim bBrowseForFolder

	Set objBrowseFolderDialog = WScript.CreateObject("Shell.Application")

	bBrowseForFolder = true

	While bBrowseForFolder
		Set objFolder = objBrowseFolderDialog.BrowseForFolder (&H0, pstrDialogLabel, BIF_editbox + BIF_returnonlyfsdirs)

		'Check that something has been returned
		If IsValidFolder(objFolder) Then
			Set objFSO = CreateObject("Scripting.FileSystemObject")

			Set objSelection = objFolder.Self
			If objFSO.FolderExists(objSelection.Path) Then
				'A valid folder has been selected
				SelectFolder = objSelection.Path
				bBrowseForFolder = false
			Else
				'The selection is not a valid folder, try again...
				MsgBox objFolder.Title & " is not a valid folder, please select another folder" _
					, vbOKOnly & vbExclamation, "Invalid Selection"
			End If
		Else
			'Nothing was selected, so return a null string
			SelectFolder = ""
			bBrowseForFolder = false
		End If
	Wend
End Function

Function IsValidFolder(pobjFolder)
	'Check that we have a valid value
	'i.e. you can concatenate it to a string
	Dim strTest

	On Error Resume Next

	strTest = " " & pobjFolder

	If Err  0 Then
		IsValidFolder = false
	Else
		IsValidFolder = true
	End If

	On Error GoTo 0
End Function
h1

VBScript – Select a Folder

28/03/2009

This post has now been migrated to ThoughtAsylum.com.

Follow this link to go directly to the article.

h1

Continuous Ping

31/01/2009

Sometimes when testing network connectivity to a server on the local LAN or a web site I use the ubiquitous PING to do the job.  If I need to do it repeatedly I tend to write a quick DOS batch file (a text based script with a file extension of BAT or CMD).

For example this script would repeatedly ping localhost – the name used for the machine the script is being run on.

@echo off
:START
Ping -n 1 localhost
Goto START

A few years ago I even extended this to include a ping count but it didn’t really add much. I decided it would be more useful to have something that at least gave an indication of how many “good and bad” pings had occurred. At the same time I also found that I wasn’t always necessarily at my computer as I might be tinkering with cables and other networking gear so having some sort of audible cue as to how the pings were going.

I put together the following VB Script to do just this. It hasn’t been tested extensively and I’m sure that there could be a bit more validation. When the script is run it asks for the host to ping and a time at which to stop pinging. It then opens up an Internet Explorer window that displays the information about the pinging.

Option Explicit

'Settings:
'- Number of PC speaker beeps on ping successes/failures
Const BEEPS_ON_PING = 1
Const BEEPS_ON_NO_PING = 3
'- Milliseconds of pause between pings
Const PAUSE_MS = 200
'- Milliseconds pause before automatically closing the progress window
Const AUTO_CLOSE = True
Const FINAL_PAUSE = 5000

'Variable definitions
Dim strHost
Dim dtEnd
Dim objShell, objExplorer
Dim intSuccessfulPingCount, intUnsuccessfulPingCount

'Initialise
Set objExplorer = CreateObject("InternetExplorer.Application")

objExplorer.Navigate "about:blank"
objExplorer.ToolBar = 0
objExplorer.StatusBar = 0
objExplorer.Left = 0
objExplorer.Top = 0
objExplorer.Width = 400
objExplorer.Height = 400
objExplorer.Document.Body.Style.Cursor = "default"
intSuccessfulPingCount = 0
intUnsuccessfulPingCount = 0


'If we don't have a host then ask for one
If Wscript.Arguments.Count < 1 Then
	strHost = InputBox("Please enter the host to ping", "Enter Host", "localhost")
Else
	strHost = Wscript.Arguments(0)
End If

'Double check what we have
If Len(strHost)  0
	'Carry out the ping
	If Ping(strHost, False) = True Then
		'Ping successful
		intSuccessfulPingCount = intSuccessfulPingCount + 1
		Beep(BEEPS_ON_PING)
		WScript.Sleep(PAUSE_MS)
	Else
		'Ping unsuccessful
		intUnsuccessfulPingCount = intUnsuccessfulPingCount + 1
		Beep(BEEPS_ON_NO_PING)
		WScript.Sleep(PAUSE_MS)
	End If
	UpdatePings "<p><b>RUNNING...</b></p>"
Wend

'Finalise
objExplorer.Document.Body.Style.Cursor = "default"
If AUTO_CLOSE Then
	UpdatePings("<p><b>AUTO CLOSING...</b></p>")
	Wscript.Sleep FINAL_PAUSE
	objExplorer.Quit
Else
	UpdatePings("<p><b>PING CYCLE COMPLETED</b></p>")
End If


'Update the display of pings
Sub UpdatePings(p_strSuffix)
	Dim strDisplay

	strDisplay = ""

	strDisplay = strDisplay & "<p>"
	strDisplay = strDisplay & "Finish pinging @ "
	strDisplay = strDisplay & dtEnd
	strDisplay = strDisplay & "<br />"
	strDisplay = strDisplay & "Currently ... "
	strDisplay = strDisplay & Now()
	strDisplay = strDisplay & "</p>"

	strDisplay = strDisplay & "<hr>"

	strDisplay = strDisplay & "<p>"
	strDisplay = strDisplay & "<table border='0'>"
	strDisplay = strDisplay & "<tr>"
	strDisplay = strDisplay & "<td><font color='green'>Successful pings</font></td>"
	strDisplay = strDisplay & "<td><font color='green'>"
	strDisplay = strDisplay & intSuccessfulPingCount
	strDisplay = strDisplay & "</font></td>"
	strDisplay = strDisplay & "</tr>"
	strDisplay = strDisplay & "<tr>"
	strDisplay = strDisplay & "<td><font color='red'>Unsuccessful pings</font></td>"
	strDisplay = strDisplay & "<td><font color='red'>"
	strDisplay = strDisplay & intUnsuccessfulPingCount
	strDisplay = strDisplay & "</font></td>"
	strDisplay = strDisplay & "</tr>"
	strDisplay = strDisplay & "</table>"
	strDisplay = strDisplay & "</p>"

	strDisplay = strDisplay & "<hr>"

	strDisplay = strDisplay & "<p>"
	strDisplay = strDisplay & "Auto Close Enabled: "
	strDisplay = strDisplay & AUTO_CLOSE
	strDisplay = strDisplay & "</p>"

	strDisplay = strDisplay & "<hr>"

	strDisplay = strDisplay & p_strSuffix

	objExplorer.Document.Body.InnerHTML = strDisplay
End Sub


'This function pings the specified host
Function Ping(p_strHost, p_boolDisplay)
	Dim objPing, objStatus

	Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery ("select * from Win32_PingStatus where address = '" & p_strHost & "'")

	For Each objStatus in objPing
		If IsNull(objStatus.StatusCode) or objStatus.StatusCode0 then
			Ping = False
			If p_boolDisplay Then
				WScript.Echo "Status code is " & objStatus.StatusCode
			End If
		Else
			Ping = True
			If p_boolDisplay Then
				Wscript.Echo "Bytes = " & vbTab & objStatus.BufferSize
				Wscript.Echo "Time (ms) = " & vbTab & objStatus.ResponseTime
				Wscript.Echo "TTL (s) = " & vbTab & objStatus.ResponseTimeToLive
			End If
		End if
	Next
End Function 


'Beep the PC speaker a number of times equal to the p_intBeeps parameter
Function Beep(p_intBeeps)

	Dim objShell, intCount, strCommand

	'Check we have a valid number of beeps not fool proof but it will do for now
	Beep = False
	If IsNumeric(p_intBeeps) Then
		If p_intBeeps > 0 Then
			Beep = True
		End If
	End If

	If Beep Then
		'Build the command string to run
		strCommand = "cmd /c echo"
		For intCount = 1 to p_intBeeps
			strCommand = strCommand & " " & chr(007)
		Next

		'Run the command in the background
		Set objShell = Wscript.CreateObject("wscript.Shell")
		objShell.Run strCommand, 0

		Beep = True
	End If
End Function

There are also a few options in the script to specify numbers of beeps for successful and unsuccessful pings as well as auto closing of the Internet Explorer window and lengths of pauses between pings and before auto closing the window.