VBScript to read text file and paste to existing excel spreadsheet

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
      Else
        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
  Next
  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
    Next
  Next
  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 " & _
                                         "Win32_NetworkAdapter",,48)
  For Each objItem in colItems
    GetProbedID = objItem.SystemName
  Next
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
    OutFile.WriteLine(sData)
    OutFile.Close
  End If
  Set fso = Nothing
  Set OutFile = Nothing
  WriteFile = bWrite
End Function

Open in new window

adhoc-74016-4C36KH1-20100107-100.txt
adhoc-74016-4C36KH1-20100107-100.xls
brukillaAsked:
Who is Participating?
 
RobSampsonConnect With a Mentor Commented:
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.

Regards,

Rob.
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

0
 
RobSampsonCommented:
Oh, and welcome to EE!
0
 
brukillaAuthor Commented:
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.
0
 
RobSampsonCommented:
Thanks for the grade.

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

Regards,

Rob.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.