?
Solved

VBScript to read text file and paste to existing excel spreadsheet

Posted on 2010-01-07
4
Medium Priority
?
3,448 Views
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
      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
0
Comment
Question by:brukilla
  • 3
4 Comments
 
LVL 65

Accepted Solution

by:
RobSampson earned 2000 total points
ID: 26207381
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 26207392
Oh, and welcome to EE!
0
 

Author Closing Comment

by:brukilla
ID: 31674090
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 26279275
Thanks for the grade.

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

Regards,

Rob.
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

Hello again, all.  For those of you that have been following along, you'll know that this is my third article on this topic (though it is not Part III).  This article is sort of remedial, and probably the topic with which I should have started the s…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
Exchange organizations may use the Journaling Agent of the Transport Service to archive messages going through Exchange. However, if the Transport Service is integrated with some email content management application (such as an anti-spam), the admin…
Is your OST file inaccessible, Need to transfer OST file from one computer to another? Want to convert OST file to PST? If the answer to any of the above question is yes, then look no further. With the help of Stellar OST to PST Converter, you can e…

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