# VB scripting question



## clmowers (Jun 20, 2005)

Hello, Hopefully this will be pretty easy. I found some script on Microsoft site that will help gather computer infomation. What i would like to do is have the scripts put the information into a excel spreadsheet or something. Right now, the scripts are echoing the info on the screen. Which is fine but i need to run this on several computers and need to be able to view the info later. Any help would be great. thanks


----------



## saikee (Jun 11, 2004)

What is stopping you from "cut and paste" the script s (even directly off the Internet screen) into the VB editor of a Excel spread sheet?


----------



## Rollin_Again (Sep 4, 2003)

Can you post your existing script for us to see?

Rollin


----------



## clmowers (Jun 20, 2005)

```
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
strComputer = "."
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
strEntry1a = "DisplayName"
strEntry1b = "QuietDisplayName"
strEntry2 = "InstallDate"
strEntry3 = "VersionMajor"
strEntry4 = "VersionMinor"
strEntry5 = "EstimatedSize"

Set objReg = GetObject("winmgmts://" & strComputer & _
 "/root/default:StdRegProv")
objReg.EnumKey HKLM, strKey, arrSubkeys
WScript.Echo "Installed Applications" & VbCrLf
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
  If strValue1 <> "" Then
    WScript.Echo VbCrLf & "Display Name: " & strValue1
  End If
  objReg.GetStringValue HKLM, strKey & strSubkey, _
   strEntry2, strValue2
  If strValue2 <> "" Then
    WScript.Echo "Install Date: " & strValue2
  End If
  objReg.GetDWORDValue HKLM, strKey & strSubkey, _
   strEntry3, intValue3
  objReg.GetDWORDValue HKLM, strKey & strSubkey, _
   strEntry4, intValue4
  If intValue3 <> "" Then
     WScript.Echo "Version: " & intValue3 & "." & intValue4
  End If
  objReg.GetDWORDValue HKLM, strKey & strSubkey, _
   strEntry5, intValue5
  If intValue5 <> "" Then
    WScript.Echo "Estimated Size: " & Round(intValue5/1024, 3) & " megabytes"
  End If
Next
[code]
```


----------



## Rollin_Again (Sep 4, 2003)

Do you need to have the script create the Excel workbook and will the workbook already exist on each machine?

Rollin


----------



## clmowers (Jun 20, 2005)

Well i would like it to create the workbook if possible


----------



## Rollin_Again (Sep 4, 2003)

Try the modified code below. I did not include code to save the workbook so make sure to manually save to a location of your choice.


```
Dim objExcel 
Dim objWorkBook 
Dim vLastRow

Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
strComputer = "."
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
strEntry1a = "DisplayName"
strEntry1b = "QuietDisplayName"
strEntry2 = "InstallDate"
strEntry3 = "VersionMajor"
strEntry4 = "VersionMinor"
strEntry5 = "EstimatedSize"

Set objExcel = CreateObject("EXCEL.APPLICATION")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
objWorkbook.ActiveSheet.Range("A1").Value =  "DisplayName"
objWorkbook.ActiveSheet.Range("B1").Value = "InstallDate"
objWorkbook.ActiveSheet.Range("C1").Value = "VersionMajor"
objWorkbook.ActiveSheet.Range("D1").Value = "EstimatedSize"

vLastRow = objWorkbook.Activesheet.UsedRange.Rows.Count + 1

Set objReg = GetObject("winmgmts://" & strComputer & _
"/root/default:StdRegProv")
objReg.EnumKey HKLM, strKey, arrSubkeys
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
If strValue1 <> "" Then
objWorkbook.ActiveSheet.Range("A" & vLastRow).Value =  strValue1
End If
objReg.GetStringValue HKLM, strKey & strSubkey, _
strEntry2, strValue2
If strValue2 <> "" Then
objWorkbook.ActiveSheet.Range("B" & vLastRow).Value =  strValue2
End If
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry3, intValue3
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry4, intValue4
If intValue3 <> "" Then
objWorkbook.ActiveSheet.Range("C" & vLastRow).Value =   intValue4
End If
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry5, intValue5
If intValue5 <> "" Then
objWorkbook.ActiveSheet.Range("D" & vLastRow).Value =   Round(intValue5/1024, 3) & " megabytes"
End If

vLastRow = objWorkbook.Activesheet.UsedRange.Rows.Count + 1
Next
```
Regards,
Rollin


----------



## clmowers (Jun 20, 2005)

What would that code be to save it automaticlly?


----------



## Rollin_Again (Sep 4, 2003)

Just add the following line to the end of the code and change the path to reflect the true save destination. Did you test the code to see if it does what you want?


```
objWorkbook.SaveAs ("C:\TEST.xls")
```
Rollin


----------



## clmowers (Jun 20, 2005)

Yes, i did test the code and it works great. Thanks so much


