5 Replies - 300 Views - Last Post: 01 November 2012 - 10:45 AM Rate Topic:

#1 stephen.madden

D.I.C Head

Reputation: 0

Posts: 64
Joined: 15-May 09

Adding another registry location and data to the same Excel Worksheet

Posted 31 October 2012 - 11:47 AM

I am not a VB guy, and I know this is VB Script, so if this is the wrong location, I am sorry. But, I manipulated a bit of code a stumbled across that gets values for applications installed on system. Since this is a 64 bit Windows 7 box, I modified the registry location to pull from HKLM:\Software\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall. But, there are also values in the location of HKLM:\Software\Microsoft\Windows\CurrentVersion\Uninstall. Question is, after creating a variable for the other location, such as Dim str32Key = HKLM:\Software\Microsoft\Windows\CurrentVersion\Uninstall, what would be the best way to concatenate these values in the same Excel Worksheet. Here is the code I have thus far. Thanks!Like I said, I know I must create an additional variable for the key location. And i know I must get the other objReg values. Any assistance is greatly appreciated.

Dim lngRow2 
Dim WshShell 
Dim BtnCode 
 
Dim intReturn 
Dim intVMajorValue 
Dim intVMinorValue 
Dim intSizeValue 
Dim strDisplayNameValue 
Dim strQuietDisplayNameValue 
Dim strDateValue 
Dim objReg 
Dim strKey 
Dim strSubkey 
Dim arrSubkeys 
 
Dim arrForbiddenApps() 
Dim arrComputer() 
 
    Set objExcel = CreateObject("Excel.Application") 
    Set objWorkbook = objExcel.Workbooks.Open ("C:\Users\stephen.madden\Desktop\test2.xlsx") 
    Set objSheet=objExcel.Workbooks.Item(1) 
     
    Set WshShell = WScript.CreateObject("WScript.Shell") 
     
    objExcel.Visible = True 
    lngRow2 = 2 
     
    'strComputer = "."  
    strKey = "Software\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall"  
 
    strDisplayName = "DisplayName"  
    strQuietDisplayName = "QuietDisplayName"  
    strInstallDate = "InstallDate"  
    strVersionMajor = "VersionMajor"  
    strVersionMinor = "VersionMinor"  
    strEstimatedSize = "EstimatedSize"  
  
     BtnCode = WshShell.Popup("Start Searching for installed Applications?", 7, "WindowsOnlineActivation:", 4 + 32) 
 
    If BtnCode = 6 Then 
        'WScript.Echo "Get Installed Applications" 
        Call fct_GetForbiddenApplications(objExcel, arrForbiddenApps) 
         
        Call fct_GetComputer(objExcel, arrComputer) 
         
        For each strComputer In arrComputer 
            On Error Resume Next 
             
            wscript.echo strComputer 
 
            Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv") 
            If Err.Number <> 0 Then Call ErrorCheck(Err.Number, Err.Description) 
             
            objReg.EnumKey HKLM, strKey, arrSubkeys  
 
            objExcel.Workbooks.Item(1).Sheets.Add  
            objSheet.ActiveSheet.Name=strComputer 
 
            objExcel.Cells(1, 1).Value = strComputer 
            objExcel.Cells(1, 1).Font.Bold = True 
            objExcel.Cells(1, 2).Value = strDisplayName 
            objExcel.Cells(1, 2).Font.Bold = True 
            objExcel.Cells(1, 3).Value = strQuietDisplayName 
            objExcel.Cells(1, 3).Font.Bold = True 
            objExcel.Cells(1, 4).Value = strInstallDate 
            objExcel.Cells(1, 4).Font.Bold = True 
            objExcel.Cells(1, 5).Value = "Version" 
            objExcel.Cells(1, 5).Font.Bold = True 
            objExcel.Cells(1, 6).Value = strEstimatedSize 
            objExcel.Cells(1, 6).Font.Bold = True 
            For Each strSubkey In arrSubkeys  
                intReturn = objReg.GetStringValue(HKLM, strKey & strSubkey, strDisplayName, strDisplayNameValue)  
                If intReturn <> 0 Then  
                    objReg.GetStringValue HKLM, strKey & strSubkey, strQuietDisplayName, strQuietDisplayNameValue  
                End If  
                If Trim(strDisplayNameValue) <> "" Then 
                     
                    objReg.GetStringValue HKLM, strKey & strSubkey, strInstallDate, strDateValue  
                    objReg.GetDWORDValue HKLM, strKey & strSubkey, strVersionMajor, intVMajorValue  
                    objReg.GetDWORDValue HKLM, strKey & strSubkey, strVersionMinor, intVMinorValue  
                    objReg.GetDWORDValue HKLM, strKey & strSubkey, strEstimatedSize, intSizeValue  
                     
                    if fct_IsAppForbidden(strDisplayNameValue, arrForbiddenApps) = True Then 
                        objExcel.Cells(lngRow2, 2).Font.Bold = True 
                        objExcel.Cells(lngRow2, 2).Interior.ColorIndex = 3 
                    End If 
                     
                    objExcel.Cells(lngRow2, 2).Value = strDisplayNameValue 
                    objExcel.Cells(lngRow2, 3).Value = strQuietDisplayNameValue 
                    Call fct_SetDateValue (strDateValue) 
                    objExcel.Cells(lngRow2, 4).Value = strDateValue 
                    If intVMajorValue <> "" Then 
                        objExcel.Cells(lngRow2, 5).Value = "V." & intVMajorValue & "." & intVMinorValue 
                        If intSizeValue <> "" Then 
                            objExcel.Cells(lngRow2, 6).Value = intSizeValue / 1024 & " MB" 
                        End if                         
                    End if 
                    lngRow2 = lngRow2 +1 
                End If 
            Next 
            Set objRange = objExcel.Range("B1")  
            objRange.Activate  
            Set objRange = objExcel.ActiveCell.EntireColumn  
            objRange.Autofit()  
            Set objRange = Nothing 
            Set objReg = Nothing 
             
        Next 
        'Wscript.Echo "Searching for installed Applications finished" 
    Else 
        'Wscript.Echo "Searching for installed Applications not started" 
    End If 
 
