Solved

Turning this vbs script into a hta

Posted on 2009-04-13
2
1,547 Views
Last Modified: 2012-06-22
Hi guys, hope you are all well.
Guys, i have the following script that works fine (in the snippet), but what id like to do is:

1) Turn it into a hta file
2) When it runs, instead of outputting to c:\diskspace.txt, output within the hta application itself.

Any help greatly appreciated.
set objFSO = createobject("Scripting.FileSystemObject")

Set objnet = CreateObject("wscript.network")

 

Const ForReading = 1

Const ForAppend = 8

const strReport = "c:\diskspace.txt"

Set strList = objfso.OpenTextFile("c:\servers.txt", ForReading)

'txt = vbtab & vbtab & "Drive" & vbtab & "Size" & vbtab & "Used" & vbtab & "Free" & vbtab & "Free(%)" & vbcrlf

 

Do Until strList.AtEndOfStream

strComputer = strList.ReadLine

If Reachable(strComputer) Then

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set colItems = objWMIService.ExecQuery("Select * From Win32_LogicalDisk Where DeviceID = 'C:'")

'txt = vbtab & vbtab & "Drive" & vbtab & "Size" & vbtab & "Used" & vbtab & "Free" & vbtab & "Free(%)" & vbcrlf

For Each objItem in colItems

	

	

	pctFreeSpace = INT((objItem.FreeSpace / objItem.Size) * 1000)/10

	strDiskSize = Int(objItem.Size /1073741824) & "Gb"

	strFreeSpace = Int(objItem.FreeSpace /1073741824) & "Gb"

	strUsedSpace = Int((objItem.Size-objItem.FreeSpace)/1073741824) & "Gb"

	txt = strComputer & vbTab & objItem.Name & vbtab & strDiskSize & vbtab & strUsedSpace & vbTab & strFreeSpace & vbtab & pctFreeSpace

 

Next

 

writeTextFile txt, strReport

Else

txt = strComputer & vbTab & "Unreachable"

writeTextFile txt, strReport

End If

Loop

wscript.echo "Report written to " & strReport 

 

' Procedure to write output to a text file

private sub writeTextFile(byval txt,byval strTextFilePath)

	

 

 

	set objTextFile = objFSO.OpenTextFile(strTextFilePath,ForAppend)

 

	objTextFile.Write(txt & vbNewLine)

 

	objTextFile.Close

	SET objTextFile = nothing

end sub

 

Function Reachable(strComputer)

 strCmd = "ping -n 1 " & strComputer

 Set objShell = CreateObject("WScript.Shell")

 Set objExec = objShell.Exec(strCmd)

 strTemp = UCase(objExec.StdOut.ReadAll)

 

 If InStr(strTemp, "REPLY FROM") Then

 Reachable = True 

 Else

 Reachable = False

 End If

End Function

Open in new window

0
Comment
Question by:Simon336697
2 Comments
 
LVL 14

Accepted Solution

by:
yehudaha earned 500 total points
ID: 24134848
hey try this
<html>

<!-- 

**************************************************************************
 

	Copyright (c) SAPIEN Technologies, Inc. All rights reserved

   This file is part of the PrimalScript 2007 Code Samples.
 

	File:  DiskReporter.hta
 

	Comments:

	

		REQUIREMENTS:  

		Windows 2000 SP4 (Windows XP preferred)

		WMI

		800x600 screen resolution

		Administrative credentials for remote systems

	COMMENTS: 

	Version 2 Changes:

	

	Added Export feature to save results to HTML, Microsoft Excel,

	Microsoft Word,a text file or a CSV file.

	

	Added option for single computer scan.

	

	Added code to disable buttons and features when they couldn't or

	shouldn't be used.

	

	Version 1 Comments:

	This HTA is used to monitor logical disk space from a list of servers.

	The list of servers (or desktops) can be in a text list of computer

	names, a domain group (either distribution or security) or an OU if

	you are a member of a domain.

	

	If the client running the console is using Windows XP or 2003, the

	remote system is first pinged to check connectivity before attempting

	a WMI connection.  If the client is running Windows 2000 the ping will

	fail and an attempt to connect via WMI will still be made.  The only

	drawback to using Windows 2000 is that if a remote system is offline,

	it takes slightly longer to process and you will get a different error

	message.

	

	A report is created that shows logical disk size, space used and space

	free.  A colored graphical representation depicts how much of the drive 

	is being utilized.  If the disk utilization is over 80%, the graph will 

	be RED.  If it is less than 50% it will be GREEN.  

	

	You may use alternate credentials.  It is recommended to use

	the format domain\username.  If you use alternate credentials and open

	the remote computer in the computer management console, you will be

	prompted to re-enter the password in a RunAs window.  If you open a 

	remtoe drive in Windows Explorer from the console you will be preompted

	to re-enter your alternate credentials.  Alternate credentials cannot

	be used for the local (ie client running the HTA) computer.

	

	The console will save your last used setting for textfile, group name,

	or OU that you process successfully in the registry under

	HKCU\Software\SAPIEN Technologies\DiskReporter\.

	

	When you print, only the report table and a header will print. None of

	the buttons or input boxes will print.

	
 

   Disclaimer: This source code is intended only as a supplement to 

				SAPIEN Development Tools and/or on-line documentation.  

				See these other materials for detailed information 

				regarding SAPIEN code samples.
 

	THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT WARRANTY OF ANY

	KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE

	IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A

	PARTICULAR PURPOSE.
 

