VbScript: Function not getting executed fully - function

I am trying to call a function. Inside function I am reading an xml file and changing value to one of the nodes. But its exiting from function after the line sXmlFile = OpenXMLFile("\\common_automation\common_bin\" & sXmlFileName & ".xml")
The functionality inside the function when tested separately is working fine. But how I do make the control go to the entire function without exiting. Before executing the statements in function fully for the 1st call, its taking the 2nd call to the function.
x=replace_instrument_id(strIp,"newFund")
y=replace_instrument_id(strIp,"newBlock")
z=replace_instrument_id(strIp,"newSecRef")
Function replace_instrument_id(sCusip,sXmlFileName)
WScript.Echo"sCusip:" & sCusip
WScript.Echo"sXmlFileName:" & sXmlFileName
sXmlFile = OpenXMLFile("\\common_automation\common_bin\" & sXmlFileName & ".xml")
WScript.Echo "sXmlFile" & sXmlFile
strCusip = sCusip
Dim sNS : sNS = "xmlns:xs='http://www.w3.org/2001/XMLSchema' xmlns:msdata='urn:schemas-microsoft-com:xml-msdata'"
Dim oXDoc : Set oXDoc = CreateObject( "Msxml2.DOMDocument.6.0" )
Dim sXPath
if(sXmlFileName="newSecRef") Then
sXPath = "/NewDataSet/ReturningDataSet/live_ins_id"
Else
sXPath = "/NewDataSet/ReturningDataSet/ins_id"
End If
oXDoc.setProperty "SelectionLanguage", "XPath"
oXDoc.setProperty "SelectionNamespaces", sNS
oXDoc.async = False
oXDoc.loadXml sXmlFile
If 0 = oXDoc.ParseError Then
oXDoc.selectSingleNode(sXPath).text = strCusip
oXDoc.save "\common_automation\common_bin\"& sXmlFileName &".xml"
WScript.Echo oXDoc.selectSingleNode(sXPath).text
Else
WScript.Echo oXDoc.parseError.reason
End If
End Function
Function OpenXMLFile (filename)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(filename, 1)
thisline = objFile.ReadAll
objFile.Close
OpenXMLFile = thisline
End Function
The output I am getting is
sCusip:02R99BET7
sXmlFileName:newFund
sCusip:02R99BET7
sXmlFileName:newBlock
sCusip:02R99BET7
sXmlFileName:newSecRef

Related

How to read CSV files inside a loop using VBScript

I have 2 CSV files as shown below.
TEAMLIST.csv:
empid,name
54321,xyz
12345,abc
DATA.csv:
heading1,head2,head3,head4
54321-Process : GDPR_WBT,54321,Process : GDPR_WBT,TRUE
12345-Process : GDPR_WBT,12345,Process : GDPR_WBT,TRUE
54321-Fire Safety,54321,Fire Safety,FALSE
12345-Fire Safety,12345,Fire Safety,TRUE
Below is my entire VBScript code. The problem is that the inner loop is working fine but the outer loop is taking only the first record [54321,xyz] and not all records. Not able to understand why.
Option Explicit
Dim fs
Dim fs2
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs2 = CreateObject("Scripting.FileSystemObject")
Dim EMPLOYEE
Dim DATA
Set EMPLOYEE = fs.OpenTextFile("TEAMLIST.csv")
Set DATA = fs2.OpenTextFile("DATA.csv")
Dim counter, line, EMP_ARRAY
Dim counter2, line2, DATA_ARRAY
counter = 0
counter2 = 0
Do While Not EMPLOYEE.AtEndOfStream
line = EMPLOYEE.ReadLine
counter = counter + 1
If counter > 1 Then
EMP_ARRAY = Split(line, ",")
Do While Not DATA.AtEndOfStream '### DATA LOOP STARTS ###
line2 = DATA.ReadLine
counter2 = counter2 + 1
If counter2 > 1 Then
DATA_ARRAY = Split(line2, ",")
If EMP_ARRAY(0) = DATA_ARRAY(1) Then
If DATA_ARRAY(2) = "Process : GDPR_WBT" Then
If DATA_ARRAY(3) = "" Then
DATA_ARRAY(3) = "FALSE"
End If
WScript.Echo EMP_ARRAY(0) & "--" & EMP_ARRAY(1) & "--" & DATA_ARRAY(2) & "--" & DATA_ARRAY(3)
End If
If DATA_ARRAY(2) = "Fire Safety" Then
If DATA_ARRAY(3) = "" Then
DATA_ARRAY(3) = "FALSE"
End If
WScript.Echo EMP_ARRAY(0) & "--" & EMP_ARRAY(1) & "--" & DATA_ARRAY(2) & "--" & DATA_ARRAY(3)
End If
End If
End If
Loop '### DATA LOOP ENDS ###
End If
Loop
EMPLOYEE.Close
DATA.Close
Set EMPLOYEE = Nothing
Set DATA = Nothing
Set fs = Nothing
Set fs2 = Nothing
After the first iteration of the outer loop the inner loop has already read DATA.csv to the end. To "rewind" that file for each iteration of the outer loop you need to open/close it inside the outer loop.
Do Until EMPLOYEE.AtEndOfStream
'...
Set DATA = fs.OpenTextFile("DATA.csv")
Do Until DATA.AtEndOfStream
'...
Loop
DATA.Close
Loop
Alternatively (if the file is sufficiently small) read it into an array once and have the inner loop iterate over that array.
DATA = Split(fs.OpenTextFile("DATA.csv").ReadAll, vbNewLine)
Do Until EMPLOYEE.AtEndOfStream
'...
For Each line2 In DATA
'...
Next
Loop
Side-note 1: creating multiple FileSystemObject instances in your script is pointless. Create a single instance at the beginning of your script and use that instance throughout the rest of the code.
Side-note 2: Do While Not is awkward. Use Do Until instead.

How can I handle errors when copying file over Network

I'm recycling code from an old database.
For one person, located half way across the country, I believe there may be some connection issue.
Public Function BackUpBackend()
Dim Source As String
Dim Target As String
Dim retval As Integer
Source = "\\network\backend\accessfile.accdb"
Target = "\\network\backend\backup\"
Target = Target & Format(Date, "mm-dd") & "#"
Target = Target & Format(Time, "hh-mm") & ".accdb"
retval = 0
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
End Function
Is there any way to detect connection errors in this code? And if there is, can the connection be re-established or just stop the backup process all together when the issue comes up?
In VBA you can do
On Error Resume Next
which will continue past errors. This can be dangerous though, so it's often best to switch on error handling again as soon as possible with
On Error Goto 0
You can define custom handlers for errors that crop up that you want to take specific action on:
From the VBA Reference:
Sub InitializeMatrix(Var1, Var2, Var3, Var4)
On Error GoTo ErrorHandler
. . .
Exit Sub
ErrorHandler:
. . .
Resume Next
End Sub
So you might do something like: (I've not tested)
Public Function BackUpBackend()
Dim Source As String
Dim Target As String
Dim retval As Integer
Source = "\\network\backend\accessfile.accdb"
Target = "\\network\backend\backup\"
Target = Target & Format(Date, "mm-dd") & "#"
Target = Target & Format(Time, "hh-mm") & ".accdb"
retval = 0
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Goto ErrorHandler
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
On Error Goto 0
Exit Function
ErrorHandler:
MsgBox("Backup failed. If this happens often contact IT", vbExclamation )
End Function

cannot pass argument containing space to vbs function

function readFromRegistry (strRegistryKey, strDefault)
Dim WSHShell, value
On Error Resume Next
Set WSHShell = CreateObject ("WScript.Shell")
value = WSHShell.RegRead (strRegistryKey)
if err.number <> 0 then
readFromRegistry= strDefault
else
readFromRegistry=value
end if
set WSHShell = nothing
end function
function OpenWithChrome(sPage)
Dim strChrome
Dim WShellChrome
strChrome = readFromRegistry ( "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\chrome.exe\Path", "")
if (strChrome = "") then
strChrome = "chrome.exe"
else
strChrome = strChrome & "\chrome.exe"
end if
Set WShellChrome = CreateObject("WScript.Shell")
strChrome = """" & strChrome & """" & " " & sPage
WShellChrome.Run strChrome, 1, false
end function
OpenWithChrome "auto slides.html"
At last line i'm calling function OpenWithChrome with argument containing spaces. But it unable to open that file in my browser.
You just need to encode your space so Chrome can understand it. Change that line to:
OpenWithChrome "auto%20slides.html"
More information on encoding html files that use spaces can be found here:
HTML: href syntax : is it okay to have space in file name

Data from Access will not copy to Word bookmark

I have data from a query name "GrabInfoOfMostRecent" and I am using it as a source for Word to fill in a document with bookmarks. However, once I get to any non-text data, I get error 438 "Object doesn't support this property or method".
Specifically:
For "MRN"I have tried all variations of .Range.Text/Value/Value2 and cannot get the number MRN to fill into the appropriate Bookmark.
For "Diagnosis1", I get an Error13 "Type Mismatch" but I don't know why. It is defined as "Short Text" just as all previous text entries are.
Anyone with any help, I would be deeply appreciative.
Sub WordAutomation()
On Error GoTo HandleError
' Object variables for Automation stuff
' declare them like so during development
' you need to set a reference to the applications
'Dim objWord As New Word.Application
' declare them like this when development is complete
' references no longer necessary
Dim objWord As Object
' Object variables for database access
Dim db As DAO.Database
Dim rstPatientVisit As DAO.Recordset
Dim rsReportData As DAO.Recordset
Dim rsExclusions As DAO.Recordset
' Scalar variables
Dim strsql As String
Dim strFile As String
Dim conPath As String
Dim wdGoToBookmark As Integer
'find the folder where the database resides
Set db = CurrentDb
Set rsReportData = db.OpenRecordset("GrabInfoOfMostRecent")
strFile = db.Name
conPath = Mid(strFile, 1, Len(strFile) - Len(Dir(strFile)))
'Step through the records one at a time, creating a Word
'document for each.
'Do While Not rsReportData.EOF
'--create new word document
Set objWord = CreateObject("Word.Application")
objWord.Documents.Add conPath & "TunTemplate.dotx"
' Make both Word and the document are visible
objWord.Visible = True
objWord.Windows(1).Visible = True
'find bookmarks and insert values
With objWord.ActiveDocument.Bookmarks
.Item("RDFirst").Range.Text = rsReportData!RDFirstName
.Item("RDLast").Range.Text = rsReportData!RDLastName
.Item("PFirstName").Range.Text = rsReportData!PVFirstName
.Item("PLastName").Range.Text = rsReportData!PVLastName
.Item("MRN").Range.Value2 = rsReportData!MRN
.Item("RDAddress").Range.Text = rsReportData!RDAddress
.Item("PAddress").Range.Text = rsReportData!Address
.Item("RDCity").Range.Text = rsReportData!RDCity
.Item("RDCounty").Range.Text = rsReportData!RDCounty
.Item("PCity").Range.Text = rsReportData!City
.Item("PCounty").Range.Text = rsReportData!County
.Item("RDPostalCode").Range.Text = rsReportData!RDPostalCode
.Item("PPostalCode").Range.Text = rsReportData!PostalCode
.Item("Diagnosis1").Range.Text = rsReportData!Diagnosis1
.Item("Treatment1").Range.Text = rsReportData!Treatment1
.Item("Changes1").Range.Text = rsReportData!Changes1
.Item("Diagnosis2").Range.Text = rsReportData!Diagnosis2
.Item("Treatment2").Range.Text = rsReportData!Treatment2
.Item("Changes2").Range.Text = rsReportData!Changes2
.Item("Diagnosis3").Range.Text = rsReportData!Diagnosis3
.Item("Treatment3").Range.Text = rsReportData!Treatment3
.Item("Changes3").Range.Text = rsReportData!Changes3
.Item("Diagnosis4").Range.Text = rsReportData!Diagnosis4
.Item("Treatment4").Range.Text = rsReportData!Treatment4
.Item("Changes4").Range.Text = rsReportData!Changes4
.Item("Diagnosis5").Range.Text = rsReportData!Diagnosis5
.Item("Treatment5").Range.Text = rsReportData!Treatment5
.Item("Changes5").Range.Text = rsReportData!Changes5
.Item("Weight").Range.Text = rsReportData!Weight
.Item("Height").Range.Text = rsReportData!Height
.Item("BMICalc").Range.Text = rsReportData!BMICalc
.Item("Waist").Range.Text = rsReportData!Waist
.Item("BP").Range.Text = rsReportData!BP
.Item("RAcuity").Range.Text = rsReportData!REyeAcuity
.Item("LAcuity").Range.Text = rsReportData!LEyeAcuity
.Item("RRetina").Range.Text = rsReportData!RLensRetina
.Item("LRetina").Range.Text = rsReportData!LLensRetina
.Item("HbA1c").Range.Text = rsReportData!HbA1C
.Item("Creatinine").Range.Text = rsReportData!Creatinine
.Item("TChol").Range.Text = rsReportData!TChol
.Item("UrineACR").Range.Text = rsReportData!UrineACR
.Item("LDL").Range.Text = rsReportData!LDL
.Item("TSH").Range.Text = rsReportData!TSH
.Item("HDL").Range.Text = rsReportData!HDL
.Item("B12").Range.Text = rsReportData!B12
.Item("TG").Range.Text = rsReportData!TG
.Item("EGFR").Range.Text = rsReportData!EGFR
End With
'find and write exclusion data
strsql = "SELECT ReportID, Exclusion " & _
"FROM ExclusionData " & _
"WHERE ReportID=" & rsReportData!ReportID
Set rsExclusions = db.OpenRecordset(strsql)
Do While Not rsExclusions.EOF
With objWord.ActiveDocument.Bookmarks
.Item("exclusions").Range.Text = rsExclusions!Exclusion & vbCrLf
rsExclusions.MoveNext
End With
Loop
rsExclusions.Close
'Save the document and close Word
objWord.ActiveDocument.SaveAs (conPath & rsReportData!MRN & ".doc")
'objWord.Quit
'go to next record for processing
'rsReportData.MoveNext
'Loop
'Tell the user the process is done.
MsgBox "Done!" & vbCrLf & vbCrLf & _
"Look in this directory" & vbCrLf & conPath & vbCrLf & _
"for your documents."
ProcDone:
' clean up our object variables
Set objWord = Nothing
Set rsReportData = Nothing
Set rsExclusions = Nothing
Set db = Nothing
ExitHere:
Exit Sub
HandleError:
'display appropriate error message
Select Case Err.Number
Case 5151 'Word template not found
'Close stranded applications
MsgBox "Word template not found"
Case 5152 'Invalid file name
'Close stranded applications
objWord.ActiveDocument.Close SaveChanges:=False
objWord.Quit
MsgBox "This file or folder does not exist"
Case Else
MsgBox Err.Description, vbExclamation, _
"Error " & Err.Number
End Select
Resume ProcDone
End Sub
Simply with the desire to help you troubleshoot this; I offer the following.
Try converting the problem field into a string using:
.Item("Diagnosis1").Range.Text = CStr(rsReportData!Diagnosis1)
You may also want to display a dialog box with the contents of rsReportData!Diagnosis1:
MsgBox "rsReportData!Diagnosis1 is: " & rsReportData!Diagnosis1 _
, vbOkOnly + vbInformation
To convert null values into zero-length-strings, you can use the following:
.Item("Diagnosis1").Range.Text= IIf(IsNull(rsReportData!Diagnosis1), "", rsReportData!Diagnosis1)

vbscript error: Name Redifiined; Line 43: ExecuteGlobal sFileContents

Question from a amatuer scripter with informal coding background:
I've researched this on stack, msdn, random scripting websites but can't seem to glean a concrete solution. So please be advised this request for help is a last resort even if the solution is simple.
To put it simply, I'm trying to call a function that parses the last modified date of a file into an array of date formats. The filepath is the function parameter. These files are .vbs files in a client-side testing environment. This will be apparent if you look at the script.
My best guess is the "name redefined" error has something to do global variables being Dim'd in some way that's throwing the error.
Anyway, here's the calling sub:
Option Explicit
'=============================
'===Unprocessed Report========
'=============================
'*****Inputs: File Path*********************
dim strFolderPath, strFilename, strReportName, strFileExt, FullFilePath
strFolderPath = "C:\Users\C37745\Desktop\"
strFilename = "UNPROCESSED_REPORT"
strReportName = "Unprocessed"
strFileExt = ".xlsx"
'************************************
FullFilePath = strFolderPath & strFilename & strFilename & strFileExt
'************************************
Sub Include(MyFile)
Dim objFSO, oFileBeingReadIn ' define Objects
Dim sFileContents ' define Strings
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set oFileBeingReadIn = objFSO.OpenTextFile(MyFile, 1)
sFileContents = oFileBeingReadIn.ReadAll
oFileBeingReadIn.Close
ExecuteGlobal sFileContents
End Sub
Include "C:\Users\C37745\Desktop\VBStest\OtherTest\TEST_DLM.vbs"
''''''''''FOR TESTING''''''''''''''
Dim FilePath, varTEST
strFilePath = FullFilePath
varTEST = ParseDLMToArray(strFilePath)
msgbox varTESTtemp(0)
'''''''''''''''''''''''''''''''''
Here's the function I'm trying to call (or read, I guess):
Function ParseDLMtoArray(strFilePath)
Dim strFilePath, dlmDayD, dlmMonthM, dlmYearYY, dlmYearYYYY, DateFormatArray, dateDLM
Dim objFSO, File_Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set File_Object = objFSO.GetFile(strFilePath)
dateDLM = File_object.DateLastModified
dlmDayD = Day(dateDLM)
dlmMonthM = Month(dateDLM)
dlmYearYY = Right(Year(dateDLM),2)
dlmYearYYYY = Year(dateDLM)
'Adds a leading zero if a 1-digit month is detected
If(Len(Month(dlmDayD))=1) Then
dlmmonthMM ="0"& dlmMonthM
Else
dlmMonthMM = dlmMonthM
End If
'Adds a leading zero if a 1-digit day is detected
If(Len(Day(dlmDayD))=1) Then
dlmDayDD = "0" & dlmDayD
Else
dlmDayDD = dlmDayD
End If
varDLM_mmyyyy = dlmMonthMM & dlmYearYYYY
varDLM_mmddyy = dlmMonthMM & dlmDayDD & dlmYearYY
varDLM_mmddyyyy = dlmMonthMM & dlmDayDD & dlmYearYYYY
DateFormatArray = Array( _
varDLM_mmyyyy, _
varDLM_mmddyy, _
varDLM_mmddyyyy _
)
ParseDLMtoArray = DateFormatArray
End Function
Any advice is appreciated, including general feedback on best practices if you see an issue there. Thanks!
Your
Function ParseDLMtoArray(strFilePath)
Dim strFilePath
...
tries to declare/define strFilePath again. That obviously can't be allowed, because it would be impossible to decide whether that variable should contain Empty (because of the Dim) or the argument you passed.
At a first glance at your code, you can just delete the Dim strFilePath.