objExcel.Save 
objExcel.Quit 
Set objWorkbook = Nothing 
Set objExcel = Nothing 
 
Public Function fct_SetDateValue (strDateValue) 
Dim strYear 
Dim strMonth 
Dim strDay 
    If strDateValue <> "" Then  
        strYear =  Left(strDateValue, 4)  
        strMonth = Mid(strDateValue, 5, 2)  
        strDay = Right(strDateValue, 2)  
    'some Registry entries have improper date format  
        On Error Resume Next   
        strDateValue = DateSerial(strYear, strMonth, strDay)  
    End If  
End Function 
 
Public Function fct_GetForbiddenApplications(objExcel, arrForbiddenApps) 
Dim nRow 
 
    objExcel.Sheets(2).select 
    nRow = 2 
    Do Until objExcel.Cells(nRow,1).Value = "" 
        Redim Preserve arrForbiddenApps(nRow-2) 
        arrForbiddenApps(nRow-2) = objExcel.Cells(nRow,1).Value 
        nRow = nRow +1 
    Loop 
     
End Function 
 
Public Function fct_GetComputer(objExcel, arrComputer) 
Dim nRow 
 
    objExcel.Sheets(1).select 
    nRow = 2 
    Redim arrComputer(0) 
    Do Until objExcel.Cells(nRow,1).Value = "" 
        Redim Preserve arrComputer(nRow-2) 
        arrComputer(nRow-2) = objExcel.Cells(nRow,1).Value 
        nRow = nRow +1 
    Loop 
    ' local 
    If nRow <= 3 and arrComputer(0) = "" Then 
        Redim Preserve arrComputer(0) 
        arrComputer(0) = "." 
    End If 
     
End Function 
 
Public Function fct_IsAppForbidden(strDisplayNameValue, arrForbiddenApps)  
Dim x 
Dim nPos 
 
    For x = 0 to UBound(arrForbiddenApps) 
        nPos = InStr(1,UCase(strDisplayNameValue),UCase(arrForbiddenApps(x))) 
        If nPos > 0 Then 
            fct_IsAppForbidden = True 
            Exit For 
        End if 
    Next 
     
End Function 
 
Sub ErrorCheck(sErrorCode, sErrorDescription)  
 
    Select Case sErrorCode  
    Case 462  
        MsgBox "Target computer is not found!" & vbCrLf & VbCrLf _  
        & "Check that target computer is online and" & vbCrLf _  
        & "it's local firewall is disabled.",64,"Computer not found"  
         
        Err.Clear  
    Case Else  
        MsgBox "Error occurred." & vbCrLf & VbCrLf _  
        & "Error code is:" & sErrorCode & vbCrLf _  
        & "Error description is: " & sErrorDescription,64,"Mystical error occurred"  
 
        Err.Clear  
    End Select  
 