'**************************************************************************

	

-->
 

<head>

<style media="print">

 .hide {

 	display: none;

}

</Style>

<title>Disk Reporter</title>
 

<Script language="VBScript">

Sub window_OnLoad()

Self.Resizeto 625,425

serverlist.focus

DisableButtons True

ClearTemp

End Sub
 

'**********************************

'*  Enable or Disable buttons     *

'**********************************

Sub DisableButtons(blnFlag)

print_button.disabled=blnFlag

checklist.disabled=blnFlag

alternate_credentials.disabled=blnFlag

export_button.disabled=blnFlag

End Sub
 

'**********************************

'*  Display Version & About Info  *

'**********************************

Sub About()

On Error Resume Next

strAbout="DiskReporter.hta" & VbCrLf

strAbout=strAbout & "Version 2.0" & VbCrLf

strAbout=strAbout & "http://www.SAPIEN.com"

MsgBox strAbout,vbOKOnly+vbInformation,"About Disk Reporter"
 

End Sub
 

'**********************************

'*  Clear Temp File				  *

'**********************************

Sub ClearTemp()

Dim oShell,oEnv,oFSO
 

On Error Resume Next

Set oShell=CreateObject("wscript.shell")

Set oEnv=oShell.Environment("System")

strTemp=oShell.ExpandEnvironmentStrings("%TEMP%")

strTempFile=strTemp & "\~$jdhdr.txt"
 

Set oFSO=CreateObject("Scripting.FileSystemObject")

If oFSO.FileExists(strTempFile) Then oFSO.DeleteFile(strTempFile)
 

End sub

'**********************************

'*  Process Server list           *

'**********************************

Sub ProcessList()

On Error Resume Next
 

Dim oFSO,oFileIn,oFileOut,oArray

Dim oShell, oEnv

Dim oProgressWindow
 

'clear entries

exporttext.value=""

report.innerhtml=""

footer.innerhtml=""
 

'make sure something is entered in source.value 

If source.value="" Then

	report.InnerHTML="<font face=Tahoma size=2 color=Red>You did not enter anything in the source field.</font>"

	source.focus

	Exit Sub

End If
 

Set oShell=CreateObject("wscript.shell")

Set oEnv=oShell.Environment("System")

strTemp=oShell.ExpandEnvironmentStrings("%TEMP%")

strTempFile=strTemp & "\~$jdhdr.txt"
 

Set oFSO=CreateObject("Scripting.FileSystemObject")
 
 
 

strHTML=strHTML & "<br><table width=100% cellpadding=2 cellspacing=2 Border=1><Caption align=Center><Font Face=Tahoma Size=3>Logical Drive Utilization</Font></Caption>"

Select Case serverlist.value

	Case "COMPUTER"

		oArray=Array(source.value)

	Case "TEXT"

		slist=source.value

		If oFSO.FileExists(sList) Then

		'build temp array from entries

			Set oFileIn=oFSO.OpenTextFile(sList,1)

			Do While oFileIn.AtEndOfStream<>True

					oArray=Split(oFileIn.ReadAll,VbCrLf)

			Loop

			oFileIn.Close

		Else

		'write error message

			strHTML="<Font Face=Tahoma Color=RED Size=2>Could not open " & source.Value & "</Font>"

			report.InnerHTML=strHTML

			footer.InnerHTML="<font face=Tahoma Size=1><I>Last updated " & Now & "</I></Font>"

			Exit Sub

			End If

	Case "GROUP"

		Dim oNetwork,oGrp

		Err.Clear

		Set oNetwork=CreateObject("WScript.Network")

		Set oGrp=GetObject("WinNT://" & oNetwork.UserDomain & "/" & source.value & ",Group")

		If Err.Number<>0 Then

			strHTML="<Font Face=Tahoma Color=RED Size=2>Failed to find or open the group: " & oNetwork.UserDomain & "\" & source.value & "!</Font>"

			report.InnerHTML=strHTML

			footer.InnerHTML="<font face=Tahoma Size=1><I>Last updated " & Now & "</I></Font>"

			Err.clear

			Exit Sub

		Else

			tmpList=""

			set memberlist=oGrp.members

				For Each member In memberlist

					If Right(member.name,1)="$" Then   'only get computer objects

						tmplist=tmpList &"," & Left(member.name,Len(member.name)-1) 'parse out $ at end of name

					End if

				Next

		tmpList=Mid(tmpList,2)

		oArray=Split(tmpList,",")

		End If

	Case "OU"

		Dim oOU

		tmpList=""

		Err.Clear

		Set oOU=GetObject("LDAP://" & source.value)

		If Err.Number<>0 Then

			strHTML="<Font Face=Tahoma Color=RED Size=2>Failed to open LDAP://" & source.value & "</Font>"

			report.InnerHTML=strHTML

			footer.InnerHTML="<font face=Tahoma Size=1><I>Last updated " & Now & "</I></Font>"

			Err.clear

			Exit Sub

		else

			oOU.Filter=Array("computer")

			  for Each oServer In oOU

			    tmpList=tmpList & "," & oServer.CN

				Next

		End If

		tmpList=Mid(tmpList,2)

		oArray=Split(tmpList,",")

	Case Else

		strHTML="<Font Face=Tahoma Color=RED Size=2>You haven't selected a valid source!</Font>"

		report.InnerHTML=strHTML

		footer.InnerHTML="<font face=Tahoma Size=1><I>Last updated " & Now & "</I></Font>"

		Exit Sub

