?
Solved

Turning this vbs script into a hta

Posted on 2009-04-13
2
Medium Priority
?
1,567 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
2 Comments
 
LVL 14

Accepted Solution

by:
yehudaha earned 2000 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

[Webinar] How Hackers Steal Your Credentials

Do You Know How Hackers Steal Your Credentials? Join us and Skyport Systems to learn how hackers steal your credentials and why Active Directory must be secure to stop them.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction During my participation as a VBScript contributor at Experts Exchange, one of the most common questions I come across is this: "I have a script that runs against only one computer. How can I make it run against a list of computers in …
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
In this video we outline the Physical Segments view of NetCrunch network monitor. By following this brief how-to video, you will be able to learn how NetCrunch visualizes your network, how granular is the information collected, as well as where to f…
If you’ve ever visited a web page and noticed a cool font that you really liked the look of, but couldn’t figure out which font it was so that you could use it for your own work, then this video is for you! In this Micro Tutorial, you'll learn yo…

764 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