Solved

I need to convert a VBS to a Delphi GUI?

Posted on 2009-05-09
4
448 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

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Suggested Solutions

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…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
The viewer will learn how to synchronize PHP projects with a remote server in NetBeans IDE 8.0 for Windows.
The viewer will learn how to use and create new code templates in NetBeans IDE 8.0 for Windows.

746 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now