End Select
 

'create temp text file

Set oFileOut=oFSO.CreateTextFile(strTempFile,True)

oFileOut.WriteLine "Server~Drive(Size)~Utilization~Free(%)"

oFileOut.close

strHTML =strHTML & "<TR><TD Align=Center><Font Face=Tahoma Size=2>Server</Font></TD><TD Align=Center><Font Face=Tahoma Size=2>Drive (Size)</Font></TD><TD Align=Center><Font Face=Tahoma Size=2>Utilization</Font></TD><TD Align=Center><Font Face=Tahoma Size=2>Free (%)</Font></TD></TR>"
 

'create progress window

Set oProgressWindow = window.Open("about:blank","ProgressWindow","height=15,width=250,left=300,top=300,status=no,titlebar=no,toolbar=no,menubar=no,location=no,scrollbars=no") 

oProgressWindow.Focus()

oProgressWindow.document.body.style.fontFamily = "Tahoma"

oProgressWindow.document.body.style.fontSize = "10pt"

oProgressWindow.document.title = "Please wait"

oProgressWindow.document.body.style.borderStyle = "none"

oProgressWindow.document.body.style.marginTop = 15
 

For x=0 To UBound(oArray)

  sServer=oArray(x)

  If sServer<>"" Then

  	If UCase(source.value)=Ucase(sServer) Then 

  		strProcess="Analyzing computer : " & UCase(sServer)

  	Else

  		strProcess="Processing " & Lcase(serverlist.value) & " source " & Source.value &_

	 ": " & UCase(sServer)

  	End If

	oProgressWindow.document.body.innerhtml="<Font Face=Tahoma Size=2>" &strProcess & "</Font><br><br><Font Face=Tahoma Size=2 Color=Red>Do Not Close This Window.</Font>"

	

strHTML=strHTML & GetUtilization(sServer)

  End If

Next
 

strHTML=strHTML & "</Table><Font face=Tahoma size=1 Color=#FF0000> >80% utilization  </Font>"

strHTML=strHTML &  "<Font face=Tahoma size=1 Color=#CC9900> <80% utilization  </Font>"

strHTML=strHTML &  "<Font face=Tahoma size=1 Color=#008000> <50% utilization </Font>"

report.InnerHTML=strHTML

footer.InnerHTML="<font face=Tahoma Size=1><I>Last updated " & Now & "</I></Font>"
 

'close in progress window

oProgressWindow.Close

checklist.focus

'update registry with last used value

SetMRU serverlist.value,source.value 
 

'sleep for refresh interval then run ProcessList again

Interval=setTimeout("ProcessList()",(refresh.value*60)*1000)

End Sub
 

'**********************************

'*  Get Disk Utilization function *

'**********************************

Function GetUtilization(sServer)

On Error Resume Next

Dim oRef

Dim oLocator

Dim oService

Dim oShell,oFSO,oFile

Dim oEnv
 

Set oShell=CreateObject("wscript.shell")

Set oEnv=oShell.Environment("System")

strTemp=oShell.ExpandEnvironmentStrings("%TEMP%")

strTempFile=strTemp & "\~$jdhdr.txt"
 

Set oFSO=CreateObject("Scripting.FileSystemObject")

Set oFile=oFSO.OpenTextFile(strTempFile,8)
 

Err.Clear

'reinitialize

    PerFree=""

	Graph=""

	Size=""

	Free=""

	Used=""
 

'Test if server is up and reachable first.  This requires Windows XP or 2003 on the client running this HTA

	'If you are running Windows 2000, the HTA will continue to run, just possibly a little slower as it has to 

	'attempt connecting via WMI to an offline server.

If TestPing(sServer) = False Then

	oFile.WriteLine UCase(sServer) & "~Unable to connect via ping~~"

	strdetailHTML=strdetailHTML & "<TR><TD><Font Face=Tahoma Color=RED Size=1>" & UCase(sServer) &"<Font></TD><TD colspan=3><Font Face=Tahoma Color=RED Size=1>Unable to connect via ping</Font></TD></TR>"

