Software Profile Generator

Forums

My Profile

Inbox

Address Book

My Subscription

My Forums

Software Profile Generator

Logged in as: Guest

arrSession:exec spGetSession 2,16,53955

	Active Users: There are 0 members and 0 guests.
	Users viewing this topic: none

Printable Version

All Forums >> [Scripting] >> Post a VBScript >> Software Profile Generator
Do you like VisualBasicScript.com? Link to us and help spread the word about our forum. Thanks!

Page: [1]

Message

<< Older Topic Newer Topic >>

Software Profile Generator - 12/1/2007 9:42:31 PM

Meg

Posts: 123
Score: 2
Joined: 7/13/2006
From: Australia
Status: offline

This is a �Software Profile Generator. It uses a database as a filter which stores a list of the apps you don't want to appear on the software profile report.

It lists all items in the specified computer's �Add Remove Programs�, sorted, filtered, duplicates removed and displays a print button for your convenience.

There is a check box next to each item which you can click to add that item to the database. The page refreshes and displays the same list minus that item. Go through and remove all items which are security updates, drivers and SOE components and then go ahead and run it on as many machines you like.

I have only just written and tested this script at home this weekend, but it is designed for my corporate environment of XP machines. I have incorporated a feature where you can launch the HTA with a command line argument but that is not working yet because of security restrictions relating to HTAs, domains and databases. PITA

Place the script on a network share to run and other users will share the same filter database.

Copy the below code and past into a file with a .HTA extention, enjoy and give me feedback so I can improve it. Any updates will be to the this post.

<html> 
<head> 
<title>Programs List</title> 
<HTA:APPLICATION 
    ID="ObjProgramsList" 
    APPLICATIONNAME="ProgramsList" 
    SCROLL="yes" 
    SINGLEINSTANCE="no" 
>

'---------------------------------------------------------
'------------Script By MJP 2007----------------------
'---------------------------------------------------------

'Some variables we need to share between the functions/subs. 
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adUseClient = 3
Set objConnectionx = CreateObject("ADODB.Connection")
Set objRecordSetx = CreateObject("ADODB.Recordset")
Dim sTitle
Dim APResult
Dim strDB
Dim AddRemoveName, AltName, Hide, Notes, Spare
Dim strComputer
Dim Display

'---------------------------------------------------------

Sub Window_Onload 
'This sub is autorun when the script is run
sTitle = "ProgramsList by MJP"
'Set initial page dimentions
window.resizeto 860,508 
'Check for a single command line variable passed to HTA, Consists of single computer name which is to be queried, assumed the computer is on and accessible. 
CMDLine=ObjProgramsList.commandLine
CMDLen=len(CMDLine)
CMDLine=right(CMDLine, CMDLen-1)
pos=InStr(CMDLine, chr(34))
CMDArg=right(CMDLine, CMDLen-pos-1)
CMDArg=trim(CMDArg)
if CMDArg<>"" then
 strComputer = CMDArg
 'Generate file containg current contents of strComputer's Add Remove Programs List.  
 APResult = GetAddRemove(strComputer)
 'Display the page
 ComputerHTML.innerHTML=strComputer
 Displaypage 
 
else
 'Prompt for a computer for reading it's Add Removed Programs List. 
 RequestInput 