End Sub

Is This A Good Question/Topic? 0

Replies To: Adding another registry location and data to the same Excel Worksheet

#2 stephen.madden

D.I.C Head

Reputation: 0

Posts: 64
Joined: 15-May 09

Re: Adding another registry location and data to the same Excel Worksheet

Posted 31 October 2012 - 08:37 PM

No one ever replies to my shit. hahahaha!

Was This Post Helpful? 0

#3 maj3091

D.I.C Lover

Reputation: 271

Posts: 1,632
Joined: 26-March 09

Re: Adding another registry location and data to the same Excel Worksheet

Posted 01 November 2012 - 12:53 AM

You always reply to your own!

What exactly do you mean by concatenate both strings in excel??

If you're talking about grabbing both sets of information, then just add a loop around your registry reading part and replace the key to look at??

This post has been edited by maj3091: 01 November 2012 - 12:54 AM

Was This Post Helpful? 0

#4 stephen.madden

D.I.C Head

Reputation: 0

Posts: 64
Joined: 15-May 09

Re: Adding another registry location and data to the same Excel Worksheet

Posted 01 November 2012 - 07:06 AM

I mean I want to get the Display Names, Versions, and other values from both the HKLM:\Software\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall and HKLM:\Software\Microsoft\Windows\CurrentVersion\Uninstall locations, and put them in the same worksheet. With what you see in the code I posted, I can currently get from only one location and open the spreadsheet, populate the data, save, and close...

Was This Post Helpful? 0

#5 stephen.madden

D.I.C Head

Reputation: 0

Posts: 64
Joined: 15-May 09

Re: Adding another registry location and data to the same Excel Worksheet

Posted 01 November 2012 - 07:42 AM

Okay, you were right. And, just had to add to the objReg.EnumKey...

Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE  
 
Dim strComputer 
 
Dim strDisplayName 
Dim strQuietDisplayName  
Dim strInstallDate  
Dim strVersionMajor  
Dim strVersionMinor  
Dim strEstimatedSize 
 
Dim objExcel 
Dim objWorkbook 
Dim objSheet 
Dim lngRow 
Dim lngRow2 
Dim WshShell 
Dim BtnCode 
 
Dim intReturn 
Dim intVMajorValue 
Dim intVMinorValue 
Dim intSizeValue 
Dim strDisplayNameValue 
Dim strQuietDisplayNameValue 
Dim strDateValue 
Dim objReg 
Dim strKey
Dim str64key 
Dim strSubkey 
Dim arrSubkeys 
 