Else
 

	Set oLocator = CreateObject("WbemScripting.SWbemLocator")

	

	If username.value="" Then 

		'connect with current credentials

		Set oService = oLocator.ConnectServer (sServer,"root\cimv2")

	Else

		'connect with alternate credentials

		Set oService = oLocator.ConnectServer (sServer,"root\cimv2",username.value,password.value)

	

	End If

	Err.Clear

	oService.Security_.impersonationlevel = 3

	If Err.Number <>0 Then

		strdetailHTML="<TR><TD><Font face=Tahoma Size=1 color=RED>" & UCase(sServer) &_

		 "</Font></TD><TD Colspan=3><Font face=Tahoma Size=1 color=RED>Could not connect to " & UCASE(sServer) & ".  Error #" &_

		  Hex(Err.Number) & ".  " & Err.Description &"  (Verify your credentials.)</Font></TD></TR>"

		  Err.Clear

		strErrorText="Could not connect to " & UCase(sServer) & ". Error #" &_

		  Hex(Err.Number) & ".  " & Err.Description &" (Verify your credentials.)"

	   	oFile.WriteLine UCase(sServer) & "~" & strErrorText & "~~"

	Else

		'Query for local fixed drives only

		sQuery="Select DriveType,DeviceID,Size,FreeSpace from win32_logicaldisk where DriveType='3'"

		Set oRef=oService.ExecQuery(sQuery,,48)

		For Each drive In oRef

	 		PerFree=FormatPercent(drive.FreeSpace/drive.Size,2)

	 		Size=FormatNumber(drive.Size/1048576,2)

			Free=FormatNumber(drive.FreeSpace/1048576,2)

			Used=Size-Free

			Graph=FormatNumber(Used/Size,2)*100

			

			'tweak Graph value so that if it is less than 5 at least one hash will be displayed

			If Graph/5<1 Then Graph=5

			

			strdetailHTML=strdetailHTML &  "<TR>"

			strdetailHTML=strdetailHTML &  "<TD><Font Size=1><a href=# onClick=""ManageServer('" & sServer & "')"">" & UCase(sServer) & "</a></Font></TD>"

			strdetailHTML=strdetailHTML &  "<TD><Font Size=1><a href=# onclick=""ExploreDrive('\\" & sServer & "\" & Left(drive.DeviceID,1)&"$" &"')"">" & drive.DeviceID & "\ </a>(" & Size & "MB)</Font></TD>"

			strdetailHTML=strdetailHTML &  "<TD><Font Size=1 Color=" & CHR(34) & GraphColor(graph) & Chr(34) & "><strong>" & String(Graph/5,"|") & "</strong></Font></TD>"

			strdetailHTML=strdetailHTML &  "<TD><Font Size=1>" & Free & " MB (" & PerFree & ")</Font></TD></TR>"

		

			sLine=UCase(sServer) &"~" &Chr(34)& drive.DeviceID & "\ " & "(" & Size & "MB)" & Chr(34)

			sline=sLine & "~" & String(Graph/5,"|") & "~" & Chr(34) & Free & " MB (" & PerFree & ")"  & Chr(34)

			oFile.WriteLine sLine

		

		Next

	End If

	

End If

ofile.Close
 

GetUtilization=strDetailHTML

End Function
 

'**********************************

'*  Test Ping function			  *

'*  requires XP/2003 on client    *

'**********************************

Function TestPing(sName)

On Error Resume Next

'this function requires Windows XP or 2003

Dim cPingResults, oPingResult

Set cPingResults = GetObject("winmgmts://./root/cimv2").ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address = '" & sName & "'")

For Each oPingResult In cPingResults

	If oPingResult.StatusCode = 0 Then

		TestPing = True

	Else

		TestPing = False

	End If

Next

End Function
 

'**********************************

'*  Set color for graph function  *

'*   depending on space used  	  *

'**********************************

Function GraphColor(graph)

 Const myGreen="008000"

 Const myRed="FF0000"

 Const myYellow="CC9900"
 

On Error Resume Next

	If Graph > 80 Then

	 GraphColor=myRed

	 Exit Function

	End If

	If Graph < 50 Then

	 GraphColor=myGreen

	Else

	 GraphColor=myYellow

	End If

End Function
 

'**********************************

'*  Open Computer Management 	  *

'* Console for specified server   *

'**********************************

Function ManageServer(sServer)

On Error Resume Next
 

rc=MsgBox("Do you want to open computer management for " & UCase(sServer) &_

 "?  If you specified alternate credentials you will need to reenter the password.",vbYesNo+vbQuestion,"Server Management")

If rc=vbYes Then

	'Launch computer management console connected to specified computer

	Dim objShell

	Set objShell=CreateObject("WScript.Shell")

	

	'RunAsPath=objShell.ExpandEnvironmentStrings("%systemroot%")&"\system32\runas.exe"

	If username.value="" Then

		objShell.Exec "mmc.exe %systemroot%\system32\compmgmt.msc /computer=\\" & sServer

	Else

		objShell.Run "runas /netonly /noprofile /user:" & username.value & " " &Chr(34) &"mmc.exe %systemroot%\system32\compmgmt.msc /computer=\\" & sServer & Chr(34),1,False

	End If

End If

End Function
 

'**********************************

'*  Open Drive for exploring 	  *

'**********************************

Sub ExploreDrive(sPath)

On Error Resume Next
 

rc=MsgBox("Do you want to open the selected drive in Windows Explorer? " &_

 "If you specified alternate credentials you might be prompted to re-enter them.",vbYesNo+vbQuestion,"Explore Drive")

If rc=vbYes Then

	Dim objShell

	Set objShell=CreateObject("WScript.Shell")

	objShell.Exec "explorer " & sPath

End If

End Sub
 

'**********************************

'*  Prompt for name of text file  *

'*  domain group name or OU		  *

'**********************************

Sub SourcePrompt()

DisableButtons False

'check for MostRecent in registry.  If not found,

'then use defaults

On Error Resume Next

'clear out any old entries in source

source.value=""

footer.innerhtml=""
 

'clear alternate credentials since they might not be used again

username.value=""

password.value=""