end if
'Create a new database when run for first time or if database is deleted.
pos=instrRev(CMDLine, "\")
strDB = left(CMDLine, pos)&"ProgramFilter.mdb" 
DBCreate

End Sub

'---------------------------------------------------------

sub displayPage
'Display filtered list of all programs on computer. Each item is compared to the filter database and skipped if marked as hide. 
window.resizeto 860,768 
DisplayHTML.innerhtml=""
display=""
MyArray = Split(APResult, vbcrlf, -1, 1)
c=-1
objConnectionx.Open _
   "Provider = Microsoft.Jet.OLEDB.4.0; " & _
       "Data Source = "&strDB 
objRecordSetx.Open "SELECT * FROM PFTable", objConnectionx, adOpenStatic, adLockOptimistic

next
DisplayHTML.innerhtml="<input id=runbutton1000  class=button type=button value='Full List' name=run_button1000  onClick=DisplayPageFull> <input id=runbutton1002  class=button type=button value='Print' name=run_button1002  onClick=PrintMe> <br><br><table><tr><td bgcolor=c0c0c0><font size=3>FLICK</font></td><td bgcolor=c0c0c0><font size=3>PROGRAM NAME</font></td></tr>"&display&"</table>"
objRecordSetx.Close
objConnectionx.Close
end sub

'---------------------------------------------------------

Sub displayPageFull
' Display full list of programs installed on computer. Filtered items have an add button next to them so you can show on filtered list again
window.resizeto 860,768 
DisplayHTML.innerhtml=""
display=""
MyArray = Split(APResult, vbcrlf, -1, 1)
c=-1
objConnectionx.Open _
   "Provider = Microsoft.Jet.OLEDB.4.0; " & _
       "Data Source = "&strDB 
objRecordSetx.Open "SELECT * FROM PFTable", objConnectionx, adOpenStatic, adLockOptimistic

For Each x in MyArray 
c=c+1 
objRecordSetx.MoveFirst
HideRecord="N"
Do Until objRecordSetx.EOF or HideRecord="Y"
AddRemoveNameTest= objRecordsetx.Fields.Item("AddRemoveName")
if AddRemoveNameTest = x then
 HideRecord = "" 
 HideRecord = objRecordsetx.Fields.Item("Hide")
end if
objRecordSetx.MoveNext
loop
if x="" then
 display=display
Else
 if HideRecord<>"Y" then
  display=display&"<tr><td>"&"</td><td>"&x&"</td></tr>"   
 else
  display=display&"<tr><td bgcolor=f6f6f6>"&"<input id=runbutton"&c&"  class=button type=button value=Add name=run_button"&c&"  onClick=AddMe("&c&")></td><td bgcolor=f6f6f6>"&x&"</td></tr>"   
 end if
end if
next
DisplayHTML.innerhtml="<input id=runbutton1001  class=button type=button value=Filtered name=run_button1001  onClick=DisplayPage><br><br><table>"&display&"</table>"
objRecordSetx.Close
objConnectionx.Close
end sub

'---------------------------------------------------------

Function GetAddRemove(sComp)
 'Function credit to Torgeir Bakken, a simple read from registry. 
 Dim count, oReg, sBaseKey, iRC, aSubKeys
 Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
on error resume next
 Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
             sComp & "/root/default:StdRegProv")
 sBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
 iRC = oReg.EnumKey(HKLM, sBaseKey, aSubKeys)

if err.number <> 0 then
msgbox "Error accessing "&sComp
Location.Reload(True)
end if
on error goto 0

For Each sKey In aSubKeys
   iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, "DisplayName", sValue)
   If iRC <> 0 Then
     oReg.GetStringValue HKLM, sBaseKey & sKey, "QuietDisplayName", sValue
   End If
   If sValue <> "" Then
     iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
                               "DisplayVersion", sVersion)
     If sVersion <> "" Then
       sValue = sValue & vbTab & "Ver: " & sVersion
     Else
       sValue = sValue & vbTab 
     End If
     
     sTmp = sTmp & sValue & vbcrlf
   count = count + 1
   End If
 Next
 sTmp = BubbleSort(sTmp)
 GetAddRemove = sTmp

End Function

'---------------------------------------------------------

sub FlickMe(x)
' Flick button clicked, that program name will no longer show on filtered list. 
MyArray2 = Split(APResult, vbcrlf, -1, 1)
FieldA = MyArray2(x) 'AddRemoveName
ReadDatabase FieldA
FieldB = ALTName
FieldC = "Y" 'Hide
FieldD = Notes
FieldE = Spare
DBUpdate FieldA, FieldB, FieldC, FieldD, FieldE
Displaypage 
End Sub

'---------------------------------------------------------

sub AddMe(x)
'Add button was pressed, filtered name is no longer filtered, Magic. 
MyArray2 = Split(APResult, vbcrlf, -1, 1)
FieldA = MyArray2(x) 'AddRemoveName
ReadDatabase FieldA
FieldB = ALTName
FieldC = "N" 'Show
FieldD = Notes
FieldE = Spare
DBUpdate FieldA, FieldB, FieldC, FieldD, FieldE
DisplaypageFull 
End Sub'