----------



## clmowers (Jun 20, 2005)

Very cool. Thanks. The code works perfect. I think i have enough info to go by to modify the others. Thanks


----------



## MMJ (Oct 15, 2006)

Very nice! 

What is the copyright on this script?


----------



## clmowers (Jun 20, 2005)

Im not sure if there is one. It freely avaible on microsofts site


----------



## MMJ (Oct 15, 2006)

Is there a way to make the excel file fill up immediately?

Also where is this script on MS's site?


----------



## clmowers (Jun 20, 2005)

This script does fill the info immediately. Unless im not sure what you mean by that

http://www.microsoft.com/technet/scriptcenter/default.mspx

Just do some clicking here. but this is where i found the script above. there are lot of scripts up there that can be usefull vor any system admin or tech


----------



## MMJ (Oct 15, 2006)

No, the script fills up one line at a time for me.

So the excel file takes like 30 seconds to fill all the way.

Thanks for the link.


----------



## clmowers (Jun 20, 2005)

Oh i see what you are saying. Im not sure if there is a way. But i see what you are saying now. 
And your welcome for the link


----------



## Rollin_Again (Sep 4, 2003)

If you want to speed up the code processing and suppress the line by line updating you have two options. Both ways should reduce the processing time from about 20-30 seconds to about 5.

Keep the Excel object hidden and do not display until the code is finished processing. So basically take the line *objExcel.Visible = True* and move it outside of your "For/Next" loop.


```
Set objExcel = CreateObject("EXCEL.APPLICATION")

'code
'code

Next
objExcel.Visible = True
```
You can also suppress Screen Updating by adding the following line of code just after the Excel object is created *objExcel.ScreenUpdating = False*

After the code is finished processing and you have exited the "For/Next" loop just turn the updating back on using *objExcel.ScreenUpdating = True*


```
Set objExcel = CreateObject("EXCEL.APPLICATION")
objExcel.Visible = True
objExcel.ScreenUpdating = False

'code
'code

Next
objExcel.ScreenUpdating = True
```
Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

How can you change this code to give you the computer name too?


----------



## Rollin_Again (Sep 4, 2003)

Copy and paste the code below into a blank module and then run the macro called function named "GetName"

You can also get the name from another sub by calling the function called funcCompName


```
Private Declare Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function funcCompName() As String

    Dim lngLen As Long, lngX As Long
    Dim strCompName As String
    lngLen = 16
    strCompName = String$(lngLen, 0)
    lngX = apiGetComputerName(strCompName, lngLen)
    If lngX <> 0 Then
        funcCompName = Left$(strCompName, lngLen)
    End If
End Function


Public Sub GetName()

strCompName = funcCompName
MsgBox (strCompName)

End Sub
```
Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

Ok ! can you explain a little more how do add your code to my code?


----------



## Rollin_Again (Sep 4, 2003)

Copy and paste the code below at the very top of your existing code module


```
Private Declare Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function funcCompName() As String

    Dim lngLen As Long, lngX As Long
    Dim strCompName As String
    lngLen = 16
    strCompName = String$(lngLen, 0)
    lngX = apiGetComputerName(strCompName, lngLen)
    If lngX <> 0 Then
        funcCompName = Left$(strCompName, lngLen)
    End If
End Function
```
After pasting the above code into your module your function will be declared and defined and you can call it from anywhere else in your code by using the two lines below. If you continue to have problems post your workbook or document and I'll help you.


```
strCompName = funcCompName
MsgBox (strCompName)
```
Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

This is my code:
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
strComputer = "."
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
strEntry1a = "DisplayName"
strEntry1b = "QuietDisplayName"
strEntry2 = "InstallDate"
strEntry3 = "VersionMajor"
strEntry4 = "VersionMinor"
strEntry5 = "EstimatedSize"

Set objReg = GetObject("winmgmts://" & strComputer & _
"/root/default:StdRegProv")
objReg.EnumKey HKLM, strKey, arrSubkeys
WScript.Echo "Installed Applications" & VbCrLf
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
If strValue1 <> "" Then
WScript.Echo VbCrLf & "Display Name: " & strValue1
End If
objReg.GetStringValue HKLM, strKey & strSubkey, _
strEntry2, strValue2
If strValue2 <> "" Then
WScript.Echo "Install Date: " & strValue2
End If
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry3, intValue3
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry4, intValue4
If intValue3 <> "" Then
WScript.Echo "Version: " & intValue3 & "." & intValue4
End If
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry5, intValue5
If intValue5 <> "" Then
WScript.Echo "Estimated Size: " & Round(intValue5/1024, 3) & " megabytes"
End If
Next

I will like when I run the script to give the computername and to save on the network drive.
Thank for help me!


----------



## Rollin_Again (Sep 4, 2003)