Select Case serverlist.value

	Case "COMPUTER"

		If ReadMRU("COMPUTER")="" Then

			Dim objNetwork

			Set objNetwork=CreateObject("WScript.Network")

			source.value=objNetwork.ComputerName

		Else

			source.Value=ReadMRU("COMPUTER")

		End If

		CheckLocal()

		sMsg="<Font family=Tahoma size=2 color=blue>Enter a computer name. " &_

		"If the alternate credentials section is grayed out, it will be " &_

		"enabled when you click on it. You cannot use alternate credentials for the local system."

	Case "TEXT"

		If ReadMRU("TEXT")="" then

			source.value="servers.txt"

		Else

			source.Value=ReadMRU("text")

		End If

		sMsg="<Font family=Tahoma size=2 color=blue>Enter filename of your server list.  If not in the same directory as this HTA, Then you must enter the full path."

	Case "GROUP"

		If ReadMRU("GROUP")="" Then

			source.value="DOMAIN CONTROLLERS"

		Else

			source.value=ReadMRU("group")

		End If

		sMsg="<Font family=Tahoma size=2 color=blue>Enter the name of a domain based group that contains computer names.  It can be either a security or distribution group."

	Case "OU"

		If ReadMRU("OU")="" Then

			Dim RootDSE,mydomain

			set RootDSE=GetObject("LDAP://RootDSE")

			set mydomain=GetObject("LDAP://"&RootDSE.Get("DefaultNamingContext"))

			'display message if computer is not a domain member

			If Err.number<>0 Then

				sMsg="<Font family=Tahoma size=2 color=red>You must belong to a domain in order to query an OU. ( Error#" & Err.number & " " & Err.description & ")"

				report.InnerHtml=sMsg & "</font>"

				DisableButtons True

				'change focus to Check Server button

				checklist.focus

				Err.clear

				Exit Sub

			End If

			myDomainPath=MID(mydomain.ADSPath,8)	'DC=MyDomain,DC=local

			source.value="OU=Domain Controllers," & myDomainPath

		Else

			source.value=ReadMRU("OU")

		End If

		sMsg="<Font family=Tahoma size=2 color=blue>Enter in the LDAP path of the OU that contains the computer accounts you want to monitor."

	Case Else

		sMsg="<Font family=Tahoma size=2 color=red>There was an unexpected error.</font>"

End Select
 

report.InnerHtml=sMsg &"</font>"

'change focus to Check Server button

checklist.focus

End Sub
 

'**********************************

'*  Check for localhost		      *

'**********************************

Sub CheckLocal()

'if source.value is localhost Then

'disable alternate credentials

Dim objNetwork

Set objNetwork=CreateObject("WScript.Network")
 

'clear alternate credentials if set since they can't be used anyway

username.value=""

password.value=""
 

If UCase(objNetwork.ComputerName)=UCase(source.value) Then

	alternate_credentials.disabled=True

Else

	alternate_credentials.disabled=False

End If
 

End sub
 

'**********************************

'*  Validate Refresh Interval     *

'**********************************

Sub ValidateRefresh()

On Error Resume Next

'refresh interval must be greater than 1

If refresh.value<1 Then

strHTML="<Font Face=Tahoma Size=2 Color=Red>You must enter a refresh value greater than 1</font>"

report.innerHTML=strHTML

refresh.value=60

refresh.focus

End If
 

End Sub
 

'**********************************

'*  Update Registry with last     *

'*   used settings for text file  *

'*   domain group or OU           *

'**********************************

Sub SetMRU(sType,sMRU)

'sType is either text,group, or OU

'sMRU is value for either text, group or OU
 

On Error Resume Next

Dim objShell

Set objShell=CreateObject("WScript.Shell")
 

strRegPath="HKCU\Software\SAPIEN Technologies\DiskReporter\"& sType

objShell.RegWrite strRegPath,sMRU,"REG_SZ"
 

End Sub
 

'**********************************

'*  Read Registry for last        *

'*   used settings for text file  *

'*   domain group or OU           *

'**********************************

Function ReadMRU(sType)

'sType is either computer,text,group, or OU

On Error Resume Next

Dim objShell

Set objShell=CreateObject("WScript.Shell")
 

strRegPath="HKCU\Software\JDHITSolutions\DiskReporter\"& sType

ReadMRU=objShell.RegRead(strRegPath)

Err.clear

End Function
 

'**********************************

'*  Export results to CSV         *

'**********************************

Sub ExportToCSV()

Dim objFSO,objFile,objNewFile,oShell,oEnv
 

Set oShell=CreateObject("wscript.shell")

Set oEnv=oShell.Environment("System")

strTemp=oShell.ExpandEnvironmentStrings("%TEMP%")

strTempFile=strTemp & "\~$dr.txt"
 

strFile=SaveAs("logical_drive_report.csv")

If strFile="" Then Exit Sub
 

Set objFSO=CreateObject("Scripting.FileSystemObject")

Set objFile=objFSO.OpenTextFile(strTempFile,1)

Set objNewFile=objFSO.CreateTextFile(strFile,True)

Do While objFile.AtEndOfStream<>True

	strData=objFile.ReadLine

	strData=Replace(strData,"~",",")

	objNewFile.WriteLine strData

Loop

objNewFile.WriteLine footer.innertext
 

objNewFile.Close

objFile.Close
 

MsgBox "Finished exporting to " & strFile,vbOKOnly+vbInformation,"Export"
 

End Sub
 

'**********************************

'*  Export results to HTML        *

'**********************************

Sub ExportToHTML()

Dim objFSO,objFile
 

strFile=SaveAs("logical_drive_report.html")

