Jump to content

Recommended Posts

Posted (edited)

The Converter did not work.........Can anyone Help??

Here is the vb script:

'----- Input target PC ----- 
strComputer = InputBox _ 
(vbLf & "Please enter Computer Name or IP Address" & vbLf & _ 
"to list installed applications","IT Support - List Apps","") 
If strComputer = "" Then 
Set objComputer = CreateObject("Shell.LocalMachine") 
strComputer = objComputer.MachineName 
strMsg = "No ComputerNamed entered, using local machine " & _ 
"(" & strComputer & ")" 

Dim x
Set x = Createobject("WSCRIPT.Network")
Dim strUsername
strUsername = x.UserName

MsgBox strMsg, 32, "IT Support - INFO" 
End If 
'--------------------------- 

'----- Call SUBs/FUNC ----- 
Set objwb = ExcelSetup 'Set objwb to FUNC 
Session objwb 'Pass FUNC values to SUB Session VARs 
'------------------------------ 

'----- Create Excel sheet with Column headers in 1st row ----- 
Function ExcelSetup 
Dim objExcel 
Dim objwb 
'----- Open Excel / Settings ----- 
Set objExcel = CreateObject("Excel.Application") 
Set objwb = objExcel.Workbooks.Add 
Set objwb = objExcel.ActiveWorkbook.Worksheets(1)
Set ExcelSetup = objwb 
 objwb.Name = "Keane - User Software List" 'Name the sheet 
 objWb.Activate 
 objExcel.Visible = True 
 objExcel.Range("A1:Z1").Select 
 objExcel.Selection.Interior.ColorIndex = 19 
 objExcel.Selection.Font.ColorIndex = 11 
 objExcel.Selection.Font.Bold = True 
 objwb.Cells(1, 1).Font.Color = RGB(255,174,0)
 
 objExcel.Range("A3:Z3").Select 
 objExcel.Selection.Font.ColorIndex = 11 
 objExcel.Selection.Font.Bold = True 
  
 '----- Excel headers ----- 
 objwb.Cells(1, 1).Value = "Created: " & Date 
 objwb.Cells(1, 2).Value = "Current Logged in User: " & strUsername
 objwb.Cells(3, 1).Value = "Computer Name"
 objwb.Cells(3, 2).Value = "Applications" 
 objwb.Cells(3, 3).Value = "Patches/Hotfixes"
 '------------------------- 
End Function 
'----------------------------------- 

'---- Sub session ----- 
Sub Session(MyWB) 
'----- Settings ----- 
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE 
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" 
strEntry1a = "DisplayName" 
strEntry1b = "QuietDisplayName" 
'-------------------- 
x = 3 'XLS row starting point 
intCount = 0 'Set to 0 
'----- Check ----- 
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
              StrComputer & "/root/default:StdRegProv")


objReg.EnumKey HKLM, strKey, arrSubkeys 
'Loop thru Uninstall folder
For Each strSubkey In arrSubkeys 
 intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, _ 
 strEntry1a, strValue1) 

If intRet1 <> 0 Then 
   objReg.GetStringValue HKLM, strKey & strSubkey, _ 
   strEntry1b, strValue1
End If 
'Check strValue1
If Not ((Instr(strValue1, "(KB")) Or (Instr(strValue1, "- KB")) Or (Instr(strValue1, "Hotfix")) Or strValue1 = "") > 0 Then 
   x = x + 1

   If InStr(strValue1, "Project") Then 
      MyWB.Cells(x, 1).Value = strComputer 
      MyWB.Cells(x, 2).Value = strValue1
      MyWB.cells(x, 2).Font.bold = True
      MyWB.cells(x, 2).Font.Color = RGB(128,210,35)   
   If InStr(strValue1, "Visio") Then 
      MyWB.Cells(x, 1).Value = strComputer 
      MyWB.Cells(x, 2).Value = strValue1
      MyWB.cells(x, 2).Font.Color = RGB(128,210,35)
      MyWB.cells(x, 2).Font.bold = True   
     Else 
      MyWB.Cells(x, 1).Value = strComputer 
      MyWB.Cells(x, 2).Value = strValue1
   End If
   End If                     
   '----- Write to XLS ----- 
   MyWB.Cells(x, 1).Value = strComputer 
   MyWB.Cells(x, 2).Value = strValue1
   MyWB.Cells(x, 3).Value = strHotfixes
 End If 
'--------------------------------------- 
Next
MyWB.Cells.EntireColumn.AutoFit
End Sub

MsgBox "List is complete"
Edited by savj14

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...