Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people, just like you, are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Solved

I need to convert a VBS to a Delphi GUI?

Posted on 2009-05-09
4
464 Views
Last Modified: 2013-11-23
Hello,
I do have a little problem, i do have this VBS script, and i need to convert it to a delphi instead. It has to be an exe with a GUI, i have been trying to it with no success :( . I do really need that for my work, can any body help? I have pasted the VBS bellow

Any help is really appreciated.
Thank you
On error resume next
 
Dim objUser, strExcelPath, objExcel, objSheet, k, objGroup, cnt, unReached
 
' Spreadsheet file to be created.
strExcelPath = "c:\UserGroup.xls"
 
Set objExcel = CreateObject("Excel.Application")
If (Err.Number <> 0) Then
    On Error GoTo 0
    Wscript.Echo "Excel application not found."
    Wscript.Quit
End If
'On Error GoTo 0
 
cnt = 2
unReached = 2
Const ADS_SCOPE_SUBTREE = 2
Set fso = CreateObject("Scripting.FileSystemObject")
 
' Create a new workbook.
objExcel.Workbooks.Add
 
' Bind to worksheet.
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objSheet.Name = "User Groups"
 
Set objSheetU = objExcel.ActiveWorkbook.Worksheets(2)
objSheetU.Name = "Unavailable"
objExcel.ActiveWorkbook.SaveAs strExcelPath
 
' Populate spreadsheet cells with user attributes.
objSheet.Cells(1, 1).Value = "Computer Name"
objSheet.Cells(1, 2).Value = "User Name"
objSheet.Cells(1, 3).Value = "Manufacturer"
objSheet.Cells(1, 4).Value = "Model"
objSheet.Cells(1, 5).Value = "Serial No"
objSheet.Cells(1, 6).Value = "Part No"
objSheet.Cells(1, 7).Value = "OS"
objSheet.Cells(1, 8).Value = "Processor"
objSheet.Cells(1, 9).Value = "Ram"
objSheet.Cells(1, 10).Value = "DiskDrive Size"
objSheet.Cells(1, 11).Value = "Graphic Card Model"
objSheet.Cells(1, 12).Value = "Graphic Card Memory"
 
 
objSheetU.Cells(1, 1).Value = "Computer Name"
 
 
 
set list = fso.CreateTextFile("./output.txt")
Set upgrade = fso.CreateTextFile("./upgrade.txt")
 
strDomainDn = InputBox("domain" & vbCrLf & "(i.e. dc=domain,dc=com)")
 
If strDomainDn = "" Then
	WScript.Echo "Exiting!"
	WScript.Quit
End If
 
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand =   CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
 
Set objCOmmand.ActiveConnection = objConnection
objCommand.CommandText = _
    "Select Name, Location from 'LDAP://" & strDomainDn & "' " _
        & "Where objectClass='computer'"  
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE 
 
Set objRecordSet = objCommand.Execute
objRecordSet.MoveFirst
 
Do Until objRecordSet.EOF
    
    ' list.write "Computer Name: " & objRecordSet.Fields("Name").Value
    strComputer = objRecordSet.Fields("Name").Value
    
    Set objShell = CreateObject("WScript.Shell")
    strCommand = "%comspec% /c ping -n 3 -w 1000 " & strComputer & ""
    Set objExecObject = objShell.Exec(strCommand)
 
	Do While Not objExecObject.StdOut.AtEndOfStream
        strText = objExecObject.StdOut.ReadAll()
        If Instr(strText, "Reply") > 0 Then
            Set objWMIService = GetObject _
                ("winmgmts:\\" & strComputer & "\root\cimv2")
	 	    Set colItems = objWMIService.ExecQuery _
	                ("Select * From Win32_OperatingSystem")
		      
		    Set colItems2 = objWMIService.ExecQuery("Select * from Win32_BIOS",,48)
	           ' list.write Err.Description
		    Set colItems3 = objWMIService.ExecQuery("Select * from Win32_ComputerSystem",,48)
		    Set colItems4 = objWMIService.ExecQuery("SELECT * FROM Win32_Processor", "WQL", _
	                                          wbemFlagReturnImmediately + wbemFlagForwardOnly)
		    Set colItems5 = objWMIService.ExecQuery("Select * from Win32_VideoController ")
 		    Set colItems6 = objWMIService.ExecQuery("Select * from Win32_DiskDrive")
		    Set colItems7 = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
		    Set colItems8 = objWMIService.ExecQuery("Select * from Win32_SystemEnclosure")
	
 
 
 
 
		    For Each objItem in ColItems
	        	strOS = objItem.Caption
		    Next
			
		    For Each objItem in colItems2
				strSerialno = objItem.SerialNumber
				strManu = objItem.Manufacturer
	    	    Next
			
		    For Each objItem in colItems5
				strGraphicalVideoCard = objItem.Caption
				strGraphicalVideoCardMemory = objItem.AdapterRAM
		    Next
			
		    For Each objItem in colItems6
				strHDsize = objItem.Size
		    Next
			
		    For Each objItem in colItems7
				stOS = objItem.Caption
		    Next
 
			
	
		    For Each objItem in colitems3
		        strUserName = objItem.Username
				strModel = objItem.Model
				strRAM = objItem.TotalPhysicalMemory
				strTimeZone = (objItem.CurrentTimeZone / 60)
				strDayLightSavings = objItem.DaylightInEffect
		    Next
		
		    For Each objItem in colitems4
				strProcessor = objItem.Name
	        Next
			
			If Err.Number > 0 then
			    strErrorSystems =  strComputer & ", " & strErrorSystems 
			Else
			    list.write "-------------------------------------------------------------" & vbcrlf & vbcrlf
			    list.write "Computer Name: " & strComputer & ", " & strUserName & vbcrlf 
			    list.write "-------------------------------------------------------------" & vbcrlf & vbcrlf
'#################### Comuter Name ###################################
objSheet.Cells(cnt, 1).Value = strComputer
'####################################################################
		        list.write "Operating System: " & strOS & vbcrlf
	            list.write "Current User: " & strUserName & vbcrlf
'#################### Current User ###################################
objSheet.Cells(cnt, 2).Value = strUserName
'####################################################################
			    list.write "::::" & vbcrlf
			    list.write "Manufacturer: " & strManu & vbcrlf
'#################### Manufacturer  ###################################
objSheet.Cells(cnt, 3).Value = strManu
'####################################################################
			    list.write "Model: " & strModel & vbcrlf
'#################### Model  ###################################
objSheet.Cells(cnt, 4).Value = strModel
'####################################################################
			    list.write "Service Tag: " & DellTag & vbcrlf
			    list.write "Processor type: " & strProcessor & vbcrlf
'#################### Processor ###################################
objSheet.Cells(cnt, 8).Value = strProcessor
'####################################################################
			    list.write "RAM: " & strRAM & vbcrlf
'#################### Ram  ###################################
memoryX = (strRam/1024)/1024
memoryX = Int(memoryX)
memoryX = memoryX + 2
objSheet.Cells(cnt, 9).Value = memoryX 
'########################################################################################
list.write "GraphicalVideoCard: " & strGraphicalVideoCard & vbcrlf
'##############################  GraphicalVideoCard ######################################
objSheet.Cells(cnt, 11).Value = strGraphicalVideoCard
'##############################  GraphicalVideoCard Memory ######################################
memoryz = (strGraphicalVideoCardMemory/1024)/1024
memoryz = Int(memoryz)
objSheet.Cells(cnt, 12).Value = memoryz 
'##############################  Hard Drive Memory ######################################
memoryT = ((strHDsize/1024)/1024)/1024
memoryT = Int(memoryT)
objSheet.Cells(cnt, 10).Value = memoryT
'#################### Serial Number ###################################
objSheet.Cells(cnt, 5).Value = strSerialno
'#################### O S ###################################
objSheet.Cells(cnt, 7).Value = stOS
'#################### O S ###################################
objSheet.Cells(cnt, 6).Value = strModel
 
 
 
 
			    list.write "Time Zone: " & strTimeZone & vbcrlf
			    list.write "Daylight Savings in effect: " & strDayLightSavings & vbcrlf
			    list.write "-------------------------------------------------------------" & vbcrlf & vbCrLf
			    memory = (strRam/1024)/1024
			    memory = Int(memory)
			    memory = memory + 2
				
								
			End If
			    
		    'flushes error code from the previous loop
		    Err.Clear
	   Else
	     	UnavailableSystems =  strComputer & ", " & UnavailableSystems
		objSheetU.Cells(unReached, 1).Value = strComputer
unReached = unReached + 1
	   End If
    Loop
    objRecordSet.MoveNext
    cnt = cnt +1
 
objExcel.ActiveWorkbook.Save
Loop
 
list.write "The following systems were unavailable: " & UnavailableSystems & vbcrlf
list.write " " & vbcrlf & vbcrlf
list.write "The following systems were on, but returned an error: " & strErrorSystems & vbcrlf
 
' Save the spreadsheet and close the workbook.
 
objExcel.ActiveWorkbook.Close
 
' Quit Excel.
objExcel.Application.Quit
 
WScript.Echo "Done!"

Open in new window

0
Comment
Question by:MarryJ
  • 2
4 Comments
 
LVL 45

Expert Comment

by:aikimark
ID: 24355702
Here are examples of using WMI with Delphi:
http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_23201105.html
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=628&lngWId=7
http://www.prototypical.co.uk/pdf/are%20you%20wmi%202.pdf
Downloadable example from Embarcadero is knowledgebase item 19255

There are also some WMI wrapper libraries, like:
http://www.online-admin.com/wmiset.html

===========================
For simplicity, I would eliminate the FileSystemObjects when creating the list and update files.  Note that the Update file is never written to an these statements can be deleted.

There are two options for writing the data into Excel.  You can instantiate an Excel object, much like the VBScript code.  You can also use an TExcel control on your Delphi form.

===========================
What is your level of Delphi expertise?
What is your level of VBScrip expertise?

0
 

Author Comment

by:MarryJ
ID: 24356477
Thank You,
I will try that , i hope i couldnt build some sort of GUI using your tips as its needed by one of my clients.
I know nothing about VBscripting, i only work with a team in customizing database applications in delphi.
0
 
LVL 45

Accepted Solution

by:
aikimark earned 500 total points
ID: 24357983
If you have some flexibility, you might use a stringgrid control on your Delphi form to display the results.  That will relieve you from having to use Excel.

I'm more of a VB specialist than a Delphi specialist, so my second step helping you is to reformat the code you supplied and add comments to help you understand what is happening and what you might want to change during the rewrite process.
On Error Resume Next
 
Sub main()
 
' NOTE: all of these VBScript variables are variant data types
'Delphi ToDo: specific data type variable definitions
Dim objUser, strExcelPath, objExcel, objSheet, k, objGroup, cnt, unReached
 
' Spreadsheet filename that will be created.
strExcelPath = "c:\UserGroup.xls"
 
' instantiate Excel (automation) object
'Delphi ToDo: Use Try Catch structure
Set objExcel = CreateObject("Excel.Application")
If (Err.Number <> 0) Then
  ' Notify user of problem and exit procedure
  WScript.Echo "Excel application not found."
  WScript.Quit
End If
 
'local variables and constants
cnt = 2
unReached = 2
Const ADS_SCOPE_SUBTREE = 2
 
' NOTE: missing variable declarations for ColItems - ColItems8
 
' Create a new workbook.
objExcel.Workbooks.Add
 
' Bind to worksheet.
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
objSheet.Name = "User Groups"
 
Set objSheetU = objExcel.ActiveWorkbook.Worksheets(2)
objSheetU.Name = "Unavailable"
objExcel.ActiveWorkbook.SaveAs strExcelPath
 
' Populate spreadsheet cells with user attributes.
' Place column headers in the first row
objSheet.Cells(1, 1).Value = "Computer Name"
objSheet.Cells(1, 2).Value = "User Name"
objSheet.Cells(1, 3).Value = "Manufacturer"
objSheet.Cells(1, 4).Value = "Model"
objSheet.Cells(1, 5).Value = "Serial No"
objSheet.Cells(1, 6).Value = "Part No"
objSheet.Cells(1, 7).Value = "OS"
objSheet.Cells(1, 8).Value = "Processor"
objSheet.Cells(1, 9).Value = "Ram"
objSheet.Cells(1, 10).Value = "DiskDrive Size"
objSheet.Cells(1, 11).Value = "Graphic Card Model"
objSheet.Cells(1, 12).Value = "Graphic Card Memory"
 
 
' instantiate FSO object used for writing output files
'Delphi ToDo: Replace list and upgrade variables with native Delphi
'   file writing:
' Var
'   myFile : TextFile;
'   text   : string;
'
' begin
'   // Try to open the Test.txt file for writing to
'   AssignFile(myFile, 'Test.txt');
'   ReWrite(myFile);
'
'   // Write a couple of well known words to this file
'   WriteLn(myFile, 'Hello');
'   WriteLn(myFile, 'World');
'
'   // Close the file
'   CloseFile(myFile);
   
Set fso = CreateObject("Scripting.FileSystemObject")
 
Set List = fso.CreateTextFile("./output.txt")
' NOTE: following upgrade variable not used -- commented
'Set upgrade = fso.CreateTextFile("./upgrade.txt")
 
' Get the AD domain from the user.
'Delphi ToDo: the Delphi InputBox function is almost identical
'   http://www.delphibasics.co.uk/RTL.asp?Name=InputBox
'Hint: better application usability if you supply a default AD domain
strDomainDn = InputBox("domain" & vbCrLf & "(i.e. dc=domain,dc=com)")
 
' Exit the procedure if nothing supplied
If strDomainDn = "" Then
  WScript.Echo "Exiting!"
  WScript.Quit
End If
 
' Instantiate ADO objects used to read the AD tree
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
 
Set objCommand.ActiveConnection = objConnection
objCommand.CommandText = _
    "Select Name, Location from 'LDAP://" & strDomainDn & "' " _
        & "Where objectClass='computer'"
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
 
Set objRecordSet = objCommand.Execute
'NOTE: .MoveFirst method should not be necessary -- commented
'objRecordSet.MoveFirst
 
' Iterate through the recordset (all computers in the AD tree)
Do Until objRecordSet.EOF
      
  strComputer = objRecordSet.Fields("Name").Value
  
  ' I recomment replacing the ping statements with a check of the results of the
  ' Set objWMIService = GetObject result below
  Set objShell = CreateObject("WScript.Shell")
  strCommand = "%comspec% /c ping -n 3 -w 1000 " & strComputer & ""
  Set objExecObject = objShell.Exec(strCommand)
  
  Do While Not objExecObject.StdOut.AtEndOfStream
    strText = objExecObject.StdOut.ReadAll()
    If InStr(strText, "Reply") > 0 Then
      Set objWMIService = GetObject _
        ("winmgmts:\\" & strComputer & "\root\cimv2")
      Set ColItems = objWMIService.ExecQuery _
        ("Select * From Win32_OperatingSystem")
       
      Set colItems2 = objWMIService.ExecQuery("Select * from Win32_BIOS", , 48)
      ' list.write Err.Description
      Set colitems3 = objWMIService.ExecQuery("Select * from Win32_ComputerSystem", , 48)
      Set colitems4 = objWMIService.ExecQuery("SELECT * FROM Win32_Processor", "WQL", _
                                    wbemFlagReturnImmediately + wbemFlagForwardOnly)
      Set colItems5 = objWMIService.ExecQuery("Select * from Win32_VideoController ")
      Set colItems6 = objWMIService.ExecQuery("Select * from Win32_DiskDrive")
      Set colItems7 = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
      Set colItems8 = objWMIService.ExecQuery("Select * from Win32_SystemEnclosure")
      
      For Each objItem In ColItems  'only one row returned
        strOS = objItem.Caption
      Next
          
      For Each objItem In colItems2  'only one row returned
        strSerialno = objItem.SerialNumber
        strManu = objItem.Manufacturer
      Next
          
      For Each objItem In colItems5  'only one row returned
        strGraphicalVideoCard = objItem.Caption
        strGraphicalVideoCardMemory = objItem.AdapterRAM
      Next
          
      For Each objItem In colItems6  'only one row returned
        strHDsize = objItem.Size
      Next
          
      For Each objItem In colItems7  'only one row returned
        stOS = objItem.Caption
      Next
  
      For Each objItem In colitems3  'only one row returned
        strUserName = objItem.UserName
        strModel = objItem.Model
        strRam = objItem.TotalPhysicalMemory
        strTimeZone = (objItem.CurrentTimeZone / 60)
        strDayLightSavings = objItem.DaylightInEffect
      Next
  
      For Each objItem In colitems4  'only one row returned
        strProcessor = objItem.Name
      Next
      
      'Delphi ToDo: Place the following in a Try Catch statement with the
      '     colItems# iteration statements
      If Err.Number > 0 Then
        strErrorSystems = strComputer & ", " & strErrorSystems
      Else
        List.write "-------------------------------------------------------------" & vbCrLf & vbCrLf
        List.write "Computer Name: " & strComputer & ", " & strUserName & vbCrLf
        List.write "-------------------------------------------------------------" & vbCrLf & vbCrLf
        '#################### Comuter Name ###################################
        objSheet.Cells(cnt, 1).Value = strComputer
        '####################################################################
        List.write "Operating System: " & strOS & vbCrLf
        List.write "Current User: " & strUserName & vbCrLf
        '#################### Current User ###################################
        objSheet.Cells(cnt, 2).Value = strUserName
        '####################################################################
        List.write "::::" & vbCrLf
        List.write "Manufacturer: " & strManu & vbCrLf
        '#################### Manufacturer  ###################################
        objSheet.Cells(cnt, 3).Value = strManu
        '####################################################################
        List.write "Model: " & strModel & vbCrLf
        '#################### Model  ###################################
        objSheet.Cells(cnt, 4).Value = strModel
        '####################################################################
        List.write "Service Tag: " & DellTag & vbCrLf
        List.write "Processor type: " & strProcessor & vbCrLf
        '#################### Processor ###################################
        objSheet.Cells(cnt, 8).Value = strProcessor
        '####################################################################
        List.write "RAM: " & strRam & vbCrLf
        '#################### Ram  ###################################
        memoryX = (strRam / 1024) / 1024
        memoryX = Int(memoryX)
        memoryX = memoryX + 2
        objSheet.Cells(cnt, 9).Value = memoryX
        '########################################################################################
        List.write "GraphicalVideoCard: " & strGraphicalVideoCard & vbCrLf
        '##############################  GraphicalVideoCard ######################################
        objSheet.Cells(cnt, 11).Value = strGraphicalVideoCard
        '##############################  GraphicalVideoCard Memory ######################################
        memoryz = (strGraphicalVideoCardMemory / 1024) / 1024
        memoryz = Int(memoryz)
        objSheet.Cells(cnt, 12).Value = memoryz
        '##############################  Hard Drive Memory ######################################
        memoryT = ((strHDsize / 1024) / 1024) / 1024
        memoryT = Int(memoryT)
        objSheet.Cells(cnt, 10).Value = memoryT
        '#################### Serial Number ###################################
        objSheet.Cells(cnt, 5).Value = strSerialno
        '#################### O S ###################################
        objSheet.Cells(cnt, 7).Value = stOS
        '#################### O S ###################################
        objSheet.Cells(cnt, 6).Value = strModel
      
        List.write "Time Zone: " & strTimeZone & vbCrLf
        List.write "Daylight Savings in effect: " & strDayLightSavings & vbCrLf
        List.write "-------------------------------------------------------------" & vbCrLf & vbCrLf
        memory = (strRam / 1024) / 1024
        memory = Int(memory)
        memory = memory + 2
                     
      End If
           
      'flushes error code, if any, from the previous loop
      Err.Clear
      
    Else    'ping failed -- note unreacable computer
      UnavailableSystems = strComputer & ", " & UnavailableSystems
      objSheetU.Cells(unReached, 1).Value = strComputer
      unReached = unReached + 1
    End If
    
  Loop  'process ping output
  
  objRecordSet.MoveNext
  cnt = cnt + 1
 
  objExcel.ActiveWorkbook.Save
Loop
 
List.write "The following systems were unavailable: " & UnavailableSystems & vbCrLf
List.write " " & vbCrLf & vbCrLf
List.write "The following systems were on, but returned an error: " & strErrorSystems & vbCrLf
 
' Save the spreadsheet and close the workbook.
objExcel.ActiveWorkbook.Close
 
' Quit Excel.
objExcel.Application.Quit
 
' Log end of processing
WScript.Echo "Done!"
 
End Sub

Open in new window

0

Featured Post

Networking for the Cloud Era

Join Microsoft and Riverbed for a discussion and demonstration of enhancements to SteelConnect:
-One-click orchestration and cloud connectivity in Azure environments
-Tight integration of SD-WAN and WAN optimization capabilities
-Scalability and resiliency equal to a data center

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Programmer's Notepad is, one of the best free text editing tools available, simply because the developers appear to have second-guessed every weird problem or issue a programmer is likely to run into. One of these problems is selecting and deleti…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
The viewer will learn how to use NetBeans IDE 8.0 for Windows to connect to a MySQL database. Open Services Panel: Create a new connection using New Connection Wizard: Create a test database called eetutorial: Create a new test tabel called ee…
The viewer will learn how to use and create new code templates in NetBeans IDE 8.0 for Windows.

839 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question