Dim arrForbiddenApps() 
Dim arrComputer() 
 
    Set objExcel = CreateObject("Excel.Application") 
    Set objWorkbook = objExcel.Workbooks.Open ("C:\Users\stephen.madden\Desktop\test2.xlsx") 
    Set objSheet=objExcel.Workbooks.Item(1) 
     
    Set WshShell = WScript.CreateObject("WScript.Shell") 
     
    objExcel.Visible = True 
    lngRow2 = 2 
     
    'strComputer = "."  
    strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" 
    str64Key = "Software\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall" 
 
    strDisplayName = "DisplayName"  
    strQuietDisplayName = "QuietDisplayName"  
    strInstallDate = "InstallDate"  
    strVersionMajor = "VersionMajor"  
    strVersionMinor = "VersionMinor"  
    strEstimatedSize = "EstimatedSize"  
  
     BtnCode = WshShell.Popup("Start Searching for installed Applications?", 7, "WindowsOnlineActivation:", 4 + 32) 
 
    If BtnCode = 6 Then 
        'WScript.Echo "Get Installed Applications" 
        Call fct_GetForbiddenApplications(objExcel, arrForbiddenApps) 
         
        Call fct_GetComputer(objExcel, arrComputer) 
         
        For each strComputer In arrComputer 
            On Error Resume Next 
             
            wscript.echo strComputer 
 
            Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv") 
            If Err.Number <> 0 Then Call ErrorCheck(Err.Number, Err.Description) 
             
            objReg.EnumKey HKLM, strKey, arrSubkeys  
 
            objExcel.Workbooks.Item(1).Sheets.Add  
            objSheet.ActiveSheet.Name=strComputer 
 
            objExcel.Cells(1, 1).Value = strComputer 
            objExcel.Cells(1, 1).Font.Bold = True 
            objExcel.Cells(1, 2).Value = strDisplayName 
            objExcel.Cells(1, 2).Font.Bold = True 
            objExcel.Cells(1, 3).Value = strQuietDisplayName 
            objExcel.Cells(1, 3).Font.Bold = True 
            objExcel.Cells(1, 4).Value = strInstallDate 
            objExcel.Cells(1, 4).Font.Bold = True 
            objExcel.Cells(1, 5).Value = "Version" 
            objExcel.Cells(1, 5).Font.Bold = True 
            objExcel.Cells(1, 6).Value = strEstimatedSize 
            objExcel.Cells(1, 6).Font.Bold = True 
            For Each strSubkey In arrSubkeys  
                intReturn = objReg.GetStringValue(HKLM, strKey & strSubkey, strDisplayName, strDisplayNameValue)  
                If intReturn <> 0 Then  
                    objReg.GetStringValue HKLM, strKey & strSubkey, strQuietDisplayName, strQuietDisplayNameValue  
                End If  
                If Trim(strDisplayNameValue) <> "" Then 
                     
                    objReg.GetStringValue HKLM, strKey & strSubkey, strInstallDate, strDateValue  
                    objReg.GetDWORDValue HKLM, strKey & strSubkey, strVersionMajor, intVMajorValue  
                    objReg.GetDWORDValue HKLM, strKey & strSubkey, strVersionMinor, intVMinorValue  
                    objReg.GetDWORDValue HKLM, strKey & strSubkey, strEstimatedSize, intSizeValue  
                     
                    if fct_IsAppForbidden(strDisplayNameValue, arrForbiddenApps) = True Then 
                        objExcel.Cells(lngRow2, 2).Font.Bold = True 
                        objExcel.Cells(lngRow2, 2).Interior.ColorIndex = 3 
                    End If 
                     
                    objExcel.Cells(lngRow2, 2).Value = strDisplayNameValue 
                    objExcel.Cells(lngRow2, 3).Value = strQuietDisplayNameValue 
                    Call fct_SetDateValue (strDateValue) 
                    objExcel.Cells(lngRow2, 4).Value = strDateValue 
                    If intVMajorValue <> "" Then 
                        objExcel.Cells(lngRow2, 5).Value = "V." & intVMajorValue & "." & intVMinorValue 
                        If intSizeValue <> "" Then 
                            objExcel.Cells(lngRow2, 6).Value = intSizeValue / 1024 & " MB" 
                        End if                         
                    End if 
                    lngRow2 = lngRow2 +1 
                End If 
            Next
	    objReg.EnumKey HKLM, str64Key, arrSubkeys
            For Each strSubkey In arrSubkeys  
                intReturn = objReg.GetStringValue(HKLM, str64Key & strSubkey, strDisplayName, strDisplayNameValue)  
                If intReturn <> 0 Then  
                    objReg.GetStringValue HKLM, str64Key & strSubkey, strQuietDisplayName, strQuietDisplayNameValue  
                End If  
                If Trim(strDisplayNameValue) <> "" Then 
                     
                    objReg.GetStringValue HKLM, str64Key & strSubkey, strInstallDate, strDateValue  
                    objReg.GetDWORDValue HKLM, str64Key & strSubkey, strVersionMajor, intVMajorValue  
                    objReg.GetDWORDValue HKLM, str64Key & strSubkey, strVersionMinor, intVMinorValue  
                    objReg.GetDWORDValue HKLM, str64Key & strSubkey, strEstimatedSize, intSizeValue  
                     
                    if fct_IsAppForbidden(strDisplayNameValue, arrForbiddenApps) = True Then 
                        objExcel.Cells(lngRow2, 2).Font.Bold = True 
                        objExcel.Cells(lngRow2, 2).Interior.ColorIndex = 3 
                    End If 
                     
                    objExcel.Cells(lngRow2, 2).Value = strDisplayNameValue 
                    objExcel.Cells(lngRow2, 3).Value = strQuietDisplayNameValue 
                    Call fct_SetDateValue (strDateValue) 
                    objExcel.Cells(lngRow2, 4).Value = strDateValue 
                    If intVMajorValue <> "" Then 
                        objExcel.Cells(lngRow2, 5).Value = "V." & intVMajorValue & "." & intVMinorValue 
                        If intSizeValue <> "" Then 
                            objExcel.Cells(lngRow2, 6).Value = intSizeValue / 1024 & " MB" 
                        End if                         
                    End if 
                    lngRow2 = lngRow2 +1 
                End If 
            Next 
            Set objRange = objExcel.Range("B1")  
            objRange.Activate  
            Set objRange = objExcel.ActiveCell.EntireColumn  
            objRange.Autofit()  
            Set objRange = Nothing 
            Set objReg = Nothing 
             
        Next 
        'Wscript.Echo "Searching for installed Applications finished" 
    Else 
        'Wscript.Echo "Searching for installed Applications not started" 
    End If 
 