'---------------------------------------------------------

'Create Database Function
Function DBCreate
'Check if database exists
Set objFSOA = CreateObject("Scripting.FileSystemObject")
If objFSOA.FileExists(strDB) Then
' Skip, the database has already been created (use the database just found)
Else
'Create Database
Set objConnectionA = CreateObject("ADOX.Catalog")
objConnectionA.Create _
   "Provider = Microsoft.Jet.OLEDB.4.0; " & _
       "Data Source = "&strDB
       
'Create table 
Set objConnectionA = CreateObject("ADODB.Connection")
objConnectionA.Open _
   "Provider= Microsoft.Jet.OLEDB.4.0; " & _
       "Data Source= "&strDB 
objConnectionA.Execute "CREATE TABLE PFTable(" & _
   "AddRemoveName TEXT(100) ," & _
   "AltName TEXT(100) ," & _
   "Hide TEXT(100) ," & _
   "Notes TEXT(100) ," & _
   "Spare TEXT(100))"
objConnectionA.Close  
'Write a blank line to NEW database with creation timestamp
FieldA = ""
FieldB = ""
FieldC = "Y"
FieldD = ""
FieldE = now()
DBUpdate FieldA, FieldB, FieldC, FieldD, FieldE
End if
End Function   
    
'---------------------------------------------------------

Function DBUpdate(FieldA, FieldB, FieldC, FieldD, FieldE)
'Write to database function

'Check if Record has been added to database already
objConnectionx.Open _
   "Provider = Microsoft.Jet.OLEDB.4.0; " & _
       "Data Source = "&strDB 
objRecordSetx.Open "SELECT PFTable.AddRemoveName FROM PFTable WHERE (((PFTable.AddRemoveName)="&Chr(34)&FieldA&Chr(34)&"))", _
       objConnectionx, adOpenStatic, adLockOptimistic
On Error Resume NEXT
objRecordSetx.MoveFirst
If objRecordsetx.Fields.Item("AddRemoveName")="" Then
On Error Goto 0
objRecordSetx.Close
on error resume next
'Add to database
objRecordSetx.Open "SELECT * FROM PFTable" , _
   objConnectionx, adOpenStatic, adLockOptimistic
objRecordSetx.AddNew
objRecordSetx("AddRemoveName") = FieldA
objRecordSetx("AltName") = FieldB
objRecordSetx("Hide") = FieldC
objRecordSetx("Notes") = FieldD
objRecordSetx("Spare") = FieldE
objRecordSetx.Update
if err.number<>0 then 
msgbox "Permission Denied Updating the Database"&vbcrlf&"Please Request TS Remove This Item From List. "
end if
on error goto 0
Else
'Record is already in the database delete and re-add entry to avoid duplicates
On Error Goto 0
objRecordSetx.Close
on error resume next
'Delete database record
objRecordsetx.CursorLocation = adUseClient
objRecordSetx.Open "SELECT PFTable.AddRemoveName FROM PFTable WHERE (((PFTable.AddRemoveName)="&Chr(34)&FieldA&Chr(34)&"))", _
       objConnectionx, adOpenStatic, adLockOptimistic
objRecordsetx.Delete
objRecordSetx.Close
if err.number<>0 then 
msgbox "Permission Denied Updating the Database"&vbcrlf&"Please Request TS Remove This Item From List. "
end if
on error goto 0
'Add to database
objRecordSetx.Open "SELECT * FROM PFTable" , _
   objConnectionx, adOpenStatic, adLockOptimistic
objRecordSetx.AddNew
objRecordSetx("AddRemoveName") = FieldA
objRecordSetx("AltName") = FieldB
objRecordSetx("Hide") = FieldC
objRecordSetx("Notes") = FieldD
objRecordSetx("Spare") = FieldE
objRecordSetx.Update
End IF
objRecordSetx.Close
objConnectionx.Close
End Function

'---------------------------------------------------------

sub ReadDataBase(x)
'Read record from DB

