VBScript to read text file and paste to existing excel spreadsheet

Posted on 2010-01-07
Last Modified: 2012-06-22
I have a VBScript that gets the installed progs on a machine and creates a tab delimited text file. I can save this file as a .xls, but I need a macro/module run on its contents. This is why I will have a template spreadsheet for the vbs to open and modify.  

So, I need to open the created .txt file, read its contents, store contents as variables, open existing spreadsheet, write data to spreadsheet, save spreadsheet as a new name, then delete original .txt file.

Example of .txt file attached. Example of .txt file manually saved as a .xls file attached.

Existing Code attached:

Option Explicit

Dim StrComputer

Dim prognym

Dim CurDir

Dim oFSO

Dim objFolder

CurDir = left(WScript.ScriptFullName,(Len(WScript.ScriptFullName))-(len(WScript.ScriptName)))

prognym = InputBox("Enter Program Location and Acronym " & vbcrlf & vbcrlf & _

		 	"Follow this Example: LOCATION_PROGRAM" & vbcrlf & vbcrlf & _

			"If you leave blank or cancel, the filename " & _

			"will append 'adhoc'.")

If prognym = "" Then prognym = "adhoc"

Set oFSO = CreateObject("Scripting.FileSystemObject")

If Not oFSO.FolderExists(CurDir&prognym) Then

Set objFolder = oFSO.CreateFolder(CurDir&prognym)

Set oFSO = nothing

End If

strComputer = "" 

If strComputer = "" Then strComputer = "."

'Wscript.Echo GetAddRemove(strComputer)

Dim sCompName : sCompName = GetProbedID(StrComputer)

Dim sFileName

sFileName = prognym & "_" &sCompName & "_" & GetDTFileName() & "_InstalledSoftware.txt"

Dim sFileNamePath

sFileNamePath = CurDir & sFileName

Dim DestDir

DestDir = CurDir&prognym&"\"

Dim s : s = GetAddRemove(strComputer)

If WriteFile(s, sFileName) Then

  'optional prompt for display

  MsgBox("Finished processing.  Results saved to " & DestDir & sFileName)

End If

Dim objFSO

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FileExists(sFileNamePath) Then

objFSO.MoveFile sFileNamepath, DestDir

Set objFSO = nothing

End If

'Need to add code here to read text file, store as variables, open existing excel spreadsheet, write data, save spreadsheet as new name, etc

Function GetAddRemove(sComp)

  Dim cnt, oReg, sBaseKey, iRC, aSubKeys

  Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE

  Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _

              sComp & "/root/default:StdRegProv")

  sBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"

  iRC = oReg.EnumKey(HKLM, sBaseKey, aSubKeys)

  Dim sKey, sValue, sTmp, sVersion, sDateValue, sYr, sMth, sDay

  For Each sKey In aSubKeys

    iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, "DisplayName", sValue)

    If iRC <> 0 Then

      oReg.GetStringValue HKLM, sBaseKey & sKey, "QuietDisplayName", sValue

    End If

    If sValue <> "" Then

      iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _

                                "DisplayVersion", sVersion)

      If sVersion <> "" Then

        sValue = sValue & vbTab & "Ver: " & sVersion


        sValue = sValue & vbTab 

      End If

      iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _

                                "InstallDate", sDateValue)

      If sDateValue <> "" Then

        sYr =  Left(sDateValue, 4)

        sMth = Mid(sDateValue, 5, 2)

        sDay = Right(sDateValue, 2)

        'some Registry entries have improper date format

        On Error Resume Next 

        sDateValue = DateSerial(sYr, sMth, sDay)

        On Error GoTo 0

        If sdateValue <> "" Then

          sValue = sValue & vbTab & "Installed: " & sDateValue

        End If

      End If

      sTmp = sTmp & sValue & vbcrlf

    cnt = cnt + 1

    End If


  sTmp = BubbleSort(sTmp)

  GetAddRemove = "INSTALLED SOFTWARE (" & cnt & ") - " & sCompName & _

                 " - " & Now() & vbcrlf & vbcrlf & sTmp 

End Function

Function BubbleSort(sTmp)

  'cheapo bubble sort

  Dim aTmp, i, j, temp

  aTmp = Split(sTmp, vbcrlf)  

  For i = UBound(aTmp) - 1 To 0 Step -1

    For j = 0 to i - 1

      If LCase(aTmp(j)) > LCase(aTmp(j+1)) Then

        temp = aTmp(j + 1)

        aTmp(j + 1) = aTmp(j)

        aTmp(j) = temp

      End if



  BubbleSort = Join(aTmp, vbcrlf)

