Take element from a string in VB6 - json

I have a string in this format similar to the json. Generated by the following code:
str = "{"
str &= Chr(34) & "code" & Chr(34) + ":" & Chr(34) & "0000001" & Chr(34)
str &= Chr(34) & "name" & Chr(34) + ":" & Chr(34) & "product 1" & Chr(34)
str &= Chr(34) & "value" & Chr(34) + ":" & Chr(34) & "150.00" & Chr(34)
str &= "}"
I just need to get the value after the code, name and value.
I cannot find an effective method to do this, as I will have to generalize to more terms later. How can I do this without transforming to JSON?

The code snippet you provide produces this string:
{"code":"0000001""name":"product 1""value":"150.00"}
Assuming you really are using VB6 to process this string, the following code breaks out the values:
Private Sub Test(ByVal str As String)
Dim groups As Variant
Dim values As Variant
Dim i As Integer
str = Replace(str, "{", "")
str = Replace(str, "}", "")
str = Replace(str, """""", ",")
str = Replace(str, """", "")
groups = Split(str, ",")
For i = LBound(groups) To UBound(groups)
values = Split(groups(i), ":")
Debug.Print values(1)
Next
End Sub

Something like this should help (untested):
colon% = 0
Dim completed as Boolean
while completed = false
colon% = InStr(colon% + 1, str, ":")
If colon% > 0 Then
value$ = Mid$(str, colon + 1, InStr(colon% + 2, str, Chr(34)) - colon%)
' ... do whatever with value$ here...
Else
completed = true
End If
Wend

Related

Random alphanumeric generator with unique validator returning extra digits when finding unique conflicts

I am using this code to call a random alpha numeric string. I am doing so via textbox in an Access Form.
https://www.devhut.net/2010/06/22/ms-access-vba-generate-a-random-string/
I am trying to get it to also validate it's uniqueness in a column in Access. When it fails it should run again. It however fixes that problem by doubling the digits it generates. For example to test this I am running it on a field populated with entries from 01-98. It should generate only a two digit numeric string but it returns a 4 digit.
I'm no coder btw and very unfamiliar with VB. I just rip code off the internet, and pray it works. So I might not understand things when you reply back.
Function GenRandomStr(iNoChars As Integer, _
bNumeric As Boolean, _
bUpperAlpha As Boolean, _
bLowerAlpha As Boolean)
On Error GoTo Error_Handler
Dim AllowedChars() As Variant
Dim iNoAllowedChars As Long
Dim iEleCounter As Long
Dim i As Integer
Dim iRndChar As Integer
Dim varCountOfResults As Integer
varCountOfResults = 1
While varCountOfResults > 0
'Initialize our array, otherwise it throws an error
ReDim Preserve AllowedChars(0)
AllowedChars(0) = ""
'Build our list of acceptable characters to use to generate a string from
'Numeric -> 48-57
If bNumeric = True Then
For i = 48 To 57
iEleCounter = UBound(AllowedChars)
ReDim Preserve AllowedChars(iEleCounter + 1)
AllowedChars(iEleCounter + 1) = i
Next i
End If
'Uppercase alphabet -> 65-90
If bUpperAlpha = True Then
For i = 65 To 90
ReDim Preserve AllowedChars(UBound(AllowedChars) + 1)
iEleCounter = UBound(AllowedChars)
AllowedChars(iEleCounter) = i
Next i
End If
'Lowercase alphabet -> 97-122
If bLowerAlpha = True Then
For i = 97 To 122
ReDim Preserve AllowedChars(UBound(AllowedChars) + 1)
iEleCounter = UBound(AllowedChars)
AllowedChars(iEleCounter) = i
Next i
End If
'Build the random string
iNoAllowedChars = UBound(AllowedChars)
For i = 1 To iNoChars
Randomize
iRndChar = Int((iNoAllowedChars * rnd) + 1)
GenRandomStr = GenRandomStr & Chr(AllowedChars(iRndChar))
Next i
varCountOfResults = DCount("userentry", "tamontupd", "userentry = '" & GenRandomStr & "'")
Wend
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GenRandomStr" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
You need to add GenRandomStr = "" at the top of the loop, otherwise a second/third trip through will just add to the existing string.
Refactored a little and untested because I don't have Access:
Function GenRandomStr(iNoChars As Integer, _
bNumeric As Boolean, _
bUpperAlpha As Boolean, _
bLowerAlpha As Boolean)
Dim AllowedChars As String, iEleCounter As Long
Dim i As Long, iRndChar As Long, iNoAllowedChars As Long
If bNumeric Then AllowedChars = "0123456789"
If bUpperAlpha Then AllowedChars = AllowedChars & "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If bLowerAlpha Then AllowedChars = AllowedChars & "abcdefghijklmnopqrstuvwxyz"
iNoAllowedChars = Len(AllowedChars)
Do
GenRandomStr = ""
For i = 1 To iNoChars
Randomize
iRndChar = Int((iNoAllowedChars * Rnd) + 1)
GenRandomStr = GenRandomStr & Mid(AllowedChars, iRndChar, 1)
Next i
Exit Do
Loop While DCount("userentry", "tamontupd", "userentry = '" & GenRandomStr & "'") > 0
End Function

Format DateTime to DateTime with Milliseconds

I am pulling data from database into a recordset then converting to array and then writing to a CSV.
In the database all date values are stored as timestamps in this format.
2016-05-04 08:00:00.000000
But when I write to the CSV file the timestamp does not include the milliseconds.
Anyone know how to preserve the milliseconds?
Does the data in the recordset include the milliseconds?
On Error Resume Next
Dim sPassword
Dim sUserID
Dim sDefaultLib
Dim sSystem
Dim cs
Dim rc
Dim objIEDebugWindow
sDefaultLib = *library*
sUserID = *userid*
sPassword = *password*
sSystem = *system*
cs = *connectionString*
Set con = CreateObject("ADODB.Connection")
Set data = CreateObject("ADODB.Recordset")
con.Open cs, sUserID, sPassword
rc = con.State
If (rc = 1) Then
strQuery = "SELECT * FROM Library.Table FETCH FIRST 15 ROWS ONLY FOR READ ONLY WITH UR"
data.CursorLocation = adUseClient
data.Open strQuery, con
Set filsSysObj = CreateObject("Scripting.FileSystemObject")
Dim theYear
Dim theMonth
Dim theDay
Dim mDate
mDate = Date()
theYear = DatePart("yyyy", mDate)
theMonth = Right(String(2, "0") & DatePart("m", mDate), 2)
theDate = Right(String(2, "0") & DatePart("d", mDate), 2)
mDate = theYear & theMonth & theDate
Set csvFile = filsSysObj.OpenTextFile("C:\SampleFile_" & mDate & ".csv", 8, True)
columnCount = data.Fields.Count
Set i = 0
For Each field In data.Fields
i= i + 1
If (i <> columnCount) Then
csvFile.Write Chr(34) & field.Name & Chr(34) & ","
Else
csvFile.Write Chr(34) & field.Name & Chr(34)
End If
Next
csvFile.Write vbNewLine
End If
rowCount = data.RecordCount
row = 0
Dim row
Dim column
Dim resultsArray
Dim dateArray
resultsArray = data.GetRows
debug "hi"
i = 0
Do Until i>5
MsgBox(i)
i = i + 1
'debug "in"
'Dim value
'Dim dArray()
'debug "in"
'value = Chr(34) & CStr(data.Fields(17).Value) & Chr(34) & ","
'dArray = additem(dArray, value)
'data.MoveNext
'dateArray = dArray
Loop
debug "out"
For row = 0 To UBound(resultsArray, 2)
For column = 0 To UBound(resultsArray, 1)
If row = UBound(resultsArray, 2) And column = UBound(resultsArray, 1) Then
csvFile.Write Chr(34) & resultsArray(column, row) & Chr(34)
Else
If column = 0 Then
csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
ElseIf column = 19 Then
csvFile.Write Chr(34) & FormatDateTime(resultsArray(column, row),4) & Chr(34) & ","
ElseIf column = 18 Then
csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
'ElseIf column = 17 Then
'csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
Else
csvFile.Write Chr(34) & resultsArray(column, row) & Chr(34) & ","
End If
End If
Next
csvFile.Write vbNewLine
Next
csvFile.close
'----------------------Helper Functions are below-----------------------------
Sub Debug(myText)
'Dim objIEDebugWindow must be defined globally
'Call like this "Debug variableName"
'Uncomment the next line to turn off debugging
'Exit Sub
If Not IsObject(objIEDebugWindow) Then
Set objIEDebugWindow = CreateObject("InternetExplorer.Application")
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = "<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = objIEDebugWindow.Document.Body.InnerHTML & myText & "<br>" & vbCrLf
End Sub
Function formatDate(sDate)
Dim theYear
Dim theMonth
Dim theDay
Dim formattedDate
theYear = Year(sDate)
theMonth = Right(String(2,"0") & DatePart("m", sDate),2)
theDay = Right(String(2,"0") & DatePart("d", sDate),2)
formattedDate = theYear & "-" & theMonth & "-" & theDate
formatDate = formattedDate
End Function
The only field I am having issues with is field 17 of the recordset.
It is a timestamp datatype from a DB2 database.
The issue was the format is a timestamp in DB2 database. When i pull into a recordset it loses the milliseconds. My solution was to modify the query to add an extra row that pulls in only milliseconds and then later concatenate that back to the date. Please see below. Thanks for everyones help.
if(rc = 1) then
logFile.write FormatDateTime(Now(), 3) & ": Database connection successful" & vbNewLine
logFile.write FormatDateTime(Now(), 3) &": Default Library: " & sDefaultLib & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": Signed into server as: " & sUserID & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": System: " & sSystem & vbNewLine
strQuery = "SELECT ws_date, groupcd, userid, firstname, lastname, clientcd, unitcd, categorycd, category, activity, wrktype, subwrktype, step_begin, step_end, report_indicator, report_indicator, count, event_dattim, key_date, key_time, key_milsec, microsecond(event_dattim) FROM *Library.Name* FOR READ ONLY WITH UR"
data.CursorLocation = adUseClient
data.open strQuery, con
if data.EOF then
logFile.write FormatDateTime(Now(), 3) & ": The query returned no data"
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". There was no worksteps file created. ----------------" & vbNewLine
logFile.close
end if
columnCount = data.Fields.Count
columnCount = columnCount - 1
Set filsSysObj = CreateObject("Scripting.FileSystemObject")
Set csvFile = filsSysObj.OpenTextFile("C:\VBScript\Dailys\" & fname, 8, True)
set i = 0
for each field in data.Fields
i= i + 1
if i < columnCount then
csvFile.Write chr(34) & field.name & chr(34) & ","
elseif i = columnCount then
csvFile.Write chr(34) & field.name & chr(34)
else
exit for
end if
next
csvFile.Write vbNewLine
else
logFile.write FormatDateTime(Now(), 3) & ": Database connection was unsuccessful. Database Connection Return Code: " & rc
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". ----------------" & vbNewLine
logFile.close
csvfile.close
wscript.quit
end if
dim row
dim column
dim resultsArray
resultsArray = data.GetRows
dim arrayRows
arrayRows = ubound(resultsArray, 2)
if arrayRows <> 0 then
logFile.write FormatDateTime(Now(), 3) & ": " & (arrayRows + 1) & " rows were successfully read into the array for file " & fname & vbnewline
for row = 0 to UBound(resultsArray, 2)
for column = 0 to (UBound(resultsArray, 1) - 1)
if row = Ubound(resultsArray, 2) and column = (ubound(resultsArray, 1) - 1) then
csvFile.Write chr(34) & resultsArray(column, row) & chr(34)
else
if column = 0 then
csvFile.Write chr(34) & formatDate(resultsArray(column, row)) & chr(34) & ","
elseif column = 19 then
csvFile.Write chr(34) & FormatDateTime(resultsArray(column, row),4) & chr(34) & ","
elseif column = 18 then
csvFile.Write chr(34) & formatDate(resultsArray(column, row)) & chr(34) & ","
elseif column = 17 then
Dim fDate
fDate = formatDate(resultsArray(column, row)) & " " & FormatDateTime(resultsArray(column, row),4) & ":" & second(resultsArray(column,row)) & "." & resultsArray((ubound(resultsArray, 1)), row)
csvFile.Write chr(34) & fDate & chr(34) & ","
else
csvFile.Write chr(34) & resultsArray(column, row) & chr(34) & ","
end if
end if
next
csvFile.Write vbNewLine
next
logfile.write FormatDateTime(Now(), 3) & ": " & (row) & " rows have been written to " & fname &vbNewLine
else
logFile.write FormatDateTime(Now(), 3) & ": There was no data in the query results array for file " & fname & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". ----------------" & vbNewLine
logfile.close
csvfile.close
wscript.quit
end if
csvFile.close
logfile.write "---------------- DailyWorkstepReport.vbs script successfully ended at " & Now() & "----------------" & vbNewLine
logfile.close
wscript.quit
REM ----------------------Helper Functions are below-----------------------------
Sub Debug( myText )
'Dim objIEDebugWindow must be defined globally
'Call like this "Debug variableName"
'Uncomment the next line to turn off debugging
'Exit Sub
If Not IsObject( objIEDebugWindow ) Then
Set objIEDebugWindow = CreateObject( "InternetExplorer.Application" )
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = "<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = objIEDebugWindow.Document.Body.InnerHTML & myText & "<br>" & vbCrLf
End Sub
function formatDate(sDate)
Dim theYear
Dim theMonth
Dim theDay
Dim formattedDate
theYear = Year(sDate)
theMonth = Right(String(2,"0") & DatePart("m", sDate),2)
theDay = Right(String(2,"0") & DatePart("d", sDate),2)
formattedDate = theYear & "-" & theMonth & "-" & theDate
formatDate = formattedDate
end function

How to combine two strings on a report filter?

I'm writing VBA code for an application in Access for the first time and have created two separate strings to filter a report. The first of these strFilter filters the reports based on criteria in a list box. The second strWhere has been set up to filter the report based on a date input into a pair of text boxes. Both of these string filters work perfectly when used separately.
What I want to know is if there is a way to combine the two strings easily so that the user an filter the report based on both the criteria in the list box and the date they have entered in the text boxes.
The code I have for the listbox filter when it is added to the reports filter currently looks like this:
With Reports![rptFaultRecords]
.Filter = strFilter
.FilterOn = True
I want to add the string to filter by date strWhere next to the strFilter so the report can be filtered by both date and list criteria. All the code I've entered when attempting to do this has given me a run time error 3075. Is it possible for these two strings to be combined easily and if so how can I do it?
The rest of the code I've written is below if you need to see it:
Private Sub btnAllFaultsFilter_Click()
Dim varItem As Variant
Dim strRoom As String
Dim strFilter As String
Dim strDevice As String
Dim strCat As String
Dim strStatus As String
Dim strDateField As String
Dim strWhere As String
Const strcJetDate = "\#mm\/dd\/yyyy\#"
strDateField = "[f_datereported]"
If IsDate(Me.txtStartDate) Then
strWhere = "(" & strDateField & " >= " & Format(Me.txtStartDate, strcJetDate) & ")"
End If
If IsDate(Me.txtEndDate) Then
If strWhere <> vbNullString Then
strWhere = strWhere & " AND "
End If
strWhere = strWhere & "(" & strDateField & " < " & Format(Me.txtEndDate + 1, strcJetDate) & ")"
End If
For Each varItem In Me.lstRoom.ItemsSelected
strRoom = strRoom & ",'" & Me.lstRoom.ItemData(varItem) & "'"
Next varItem
If Len(strRoom) = 0 Then
strRoom = "Like '*'"
Else
strRoom = Right(strRoom, Len(strRoom) - 1)
strRoom = "IN(" & strRoom & ")"
End If
For Each varItem In Me.lstDevice.ItemsSelected
strDevice = strDevice & ",'" & Me.lstDevice.ItemData(varItem) & "'"
Next varItem
If Len(strDevice) = 0 Then
strDevice = "Like '*'"
Else
strDevice = Right(strDevice, Len(strDevice) - 1)
strDevice = "IN(" & strDevice & ")"
End If
For Each varItem In Me.lstCategory.ItemsSelected
strCat = strCat & ",'" & Me.lstCategory.ItemData(varItem) & "'"
Next varItem
If Len(strCat) = 0 Then
strCat = "Like '*'"
Else
strCat = Right(strCat, Len(strCat) - 1)
strCat = "IN(" & strCat & ")"
End If
For Each varItem In Me.lstStatus.ItemsSelected
strStatus = strStatus & ",'" & Me.lstStatus.ItemData(varItem) & "'"
Next varItem
If Len(strStatus) = 0 Then
strStatus = "Like '*'"
Else
strStatus = Right(strStatus, Len(strStatus) - 1)
strStatus = "IN(" & strStatus & ")"
End If
strFilter = "[c_roomid] " & strRoom & " AND [f_computername] " & strDevice & " AND [f_faultcategory] " & strCat & " AND [f_faultstatus] " & strStatus
With Reports![rptFaultRecords]
'.Filter = strFilter
.Filter = strFilter
.FilterOn = True
End With
End Sub

Dates are not updating through sql code in vba

I want to update serial.Issuedate getting from form but its giving syntax error.
Please help me how can I correct this error.
My code is below:
Private Sub Command30_Click()
Set serialrs = CurrentDb.OpenRecordset("serial")
Dim Idate As Date
Dim Itodo As String
Idate = Me.IssuedDate.Value
Itodo = Me.IssuedToDO.Value
Dim issueqry As String
issueqry = "UPDATE serial " _
& " set serial.IssueToDO = '" & Itodo & "'" _
& " serial.issuedate = (#" & Format(Idate, "mm\/dd\/yyyy") & "#)" _
& " WHERE (((serial.id) Between 1 And 10)) "
DoCmd.RunSQL issueqry
MsgBox ("Issued Done")
End Sub
When you update more than one field, you must include a comma between the field expressions like this ...
SET [field name] = "foo", [another field] = 17
^
here
So try your code like this ...
issueqry = "UPDATE serial " _
& " set serial.IssueToDO = '" & Itodo & "'," _
& " serial.issuedate = #" & Format(Idate, "mm/dd/yyyy") & "#" _
& " WHERE serial.id Between 1 And 10"
Also give yourself an opportunity to inspect the string the code built ...
Debug.Print issueqry
You can view the output from Debug.Print in the Immediate window. Ctrl+g will take you there.

Excel VBA - Running SQL script multiple times with different variable value

I want to run a script in my macro multiple times by changing variable values.
Below is an example of my code that I run for one value.
The line of code I would like to change is
sScript = sScript + "where m.outletid in ('" & sOutletId & "') " & vbCrLf
Sometime I want the where clause to be
where m.outletid in ('12314')
or
where m.chainid in ('411')...
Code:
Sub Report()
Dim sScript As String
Dim sServer As String
Dim sDatabase As String
Dim sTransTable As String
Dim iVal As Integer
Dim iReturnVal As Integer
Dim SheetExists As Worksheet
Dim WK_SHEET As String
sServer = Trim(UserForm1.txtServer.Value)
sDatabase = Trim(UserForm1.txtDatabase.Value)
sTransTable = Trim(UserForm1.txtTransTable.Value)
For Each SheetExists In Worksheets
If SheetExists.Name = ("Report") Then
Application.DisplayAlerts = False
Sheets("Report").Delete
Application.DisplayAlerts = True
Exit For
End If
Next SheetExists
Worksheets.Add after:=Sheets("Sheet1")
ActiveSheet.Name = ("Report")
WK_SHEET = "Report"
Sheets(WK_SHEET).Select
sOutletId = "12314"
sScript = "Select top 10 m.CustNumber, m.Name, sum(t.Transvalue) " & vbCrLf
sScript = sScript + "from " & sTransTable & " t " & vbCrLf
sScript = sScript + "where m.outletid in ('" & sOutletId & "') " & vbCrLf
sScript = sScript + "Group by m.CustNumber, m.Name " & vbCrLf
sScript = sScript + "order by sum(t.Transvalue)Desc " & vbCrLf
iReply = MsgBox(Prompt:="Do you wish to continue with the following script for Top 10 Customers?" + sScript + "", _
Buttons:=vbYesNo, Title:="Run MACRO Top 10 Reports")
If iReply = vbNo Then
End
End If
iVal = execute_sql_select(WK_SHEET, 2, 1, sServer, sDatabase, sScript)
Sheets(WK_SHEET).Name = "Outlet" & sOutletId & "Top 10 by Spend"
Now I would like to re run the above with OutletId 12315...how can I do this? Do I use some sort of loop?
You can keep list of OutletId into Array. Then get each OutletId from Array (for loop) and execute your sql script.
Pseudu code
Array listOutid = new Array[12,13,14,15];
for(int idx = 0; idx < listOutid.Length; idx++)
{
var OutletId = listOutid[idx];
//put ur sql statement and execute here..
}