objConnectionx.Open _
   "Provider = Microsoft.Jet.OLEDB.4.0; " & _
       "Data Source = "&strDB 
objRecordSetx.Open "SELECT * FROM PFTable", objConnectionx, adOpenStatic, adLockOptimistic
objRecordSetx.MoveFirst
Do Until objRecordSetx.EOF
AddRemoveNameTest= objRecordsetx.Fields.Item("AddRemoveName")

if AddRemoveNameTest = x then
AltName = objRecordsetx.Fields.Item("AltName")
Hide = objRecordsetx.Fields.Item("Hide")
Notes = objRecordsetx.Fields.Item("Notes")
Spare = objRecordsetx.Fields.Item("Spare")
objRecordSetx.Close
objConnectionx.Close
exit sub
  end if
objRecordSetx.MoveNext
loop
objRecordSetx.Close
objConnectionx.Close
end sub

'---------------------------------------------------------

Function BubbleSort(sTmp)
'Turn string into an array, sort it, remove duplicates and turn it back into a string.
 Dim aTmp, i, j, temp
 aTmp = Split(sTmp, vbcrlf)  
 For i = UBound(aTmp) - 1 To 0 Step -1
   For j = 0 to i - 1
     'Remove Duplicates
     If LCase(aTmp(j)) = LCase(aTmp(j+1)) Then
       aTmp(j)=""
     end if
     'Sort Items
     If LCase(aTmp(j)) > LCase(aTmp(j+1)) Then
       temp = aTmp(j + 1)
       aTmp(j + 1) = aTmp(j)
       aTmp(j) = temp
     End if
   Next
 Next
 BubbleSort = Join(aTmp, vbcrlf)
End Function

'---------------------------------------------------------

sub printme
' print the current page
DisplayHTML.innerhtml="<table>"&display&"</table><br>Printed "&Now()   
  Window.Print()
DisplayHTML.innerhtml="<input id=runbutton1000  class=button type=button value='Full List' name=run_button1000  onClick=DisplayPageFull> <input id=runbutton1002  class=button type=button value='Print' name=run_button1002  onClick=PrintMe> <br><br><table><tr><td bgcolor=c0c0c0>FLICK</td><td bgcolor=c0c0c0>PROGRAM NAME</td></tr>"&display&"</table>"
  
end sub

'---------------------------------------------------------

sub EnterName
'Read inputed value
strComputer = trim(NetbiosName.value)
'Display main screen
Main.Style.Display = "inline" 
Splash.Style.Display = "none" 
'Close HTA if input cancelled or use this computer "." if nothing entered. 
If IsEmpty(strComputer) Then self.close
If strComputer = "" Then strComputer = "."
'Generate file containg current contents of strComputer's Add Remove Programs List. 
APResult = GetAddRemove(strComputer)
'Display the page
ComputerHTML.innerHTML=strComputer
Displaypage

End Sub

'--------------------------------------------------------- 
Sub RequestInput 
' Show the RequestInput Screen 
Main.Style.Display = "none" 
Splash.Style.Display = "inline" 
End Sub

'---------------------------------------------------------

</script> 
</head>

<body>

<DIV id="Splash" STYLE="Background-color:ffffff;);Height:200;Width:400;Border:0.2mm solid black;position:relative;top:90;left:200;"> 
<br><br> 
<center> 
<font face="arial" color=Navy size=5><b><i> Technical Services Profile Generator </i></b></font> 
<br> 
<a href="http://www.painterinfo.com/php2bb/viewforum.php?f=17">By MJP 2007</a><br><br> 
<b>Computer Name </b><input type="text" name="NetbiosName" size="20"><input id=runbutton  class="button" type="button" value="Enter" name="run_button"  onClick="EnterName">

</center> 
</DIV>

<DIV id="Main" STYLE="display:none;position:absolute">
<center>   <font face="Tahoma" color=Blue size=4><b> Software Profile <span id=ComputerHTML></span> </b></font></center>
<span id=DisplayHTML></span>
</Div>
</body> 
</html>

Post #: 1

RE: Software Profile Generator - 12/5/2007 12:07:58 AM

Meg

Posts: 123
Score: 2
Joined: 7/13/2006
From: Australia
Status: offline