End Function

Function GetProbedID(sComp)

  Dim objWMIService, colItems, objItem

  Set objWMIService = GetObject("winmgmts:\\" & sComp & "\root\cimv2")

  Set colItems = objWMIService.ExecQuery("Select SystemName from " & _


  For Each objItem in colItems

    GetProbedID = objItem.SystemName


End Function

Function GetDTFileName()

  dim sNow, sMth, sDay, sYr, sHr, sMin, sSec

  sNow = Now

  sMth = Right("0" & Month(sNow), 2)

  sDay = Right("0" & Day(sNow), 2)

  sYr = Right("00" & Year(sNow), 4)

  sHr = Right("0" & Hour(sNow), 2)

  sMin = Right("0" & Minute(sNow), 2)

  sSec = Right("0" & Second(sNow), 2)

  'GetDTFileName = sMth & sDay & sYr & "_" & sHr & sMin & sSec

  GetDTFileName = sYr & sMth & sDay & "_" & sHr & sMin & sSec

End Function

Function WriteFile(sData, sFileName)

  Dim fso, OutFile, bWrite

  bWrite = True

  Set fso = CreateObject("Scripting.FileSystemObject")

  On Error Resume Next

  Set OutFile = fso.OpenTextFile(sFileName, 2, True)

  'Possibly need a prompt to close the file and one recursion attempt.

  If Err = 70 Then

    Wscript.Echo "Could not write to file " & sFileName & ", results " & _

                 "not saved." & vbcrlf & vbcrlf & "This is probably " & _

                 "because the file is already open."

    bWrite = False

  ElseIf Err Then

    WScript.Echo err & vbcrlf & err.description

    bWrite = False

  End If

  On Error GoTo 0

  If bWrite Then



  End If

  Set fso = Nothing

  Set OutFile = Nothing

  WriteFile = bWrite

End Function

Open in new window

Question by:brukilla
    LVL 65

    Accepted Solution

    Hi there,

    If you change this:
    sFileName = prognym & "_" &sCompName & "_" & GetDTFileName() & "_InstalledSoftware.txt"

    to this
    sFileName = prognym & "_" &sCompName & "_" & GetDTFileName() & "_InstalledSoftware.tsv"

    Just so that it saves as a .tsv file and not .txt, Excel can open it easily.

    Then, at the end, if you place the code below, Excel will open the template, open the TSV, and copy the contents into the template, then Save As.

    You will need to update the strTemplateXLS path, and also add any Dim statements for variables that are undefined.


    strTemplateXLS = "\\server\share\Template.xls"
    strNewXLS = Left(DestDir & sFileName, Len(DestDir & sFileName) - 4) & ".xls"
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    Set objTemplate = objExcel.Workbooks.Open(strTemplateXLS, False, True)
    Set objTSV = objExcel.Workbooks.Open(sFileName, False, True)
    objTSV.Sheets(1).Cells.Copy objTemplate.Sheets(1).Range("A1")
    objTSV.Close False
    objTemplate.SaveAs strNewXLS

    Open in new window

    LVL 65

    Expert Comment

    Oh, and welcome to EE!

    Author Closing Comment

    This code was extremely helpful. It did as I wanted with minimal tweaking.

    As development goes, I have expanded further and changed some requirements, but, in the end, it will be more robust.

    I may post another question about my further development.

    Thank you so much for your time and assistance.
    LVL 65

    Expert Comment

    Thanks for the grade.

    I will have a look at your new question later today.



    Featured Post

    Top 6 Sources for Identifying Threat Actor TTPs

    Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

    Join & Write a Comment

    I met Paul Devereux (@pdevereux) today when I responded to his tweet asking “Anybody know how to automate adding files from disk to a folder in #outlook  ?”.  I replied back and told Paul that using automation, in this case scripting, to add files t…
    This script will sweep a range of IP addresses (class c only, and report to a log the version of office installed. What it does: 1.)      Creates log file in the directory the script is run from (if it doesn't already exist) 2.)      Sweep…
    Need more eyes on your posted question? Go ahead and follow the quick steps in this video to learn how to Request Attention to your question. *Log into your Experts Exchange account *Find the question you want to Request Attention for *Go to the e…
    Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

    729 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

    21 Experts available now in Live!

    Get 1:1 Help Now