If strFile="" Then Exit Sub
 

Set objFSO=CreateObject("Scripting.FileSystemObject")

Set objFile=objFSO.CreateTextFile(strFile,True)

objFile.WriteLine "<html><title>Logical Disk Report</title><body>"

tmpArray=Split(report.innerhtml,VbCrLf)

'objFile.WriteLine report.InnerHTML

For z=0 To UBound(tmpArray)

	objFile.Writeline tmpArray(z)

next

objFile.WriteLine "<br><font size=1 face=Tahoma color=blue><I>report run " & Now & "</I><br>"

objFile.WriteLine "links are invalid on exported reports<br>"

objFile.WriteLine "<a href=http://www.jdhitsolutions.com target=_blank>http://www.jdhitsolutions.com</a>"

objFile.WriteLine "</body></html>"

objFile.Close

MsgBox "Finished exporting To " & strFile,vbOKOnly+vbInformation,"Export"
 

End Sub
 

'**********************************

'*  Export results to TXT         *

'**********************************

Sub ExportToText()

Dim objFSO,objFile,objNewFile,oShell,oEnv
 

Set oShell=CreateObject("wscript.shell")

Set oEnv=oShell.Environment("System")

strTemp=oShell.ExpandEnvironmentStrings("%TEMP%")

strTempFile=strTemp & "\~$jdhdr.txt"
 

strFile=SaveAs("logical_drive_report.txt")

If strFile="" Then Exit Sub
 

Set objFSO=CreateObject("Scripting.FileSystemObject")

Set objFile=objFSO.OpenTextFile(strTempFile,1)

Set objNewFile=objFSO.CreateTextFile(strFile,True)
 

objNewFile.WriteLine vbTab & vbTab & "Logical Drive Utilization"

Do While objFile.AtEndOfStream<>True

	r=objFile.ReadLine

	r=Replace(r,Chr(34),"")

	tmpArray=Split(r,"~")

	strData=""

	For z=0 To UBound(tmpArray)

		strData=strData & tmpArray(z) & vbtab

	Next

	objNewFile.WriteLine strData

Loop

objNewFile.WriteLine footer.innertext

objNewFile.WriteLine "http://www.jdhitsolutions.com"

objNewFile.Close

objFile.Close
 

MsgBox "Finished exporting To " & strFile,vbOKOnly+vbInformation,"Export"
 

End Sub
 

'**********************************

'*  Export results to MS WORD     *

'**********************************

Sub ExportToWord()

On Error Resume Next

Dim objFSO, objFile, objWord

Dim oShell,oEnv
 

Const wdAlignParagraphLeft=0

Const wdAlignParagraphCenter=1

Const wdWord9TableBehavior=1

Const wdAutoFitFixed=0

Const wdAutoFitContent=1

Const wdExtend=1
 

'wdUnits

Const wdCell=12

Const wdCharacter=1

Const wdLine=5
 

'wdColor

Const wdColorRed=255

Const wdColorGreen=32768

Const wdColorGold=52479

Const wdColorBlack=0

Const wdColorAutomatic=-16777216
 

Set objWord=CreateObject("Word.Application")

If Err.Number<>0 Then

	MsgBox "You must have Microsoft Word installed in order to export to this format.",vbOKOnly+vbCritical,"Export"

	Exit Sub

End If
 

Set oShell=CreateObject("wscript.shell")

Set oEnv=oShell.Environment("System")

strTemp=oShell.ExpandEnvironmentStrings("%TEMP%")

strSource=strTemp & "\~$jdhdr.txt"
 

strFile=SaveAs("logical_drive_report.doc")

If strFile="" Then Exit Sub
 

Set objFSO=CreateObject("Scripting.FileSystemObject")

Set objFile=objFSO.OpenTextFile(strSource)
 

arrData=Split(objFile.ReadAll,VbCrLf)

iRows= UBound(arrData)
 

objFile.Close
 

objWord.Documents.Add

objWord.Visible=False

objWord.Selection.Font.Name="TAHOMA"

objWord.Selection.Font.Bold=True

objWord.Selection.Font.SmallCaps=True

objWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

objWord.Selection.TypeText "Logical Drive Utilization"

objWord.Selection.Font.SmallCaps=False

objWord.Selection.Font.Bold=False

objWord.Selection.Font.Size=10

objWord.Selection.TypeParagraph

objWord.Selection.TypeParagraph

objWord.Selection.ParagraphFormat.Alignment=wsAlignParagraphLeft

objWord.Selection.Tables.Add objWord.Selection.Range,iRows,4,wdWord9TableBehavior,wdAutoFitContent

objWord.ActiveDocument.Tables.Item(1).ApplyStyleHeadingRows=True
 

'set header

strData=arrData(0)

tmpArray=Split(strData,"~")

For z=0 To UBound(tmpArray)

		objWord.Selection.Font.bold=True

		objWord.Selection.ParagraphFormat.Alignment=wdAlignParagraphCenter

		objWord.Selection.TypeText tmpArray(z)

		objWord.Selection.MoveRight wdCharacter

Next
 