I'm sorry....the code I provided you earlier is for VBA. I didn't realize you needed the code for a VBS script. Just add the code below. The computer name will be assigned to the variable strInfo. Just change form a Messagebox to whatever action you want to take.


```
Dim objNetwork

Set objNetwork = CreateObject("WScript.NetWork") 
	
Dim strComputer
strComputer = objNetwork.ComputerName 
         
MsgBox strComputer
	
Set objNetwork = Nothing
```
I'm not exactly sure what you want saved to the network drive. Do you want this info saved into a text file or Excel workbook and then saved on the network? If so, the code needs to be modified to create the destination file and then save to your location.

Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

yes when I run the code to give me the output in excel and to be save on the network drive.


----------



## Rollin_Again (Sep 4, 2003)

So how does the computer name come into play? What is the save path you want the Excel file written to?

Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

What i am trying to do is when I run the script to give the the name or asset number of the computer and the software on excel sheet on the E drive, which is a network drive.


----------



## Rollin_Again (Sep 4, 2003)

Copy and paste into a text file and re-name with *.vbs* extension.

This will create the Excel workbook and save to the *E:\* drive as: _ComputerName_.xls

Cell A1 of the Excel workbook will also contain the computer name.


```
Dim objExcel 
Dim objWorkBook 
Dim vLastRow
Dim objNetwork
Dim strComputerName

Set objNetwork = CreateObject("WScript.NetWork") 
strComputerName = objNetwork.ComputerName 

Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
strComputer = "."
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
strEntry1a = "DisplayName"
strEntry1b = "QuietDisplayName"
strEntry2 = "InstallDate"
strEntry3 = "VersionMajor"
strEntry4 = "VersionMinor"
strEntry5 = "EstimatedSize"

Set objExcel = CreateObject("EXCEL.APPLICATION")
Set objWorkbook = objExcel.Workbooks.Add()
objWorkbook.activesheet.Range("A1").value = strComputerName
objWorkbook.ActiveSheet.Range("A2").Value =  "DisplayName"
objWorkbook.ActiveSheet.Range("B2").Value = "InstallDate"
objWorkbook.ActiveSheet.Range("C2").Value = "VersionMajor"
objWorkbook.ActiveSheet.Range("D2").Value = "EstimatedSize"

vLastRow = objWorkbook.Activesheet.UsedRange.Rows.Count + 1

Set objReg = GetObject("winmgmts://" & strComputer & _
"/root/default:StdRegProv")
objReg.EnumKey HKLM, strKey, arrSubkeys
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
If strValue1 <> "" Then
objWorkbook.ActiveSheet.Range("A" & vLastRow).Value =  strValue1
End If
objReg.GetStringValue HKLM, strKey & strSubkey, _
strEntry2, strValue2
If strValue2 <> "" Then
objWorkbook.ActiveSheet.Range("B" & vLastRow).Value =  strValue2
End If
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry3, intValue3
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry4, intValue4
If intValue3 <> "" Then
objWorkbook.ActiveSheet.Range("C" & vLastRow).Value =   intValue4
End If
objReg.GetDWORDValue HKLM, strKey & strSubkey, _
strEntry5, intValue5
If intValue5 <> "" Then
objWorkbook.ActiveSheet.Range("D" & vLastRow).Value =   Round(intValue5/1024, 3) & " megabytes"
End If

vLastRow = objWorkbook.Activesheet.UsedRange.Rows.Count + 1
Next


vPath = "E:\" & strComputerName & ".xls"

objWorkbook.SaveAs(vPath)
objWorkbook.Close

Set objExcel = Nothing
Set objWorkbook = Nothing
Set objNetwork = Nothing
Set objReg = Nothing  

Msgbox("Complete")
```
Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

I still have problem when I run the programm it give syntax error,line58 and char79


----------



## Rollin_Again (Sep 4, 2003)

Sorry.....When I copies and pasted the code a few extra spaces got included. I fixed the code above and also included the file as an attachement to this post. Download the attached text file and manually rename the *.txt* extension to *.vbs* and then run it.

Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

Thank you! it work fine now. But I want to ask you one more question when I try to put to another comp is not working?


----------



## Rollin_Again (Sep 4, 2003)

Does it give an error? Have you checked to make sure there is no anti-virus or anti-spyware running that may be preventing the script from running?

Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

The file name or path name does not exist
The file you are trying to open is being used by another prog.Close the document in the other program and try again
The name of the workbook yo are trying to save is the same of another doc that is read-only
code;800A03EC
source: Microsoft Excel
line 67
char1
this is the error


----------



## Rollin_Again (Sep 4, 2003)

Go into the task manager and kill *Excel.exe* from the list of running processes and try again. Also make sure the *E:\* drive is mapped on that PC.

Regards,
Rollin


----------



## IBGhost (Apr 9, 2007)

Yes!!! it work.
Thank very much!


----------

