savj14 Posted September 4, 2007 Posted September 4, 2007 (edited) The Converter did not work.........Can anyone Help?? Here is the vb script: expandcollapse popup'----- 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 September 4, 2007 by savj14
Recommended Posts
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 accountSign in
Already have an account? Sign in here.
Sign In Now