For x=1 To UBound(arrData)
 

	strData=arrData(x)

	strData=Replace(strData,Chr(34),"")

	tmpArray=Split(strData,"~")

	

		For z=0 To UBound(tmpArray)	

		

			If InStr(tmpArray(z),"connect") Then	

				objWord.Selection.SelectCell

				objWord.Selection.MoveRight wdCharacter,2,wdExtend

				objWord.Selection.Cells.Merge

				objWord.Selection.Font.Color=wdColorRed

				objWord.Selection.ParagraphFormat.Alignment=wdAlignParagraphLeft

				objWord.Selection.TypeText tmpArray(z)

				objWord.Selection.moveRight wdCharacter

				Exit For

			Else		

				objWord.Selection.Font.Color=wdColorBlack

				objWord.Selection.ParagraphFormat.Alignment=wdAlignParagraphLeft

				If InStr(tmpArray(z),"|") Then 

				' WScript.Echo Len(tmpArray(z))*5

				'set color coding for bar graph

					L=Len(tmpArray(z))*5

					If L >80 Then

						objWord.Selection.Font.Color=wdColorRed

					Elseif L<50 Then

						objWord.Selection.Font.Color=wdColorGreen

					Else

						objWord.Selection.Font.color=wdColorGold

					End If

					'bold graph

					objWord.Selection.Font.Bold=True

				 End If

				objWord.Selection.TypeText tmpArray(z)

				objWord.Selection.moveRight wdCharacter

			End If

		Next

Next
 

objWord.Selection.MoveDown wdLine

objWord.Selection.Font.Size=8

objWord.Selection.Font.Color=wdColorRed

objWord.Selection.TypeText ">80% utilization"

objWord.Selection.Font.color=wdColorGold

objWord.Selection.TypeText " <80% utilization"

objWord.Selection.Font.Color=wdColorGreen

objWord.Selection.TypeText " <50% utilization"

objWord.Selection.TypeParagraph

objWord.Selection.TypeParagraph

objWord.Selection.Font.Italic=True

objWord.Selection.Font.Color=wdColorBlack

objWord.Selection.TypeText footer.innertext

objWord.Selection.TypeParagraph
 

objWord.Selection.TypeText "http://www.jdhitsolutions.com"
 

objWord.ActiveDocument.SaveAs strFile

MsgBox "Finished exporting To " & strFile,vbOKOnly+vbInformation,"Export"
 

objWord.Quit
 
 

End Sub

'**********************************

'*  Export results to XLS         *

'**********************************

Sub ExportToExcel()
 

Dim objFSO,objFile,objNewFile,oShell,oEnv

Dim objXL
 

On Error Resume Next

Err.Clear

Set objXL=CreateObject("Excel.Application")

If Err.Number<>0 Then

	MsgBox "You must have Microsoft Excel installed in order to export to this format.",vbOKOnly+vbCritical,"Export"

	Exit Sub

End If

objXL.Visible=False

objXL.Workbooks.Add

objXL.Cells(1,3)="Logical Drive Utilization"

objXL.Range("C1").Select

objXL.Selection.font.bold=True

objXL.Selection.font.size=14

Set oShell=CreateObject("wscript.shell")

Set oEnv=oShell.Environment("System")

strTemp=oShell.ExpandEnvironmentStrings("%TEMP%")

strTempFile=strTemp & "\~$jdhdr.txt"
 
 

strFile=SaveAs("logical_drive_report.xls")

If strFile="" Then Exit Sub
 

Set objFSO=CreateObject("Scripting.FileSystemObject")

Set objFile=objFSO.OpenTextFile(strTempFile,1)
 

Row=3

Col=1

Do While objFile.AtEndOfStream<>True

	r=objFile.ReadLine

	r=Replace(r,Chr(34),"")

	tmpArray=Split(r,"~")

	For z=0 To UBound(tmpArray)

		'set font color to red if can't connect error message is detected

		If InStr(tmpArray(z),"connect") Then objXL.Cells(Row,Col+z).Font.Color=vbRed

		objXL.Cells(Row,Col+z).Value=tmpArray(z)

	Next

Row=Row+1

Loop
 

LastRow=Row-1
 

objXL.Range("A3:D3").Select

objXL.Selection.font.bold=True
 

objXL.Cells(Row+1,Col).Value=footer.innertext

objXL.Cells(Row+1,Col).Font.Italic=True

objXL.Cells(Row+2,Col).Value="http://www.jdhitsolutions.com"

objXL.Cells(Row+2,Col).Font.Italic=True
 

'get graph length and adjust color accordingly

Row=4

Col=3
 

For t=4 To LastRow

	l=(Len(objXL.Cells(row,Col))*5)

	

	If l > 80 Then

	 objXL.Cells(Row,Col).Font.ColorIndex=3

	Elseif l < 50 Then

	 objXL.Cells(Row,Col).Font.ColorIndex=50

	Else

	 objXL.Cells(Row,Col).Font.ColorIndex=45

	End If	

	Row=Row+1

next
 

objXL.Cells.Select

objXL.Cells.EntireColumn.AutoFit

objXL.Cells(1,1).Select

objXL.application.DisplayAlerts="False"

objXL.ActiveWorkbook.SaveAs strFile

objXL.Quit
 

MsgBox "Finished exporting To " & strFile,vbOKOnly+vbInformation,"Export"
 

End Sub
 
 

'**********************************

'*  Get Export Type				  *

'**********************************
 

Sub GetExportType

On Error Resume Next

strMenu="You can export to:" & VbCrLf &_

"HTML" & VbCrLf &_

"TEXT" & VbCrLf &_