objExcel.Save 
objExcel.Quit 
Set objWorkbook = Nothing 
Set objExcel = Nothing 
 
Public Function fct_SetDateValue (strDateValue) 
Dim strYear 
Dim strMonth 
Dim strDay 
    If strDateValue <> "" Then  
        strYear =  Left(strDateValue, 4)  
        strMonth = Mid(strDateValue, 5, 2)  
        strDay = Right(strDateValue, 2)  
    'some Registry entries have improper date format  
        On Error Resume Next   
        strDateValue = DateSerial(strYear, strMonth, strDay)  
    End If  
End Function 
 
Public Function fct_GetForbiddenApplications(objExcel, arrForbiddenApps) 
Dim nRow 
 
    objExcel.Sheets(2).select 
    nRow = 2 
    Do Until objExcel.Cells(nRow,1).Value = "" 
        Redim Preserve arrForbiddenApps(nRow-2) 
        arrForbiddenApps(nRow-2) = objExcel.Cells(nRow,1).Value 
        nRow = nRow +1 
    Loop 
     
End Function 
 
Public Function fct_GetComputer(objExcel, arrComputer) 
Dim nRow 
 
    objExcel.Sheets(1).select 
    nRow = 2 
    Redim arrComputer(0) 
    Do Until objExcel.Cells(nRow,1).Value = "" 
        Redim Preserve arrComputer(nRow-2) 
        arrComputer(nRow-2) = objExcel.Cells(nRow,1).Value 
        nRow = nRow +1 
    Loop 
    ' local 
    If nRow <= 3 and arrComputer(0) = "" Then 
        Redim Preserve arrComputer(0) 
        arrComputer(0) = "." 
    End If 
     
End Function 
 
Public Function fct_IsAppForbidden(strDisplayNameValue, arrForbiddenApps)  
Dim x 
Dim nPos 
 
    For x = 0 to UBound(arrForbiddenApps) 
        nPos = InStr(1,UCase(strDisplayNameValue),UCase(arrForbiddenApps(x))) 
        If nPos > 0 Then 
            fct_IsAppForbidden = True 
            Exit For 
        End if 
    Next 
     
End Function 
 
Sub ErrorCheck(sErrorCode, sErrorDescription)  
 
    Select Case sErrorCode  
    Case 462  
        MsgBox "Target computer is not found!" & vbCrLf & VbCrLf _  
        & "Check that target computer is online and" & vbCrLf _  
        & "it's local firewall is disabled.",64,"Computer not found"  
         
        Err.Clear  
    Case Else  
        MsgBox "Error occurred." & vbCrLf & VbCrLf _  
        & "Error code is:" & sErrorCode & vbCrLf _  
        & "Error description is: " & sErrorDescription,64,"Mystical error occurred"  
 
        Err.Clear  
    End Select  
 
End Sub

Was This Post Helpful? 0

#6 maj3091

D.I.C Lover

Reputation: 271

Posts: 1,632
Joined: 26-March 09

Re: Adding another registry location and data to the same Excel Worksheet

Posted 01 November 2012 - 10:45 AM

Glad you got it sorted.

Was This Post Helpful? 0

Page 1 of 1

Adding another registry location and data to the same Excel Worksheet

5 Replies - 300 Views - Last Post: 01 November 2012 - 10:45 AM Rate Topic:

#1 stephen.madden

Adding another registry location and data to the same Excel Worksheet

Replies To: Adding another registry location and data to the same Excel Worksheet

#2 stephen.madden

Re: Adding another registry location and data to the same Excel Worksheet

#3 maj3091

Re: Adding another registry location and data to the same Excel Worksheet

#4 stephen.madden

Re: Adding another registry location and data to the same Excel Worksheet

#5 stephen.madden

Re: Adding another registry location and data to the same Excel Worksheet

#6 maj3091

Re: Adding another registry location and data to the same Excel Worksheet

General Discussion

Programming Help

Web Development

Follow & Share

Give It A Try!

VB Tutorials

Reference Sheets

VB Snippets

DIC Chatroom

Bye Bye Ads

Monthly Drawing