The script in the previous post is great, but as it is a HTA which uses a database, it as security restrictions applied to it, i.e. it only works if you directly click on it, you can not pass any variables to it from another script or from the command line.

That does not matter because now I have written a VBS version that does allow you to do that. I have dumbed down the features so this script is the read only viewer you distribute a shortcut to. The HTA version is the full blown viewer that allows you to create the baseline of what programs to exclude from the software profile.

The VBS, HTA and database must be in the same folder, preferably a network share.
Run the HTA first, this creates the backend database.
Then run this VBS to view the profiles.
Press CTL + P to print the VBS, right click to save.
To add additional applications to the baseline filter, run the HTA again.

'Script By MJP 2007

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adUseClient = 3
Set objConnectionx = CreateObject("ADODB.Connection")
Set objRecordSetx = CreateObject("ADODB.Recordset")
Dim APResult
Dim AddRemoveName, Hide, Notes, Spare
Dim strComputer
Dim Display
strDB = ScriptPath&"ProgramFilter.mdb"

'Check for a single command line variable passed to script, Consists of single computer name which is to be queried, assumed the computer is on and accessible. 
If Wscript.Arguments.Count = 1 Then
   CMDArg = Wscript.Arguments(0)
End If

if CMDArg<>"" then
 strComputer = CMDArg
 'Generate file containg current contents of strComputer's Add Remove Programs List.  
 APResult = GetAddRemove(strComputer)
 'Display the page
 Displaypage 
 
else
 'Prompt for a computer for reading it's Add Removed Programs List. 
 strComputer = inputbox("Enter Machine Name")

'Generate file containg current contents of strComputer's Add Remove Programs List. 
 APResult = GetAddRemove(strComputer)
 'Display the page
 Displaypage 
end if

'---------------------------------------------------------

sub displayPage
'Display filtered list of all programs on computer. Each item is compared to the filter database and skipped if marked as hide. 
MyArray = Split(APResult, vbcrlf, -1, 1)
c=-1
objConnectionx.Open _
   "Provider = Microsoft.Jet.OLEDB.4.0; " & _
       "Data Source = "&strDB 
objRecordSetx.Open "SELECT * FROM PFTable", objConnectionx, adOpenStatic, adLockOptimistic

'Create an IE window to display the string.
sStringToDisplay="<center><b>"&ucase(strComputer)&"</b></center><table><tr><td bgcolor=c0c0c0><font size=3>TICK</font></td><td bgcolor=c0c0c0><font size=3>PROGRAM NAME</font></td></tr>"&display&"</table><p align=right><i>Generated : "&now() 
Set oIE = CreateObject("InternetExplorer.Application")
sHTMFile = "c:\temp.htm"
Set oFSO = CreateObject("Scripting.FileSystemObject") 
oFSO.CreateTextFile sHTMFile, True
With oIE
.Navigate "file://" & Replace(sHTMFile,"\","/")
.ToolBar = 0
.StatusBar = 0
.Width = 500
.Height = 768
.Left = 0
.Top = 0
.Visible = 1
End With

oFSO.DeleteFile sHTMFile, True 
With oIE.Document
.Open
.WriteLn "<Title>Software Profile For "&strComputer&"</Title>" & Replace(sStringToDisplay,VbCrLf,"<BR>")
.Write()
.Close
End With 
CreateObject("Wscript.Shell").AppActivate "Output"

objRecordSetx.Close
objConnectionx.Close
end sub

'---------------------------------------------------------

Function GetAddRemove(sComp)
 'Function credit to Torgeir Bakken, a simple read from registry. 
 Dim count, oReg, sBaseKey, iRC, aSubKeys
 Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
 Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
             sComp & "/root/default:StdRegProv")
 sBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
 iRC = oReg.EnumKey(HKLM, sBaseKey, aSubKeys)

'---------------------------------------------------------

'Determine path script is running from
Function ScriptPath()
 ScriptPath = Left(WScript.ScriptFullName, _
   Len(WScript.ScriptFullName) - Len(WScript.ScriptName))
End Function

'---------------------------------------------------------

(in reply to Meg)