"CSV" & VbCrLf &_

"WORD" & VbCrLf &_

"EXCEL" & VbCrLf & VbCrLf &_

"Please type in one of these choices."

rc=InputBox(strMenu,"Export","HTML")

If rc="" Then Exit Sub
 

Select Case UCase(rc)

	Case "HTML"

		ExportToHTML

	Case "TEXT"

		ExportToText

	Case "CSV"

		ExportToCSV

	Case "WORD"

		ExportToWord

	Case "EXCEL"

		ExportToExcel

	Case Else

		MsgBox "Valid choices are HTML, TEXT, WORD, EXCEL or CSV.  Please try again.",vbOKOnly+vbInformation,"Export"

		GetExportType

End Select
 
 

End Sub
 

'**********************************

'*  SaveAS Function				  *

'**********************************
 

Function SaveAs(strFile)

Dim objDialog
 

If InStr(GetOS,"2000") Then

	SaveAs=InputBox("Enter the filename and path.","Export",strFile)

else
 

'This requires Windows XP/2003

	Set objDialog=CreateObject("SAFRCFileDlg.FileSave")

	

	objDialog.filename=strFile

	objDialog.OpenFileSaveDlg

	SaveAs=objDialog.FileName

End If
 

End Function
 

'**********************************

'*  Get OS Caption via WMI		  *

'**********************************

Function GetOS()

'returns values like:

'Microsoft Windows XP Professional
 

On Error Resume Next

Dim objWMI
 

Set objWMI=GetObject("winmgmts://.\root\cimv2").InstancesOf("win32_operatingsystem")
 

For Each OS In objWMI

  GetOS=OS.Caption

Next
 

End Function
 

'**********************************

'*  Quit						  *

'**********************************

Sub QuitHTA()

ClearTemp

self.close
 

End sub
 
 

</Script>

</head>
 

<TITLE>Disk Reporter</TITLE>

    <HTA:APPLICATION ID="DiskReporter"

     APPLICATIONNAME="DiskReporter"

     BORDER="thick"

     BORDERSTYLE="normal"

     CAPTION="yes"

     ICON="myicon.ico"

     MAXIMIZEBUTTON="yes"

     MINIMIZEBUTTON="yes"

     SHOWINTASKBAR="yes"

     SINGLEINSTANCE="no"

     SYSMENU="yes"

     VERSION="2.0"

     WINDOWSTATE="normal">
 

<body>

<Font size="3" face="Tahoma">Disk Reporter</Font><hr>

<select name="serverlist" class="Hide" onchange="SourcePrompt">

<option value="SELECT">Select a source</option>

<option value="COMPUTER">single computer</option>

<option value="TEXT">text file</option>

<option value="GROUP">domain group</option>

<option value="OU">organizational unit</option>

</select>

<input type="text" name="source" size="30" class="Hide" onChange="CheckLocal()">  <input type="button" name="checklist" value="Report" class="Hide" onclick="ProcessList()">

<input id="print_button" type="button" value="Print" name="Print_button" class="Hide" onClick="Window.print()">

<input id="export_button" type="button" value="Export" name="Export_button" class="Hide" onclick="GetExportType()">

<input id="quit_button" type="button" value="Quit" name="quit_button" class="Hide" onClick="QuitHTA()" >
 

<fieldset class="Hide" id="alternate_credentials"><legend><Font face="Tahoma" size="2" color="Blue">Alternate Domain Credentials <i>(optional)</i></Font></legend>

<Font face="Tahoma" size="2" color="Blue">Username <input id="username" type="text" size="20" name="username"> <i>it is recommended you use domain</i>\<i>username format.</i><br>

<Font face="Tahoma" size="2" color="Blue">Password <input id="password" type="password" size="20"> <i>alternate credentials won't work for the local computer.</Font></i>

</fieldset>

<br><div id="report">&nbsp</div>

<table width="100%">

	<TD colspan="2">

	<span id="footer">&nbsp;</span>

	</td>

	<TD class="Hide" colspan="2" align="Right">

	<font size=2" face="Tahoma">Next update in <input type="text" name="refresh" size="2" value="60" onChange="ValidateRefresh">minutes

	</font>

	</TD>

</table>
 

<table border="0" cellspacing="1" width="100%" class="hide">

    <tr>

    <td valign="top" align="Center"><font face="Verdana" color="#339999" size="1">

    <a href="http://www.primalscript.com">Provided by SAPIEN Technologies</a></p>

    <a href="#web" onclick="About()">About</a>

    </td>

    </tr>

</table>  

</body>

</html>

Open in new window

0
 
LVL 1

Author Comment

by:Simon336697
ID: 24134999
Hi yehudaha,

This is brilliant mate.

Ill try and really understand this script. Hopefully I will be able to get some good use out of it mate.
Thank you so much.
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Welcome to part one of a multi-part tutorial series, VBScript for Windows System Administrators.  The goal of this series is to teach non-programmers how to write useful VBS code to automate their environment, and perform tasks faster, and in a more…
Script to copy or move mouse-selected collection of files plus targets referenced by shortcuts (.lnk) The purpose of this article is to help illuminate the real challenges and options available (where they may exist) for utilizing simple scriptin…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
Get a first impression of how PRTG looks and learn how it works.   This video is a short introduction to PRTG, as an initial overview or as a quick start for new PRTG users.

759 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now