I have extracted some data from a JSON Stream with one element being an array. The result of this is
"{" & vbCrLf & " ""2019-08-22"": 128.75," & vbCrLf & " ""2019-08-23"": 151.47," & vbCrLf & " ""2019-08-24"": 151.47" & vbCrLf & "}"
I am then trying to separate the 3 values and place them into a database using VB.
Tried parse, deserialize but going round in circles.
Dim uObject = Newtonsoft.Json.Linq.JObject.Parse("{" & vbCrLf & " ""2019-08-22"": 128.75," & vbCrLf & " ""2019-08-23"": 151.47," & vbCrLf & " ""2019-08-24"": 151.47" & vbCrLf & "}")
DEBUG.PRINT(uObject(1, 1)) - This fails
Trying to get the following output
Key1: 2019-08-22 Value1: 128.75
Key2: 2019-08-23 Value1: 151.47
Key3: 2019-08-24 Value1: 151.47
I did a quick test:
Dim JSON_Obj As JObject = JObject.Parse("{" & vbCrLf & " ""2019-08-22"": 128.75," & vbCrLf & " ""2019-08-23"": 151.47," & vbCrLf & " ""2019-08-24"": 151.47" & vbCrLf & "}")
For Each item In JSON_Obj
Debug.Print(String.Format("Key: {0} Value: {1}", item.key, item.value))
Next
'>Key: 2019-08-22 Value: 128.75
'>Key: 2019-08-23 Value: 151.47
'>Key: 2019-08-24 Value: 151.47
If you can't get it by key name, simply get them with array index or something, like JSON_Obj1 = JSON_Obj.Children.ToArray()(0)
With great help from CruelD; my final working code is
Dim JSON_Obj As Newtonsoft.Json.Linq.JObject = Newtonsoft.Json.Linq.JObject.Parse("{" & vbCrLf & " ""2019-08-22"": 128.75," & vbCrLf & " ""2019-08-23"": 151.47," & vbCrLf & " ""2019-08-24"": 151.47" & vbCrLf & "}")
Dim JSON_Data As List(Of JToken) = JSON_Obj.Children().ToList
For Each uItem As JProperty In JSON_Data
Debug.Print(uItem.Name.ToString & " - " & uItem.Value.ToString)
Next
This works a treat.
Related
I am attempting to write a websocket server in VB6 and have now figured out i am not sending \r\n in the response, how do i do that in VB6? vbNewLine and vbCr & vbLf does not work.
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim sData As String
Dim guid
guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
Winsock1.GetData sData
request.Text = sData
Dim aintCount()
Dim pos As Integer
Dim entry() As String
Dim entry2() As String
entry = Split(sData, vbCrLf, , vbTextCompare)
pos = 0
Do While pos < UBound(entry)
If Trim$(entry(pos)) <> "" Then
'Text3.Text = entry(pos)
entry2 = Split(entry(pos), ":", , vbTextCompare)
If entry2(0) = "Sec-WebSocket-Key" Then
Text3.Text = Trim(entry2(1) & guid)
End If
End If
pos = pos + 1
Loop
Dim Packet() As Byte
'Dim response As Byte() = System.Text.Encoding.UTF8.GetBytes("HTTP/1.1 101 Switching Protocols" & Environment.NewLine & "Connection: Upgrade" & Environment.NewLine & "Upgrade: websocket" & Environment.NewLine & "Sec-WebSocket-Accept: " & Convert.ToBase64String(System.Security.Cryptography.SHA1.Create().ComputeHash(Encoding.UTF8.GetBytes(New Regex("Sec-WebSocket-Key: (.*)").Match(data).Groups(1).Value.Trim() & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"))) & Environment.NewLine & Environment.NewLine)
crypt.EncodingMode = "base64"
crypt.HashAlgorithm = "sha1"
'Text1.Text = crypt.HashBytesENC(Bytes)
Bytes = StrConv(Trim(entry2(1) & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"), vbFromUnicode)
Text1.Text = crypt.HashBytesENC(Bytes)
'"HTTP/1.1 101 Switching Protocols" & Environment.NewLine & "Connection: Upgrade" & Environment.NewLine & "Upgrade: websocket" & Environment.NewLine & "Sec-WebSocket-Accept: "
Packet = "HTTP/1.1 101 Switching Protocols" & Crlf & "Connection: Upgrade" & Crlf & "Upgrade: WebSocket" & Crlf & "Sec-WebSocket-Accept: " & crypt.HashBytesENC(StrConv(Trim(entry2(1) & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"), vbFromUnicode)) & vbCr & vbLf
'Packet = Packet & "Upgrade: WebSocket" & vbCr & vbNewLine
'Packet = Packet & "Connection: Upgrade" & vbCr & vbNewLine
'Packet = Packet & "Sec-WebSocket-Accept: " & crypt.HashBytesENC(Bytes) & vbCr & vbNewLine
'Data = Empty
response.Text = Packet
Winsock1.SendData Packet
End Sub
I've tried to use the minimum code from the OP to provide an example. I don't know what the crypt function returns. It is very possible you'll want to include that inside the StrConv function as well. If so that will make it easier as you will not have to encrypt and concatenate the string in pieces. You will probably be able to look as response.Text to determine if you need to do the StrConv on the individual pieces or if you can do it on the whole string.
...
Dim Packet() As Byte
crypt.EncodingMode = "base64"
crypt.HashAlgorithm = "sha1"
Bytes = StrConv(Trim(entry2(1) & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"), vbFromUnicode)
Text1.Text = crypt.HashBytesENC(Bytes)
'Either
Packet = StrConv("HTTP/1.1 101 Switching Protocols" & vbCrLf & "Connection: Upgrade" & vbCrLf & "Upgrade: WebSocket" & vbCrLf & "Sec-WebSocket-Accept: ", vbFromUnicode) & crypt.HashBytesENC(StrConv(Trim(entry2(1) & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"), vbFromUnicode)) & StrConv(vbCrLf, vbFromUnicode)
'Or
Packet = StrConv("HTTP/1.1 101 Switching Protocols" & vbCrLf & "Connection: Upgrade" & vbCrLf & "Upgrade: WebSocket" & vbCrLf & "Sec-WebSocket-Accept: " & crypt.HashBytesENC(StrConv(Trim(entry2(1) & "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"), vbFromUnicode)) & vbCrLf, vbFromUnicode)
response.Text = StrConv(Packet, vbUnicode)
Winsock1.SendData Packet
...
I have been unable to find a solution to this problem, so I hope some of you may be of help. I'm trying to create an Audit Trail for an Access database to track changes. Many of my tables have composite primary keys (multiple fields combined to uniquely identify records). I obtained the following code for the Audit module:
Const cDQ As String = """"
Sub AuditTrail(frm As Form, recordid As Control)
'Track changes to data. 'recordid identifies the pk field's corresponding
'control in frm, in order to id record.
Dim ctl As Control
Dim varBefore As Variant
Dim varAfter As Variant
Dim strControlName As String
Dim strSQL As String
On Error GoTo ErrHandler
'Get changed values.
For Each ctl In frm.Controls
With ctl
'Avoid labels and other controls with Value property.
Select Case .ControlType
Case acTextBox
If .Value <> .OldValue Then
varBefore = .OldValue
varAfter = .Value
strControlName = .Name
'Build INSERT INTO statement.
strSQL = "INSERT INTO " _
& "Audit (EditDate, RecordID, SourceTable, " _
& " SourceField, BeforeValue, AfterValue) " _
& "VALUES (Now()," _
& cDQ & recordid.Value & cDQ & ", " _
& cDQ & frm.RecordSource & cDQ & ", " _
& cDQ & .Name & cDQ & ", " _
& cDQ & varBefore & cDQ & ", " _
& cDQ & varAfter & cDQ & ")"
'& cDQ & Environ("username") & cDQ & ", " _
'View evaluated statement in Immediate window.
Debug.Print strSQL
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
Case acComboBox
If .Value <> .OldValue Then
varBefore = .OldValue
varAfter = .Value
strControlName = .Name
'Build INSERT INTO statement.
strSQL = "INSERT INTO " _
& "Audit (EditDate, User, RecordID, SourceTable, " _
& " SourceField, BeforeValue, AfterValue) " _
& "VALUES (Now()," _
'& cDQ & Environ("username") & cDQ & ", " _
& cDQ & recordid.Value & cDQ & ", " _
& cDQ & frm.RecordSource & cDQ & ", " _
& cDQ & .NAME & cDQ & ", " _
& cDQ & varBefore & cDQ & ", " _
& cDQ & varAfter & cDQ & ")"
'View evaluated statement in Immediate window.
Debug.Print strSQL
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
Case acListBox
If .Value <> .OldValue Then
varBefore = .OldValue
varAfter = .Value
strControlName = .Name
'Build INSERT INTO statement.
strSQL = "INSERT INTO " _
& "Audit (EditDate, User, RecordID, SourceTable, " _
& " SourceField, BeforeValue, AfterValue) " _
& "VALUES (Now()," _
& cDQ & Environ("username") & cDQ & ", " _
& cDQ & recordid.Value & cDQ & ", " _
& cDQ & frm.RecordSource & cDQ & ", " _
& cDQ & .Name & cDQ & ", " _
& cDQ & varBefore & cDQ & ", " _
& cDQ & varAfter & cDQ & ")"
'View evaluated statement in Immediate window.
Debug.Print strSQL
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.SetWarnings True
End If
End Select
End With
Next
Set ctl = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description & vbNewLine _
& Err.Number, vbOKOnly, "Error"
End Sub
And then in the code for individual Forms I have the following code to run the module:
Option Compare Database
Private Sub Form_BeforeUpdate(Cancel As Integer)
Call AuditTrail(Me, HeaderID)
End Sub
I have found when I substitute the field name where HeaderID is for the name of a single valued primary key, the code works fine. When my table has multiple fields making up the primary key I am not sure how to format 'HeaderID' to recognize the composite of those values. I also have look up tables in some forms, but I'm unsure if that is contributing to the problem.
The error messages I'm getting:
Compile Error:
ByRef argument type mismatch
Any thoughts would be greatly appreciated!
Thank you,
Tiffany
Your AuditTrail subroutine takes as its parameters the form and the control where the edit to the data happens. So when you pass 'Me' and the name of the field (control), you're actually passing the current form and the control to the subroutine. When you change 'HeaderID' to anything other than a control name you will get the 'Type Mismatch' error because your subroutine is expecting a control and not a piece of data.
You will need to adjust your AuditTrail subroutine to take the index value that you actually want to store in your table. If your combined ID is a string made up of three values then change the parameter of the AuditTrail subroutine from 'control' to 'string'.
Two part question:
I am trying to write a VBscript where a loop runs, but there is a message box that the user can use to abort the sequence at anytime. I know that if you have a sequence with msgbox in it, the script will stop executing until an answer has been received, but can I run it as a subscript, so it doesn't interfere with the main script?
when I use the following script, I never see the msgbox
function test()
msgbox ("test")
end function
wscript.sleep 1000
msgbox "done
i was under the impression that function let you get inputs. Can this even be done with pure vbscript?
Not what I was going for but this is a work around I found. It makes a temporary msgbox that closes itself after a time. Gives the user a 5 second window to abort the sequence each loop.
set infobox = createobject("Wscript.shell")
do while E<N+1
E=E+1
if InfoBox.Popup ("Click cancel to stop sequence", _
5, "Abort Sequence?", 1) = 2 then
E=N+1
end if
loop
The Trick here is to have the first script create and start a second script. This second script will just run in the background and can then wait and kill the initial script Process... This can easily be done with a Function and can be called at the start of your script. When your main script ends, it simply kills the previously created second script. Note: the second script which is created will automatically delete itself upon being run. See the below Script for a good working example:
Dim iKillPID
'Start Kill Script At Start Of Script
iKillPID = KillPID()
For X = 10 To 0 Step -1
WScript.Echo "Closing in " & X & " Seconds"
WScript.Sleep 1000
Next
'Kill The Kill Script At End Of Script
GetObject("winmgmts:root\cimv2:Win32_Process.Handle='" & iKillPID & "'").Terminate
MsgBox "This Script is Complete"
'$$$$$$$$$$
Function KillPID()
Dim strKillScriptPath, strKillCommand, KillFile, StrFileKill, iScriptPID
Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
'Generates a Unique Temp File Name In The Same Directory As The Current Script
strKillScriptPath = objFSO.GetParentFolderName(WScript.ScriptFullName) & Chr(92) & Replace(objFSO.GetTempName, ".tmp", ".vbs")
'Command Line To New Kill Script
strKillCommand = "WScript.exe " & Chr(34) & strKillScriptPath & Chr(34)
'This part gets the Process ID of the Current Running Script
iScriptPID = GetObject("winmgmts:root\cimv2:Win32_Process.Handle='" & _
CreateObject("WScript.Shell").Exec("CMD /C ping 127.0.0.1 -n 2 > nul").ProcessID & "'").ParentProcessID
'String With Kill File Code (Script Process ID Included)
StrFileKill = _
"Const iKillProc = " & iScriptPID & vbCrLf & _
"Dim objFSO: Set objFSO = CreateObject(" & Chr(34) & "Scripting.FileSystemObject" & Chr(34) & ")" & vbCrLf & _
"objFSO.DeleteFile WScript.ScriptFullName, True" & vbCrLf & _ '<-- Deletes itself immediately upon running
"On Error Resume Next" & vbCrLf & _
"Set objKillProc = Nothing" & vbCrLf & _
"Set objKillProc = GetObject(" & Chr(34) & "winmgmts:root\cimv2:Win32_Process.Handle='" & Chr(34) & " & iKillProc & " & Chr(34) & "'" & Chr(34) & ")" & vbCrLf & _
"If objKillProc Is Nothing Then" & vbCrLf & _
" MsgBox " & Chr(34) & "The Process Is Not Running" & Chr(34) & vbCrLf & _
" WScript.Quit" & vbCrLf & _
"End If" & vbCrLf & _
"MsgBox " & Chr(34) & "Click OK To Kill The Script Process" & Chr(34) & vbCrLf & _
"Call KillProcess(iKillProc)" & vbCrLf & _
"WScript.Quit" & vbCrLf & _
"Sub KillProcess(iProcID)" & vbCrLf & _
"Dim objKillProc, strParentProc" & vbCrLf & _
"On Error Resume Next" & vbCrLf & _
"Set objKillProc = Nothing" & vbCrLf & _
"Set objKillProc = GetObject(" & Chr(34) & "winmgmts:root\cimv2:Win32_Process.Handle='" & Chr(34) & " & iProcID & " & Chr(34) & "'" & Chr(34) & ")" & vbCrLf & _
"If Err = 0 And Not objKillProc Is Nothing Then" & vbCrLf & _
" If StrComp(objKillProc.Name, " & Chr(34) & "cmd.exe" & Chr(34) & ", 1) = 0 Or _" & vbCrLf & _
" StrComp(objKillProc.Name, " & Chr(34) & "cscript.exe" & Chr(34) & ", 1) = 0 Or _" & vbCrLf & _
" StrComp(objKillProc.Name, " & Chr(34) & "wscript.exe" & Chr(34) & ", 1) = 0 Then" & vbCrLf & _
" strParentProc = objKillProc.ParentProcessID" & vbCrLf & _
" objKillProc.Terminate()" & vbCrLf & _
" Call KillProcess(strParentProc)" & vbCrLf & _
" End If" & vbCrLf & _
"End If" & vbCrLf & _
"Set strParentProc = Nothing" & vbCrLf & _
"Err.Clear" & vbCrLf & _
"End Sub"
'Write the Code To File
Set KillFile = objFSO.CreateTextFile(strKillScriptPath, True)
KillFile.WriteLine StrFileKill
KillFile.Close
Set KillFile = Nothing
WScript.Sleep 250
'Execute The Script and Return the Script Process ID So You Can Kill It When The Script Ends
KillPID = CreateObject("WScript.Shell").Exec(strKillCommand).ProcessID
End Function
'$$$$$$$$$$
Also, If you're using CScript as the Scripting Engine for your VBS, I believe you can stop the script by pressing CTRL + C in the Command Prompt Window.
Now if your super motivated you can create an HTA that does about the same thing, but present a UserForm or Custom Internet Explorer Window to click and it can also loop through and check if the process is still running and close itself when the script is finished and the process is no longer running. You can add pretty colors and everything too!
I'm attempting to use the AXE library to parse some JSON data. In trying to make sure that everything is running correctly I have created a test page. I am getting an error:
Error Type:
Microsoft JScript compilation (0x800A03EA)
Syntax error
json2.asp Line 1
I'm using the code that is in the json2.asp file to test this out:
<script language="javascript" runat="server" src="json2.asp"></script>
<%
dim TestData : set TestData = JSON.parse(join(array( _
"{", _
" ""firstname"": ""Fabio"",", _
" ""lastname"": ""Nagao"",", _
" ""alive"": true,", _
" ""age"": 27,", _
" ""nickname"": ""nagaozen"",", _
" ""fruits"": [", _
" ""banana"",", _
" ""orange"",", _
" ""apple"",", _
" ""papaya"",", _
" ""pineapple""", _
" ],", _
" ""complex"": {", _
" ""real"": 1,", _
" ""imaginary"": 2", _
" }", _
"}" _
)))
Response.write(TestData.firstname & vbNewline) ' prints Fabio
Response.write(TestData.alive & vbNewline) ' prints True
Response.write(TestData.age & vbNewline) ' prints 27
Response.write(TestData.fruits.get(0) & vbNewline) ' prints banana
Response.write(TestData.fruits.get(1) & vbNewline) ' prints orange
Response.write(TestData.complex.real & vbNewline) ' prints 1
Response.write(TestData.complex.imaginary & vbNewline) ' prints 2
' You can also enumerate object properties ...
dim key : for each key in TestData.keys()
Response.write( key & vbNewline )
next
set TestData = nothing
Where am I going wrong?
I am having a hard time inserting WONum into my sql string.
I have tried using ' and double '' around WONum. Someone also suggested # and [] around it, but nothing is working thus far.
I keep getting the following error: Incorrect syntax near '1577'
WONum value is actually WO-1577 during run time, but when DA.fill is executed I get that error. I starting to think that the dash is doing something in sql that I'm not aware of. Any help would help, because I have to do several more similar functions in my application.
Public Function GetTechTimes(ByVal WONum As String)
Dim strSQL As String = "Select customer_name, workorder_work_to_be_performed, workorder_work_performed, workorder_notes, workorder_warranty_work, workorder_open_date, workorder_status,workorder_completion_date, wo_tech_name, wo_tech_time, wo_parts_description from Customers, workorders, WorkOrder_Technicians, WorkOrder_Parts Where(customer_id = workorder_customer And wo_tech_wo_id = workorder_id And wo_parts_wo_id = workorder_id And workorder_number = " & WONum & ""
Dim DA As New SqlDataAdapter(strSQL, Conn)
Dim DS As New DataSet
DA.Fill(DS, "TechTimes")
Return DS
End Function
Use Sql-Parameters! That will avoid conversion or other issues and - more important - prevents SQL-Injection attacks.
Public Function GetTechTimes(ByVal WONum As String) As DataSet
Dim strSQL As String = "SELECT customer_name, " & Environment.NewLine & _
"workorder_work_to_be_performed," & Environment.NewLine & _
"workorder_work_performed, " & Environment.NewLine & _
"workorder_notes, " & Environment.NewLine & _
"workorder_warranty_work, " & Environment.NewLine & _
"workorder_open_date, " & Environment.NewLine & _
"workorder_status, " & Environment.NewLine & _
"workorder_completion_date," & Environment.NewLine & _
"wo_tech_name, " & Environment.NewLine & _
"wo_tech_time, " & Environment.NewLine & _
"wo_parts_description" & Environment.NewLine & _
"FROM(customers," & Environment.NewLine & _
" workorders," & Environment.NewLine & _
" workorder_technicians," & Environment.NewLine & _
" workorder_parts)" & Environment.NewLine & _
"WHERE customer_id = workorder_customer " & Environment.NewLine & _
"AND wo_tech_wo_id = workorder_id " & Environment.NewLine & _
"AND wo_parts_wo_id = workorder_id " & Environment.NewLine & _
"AND workorder_number = #workorder_number "
Using con = New SqlConnection(YourConnectionString)
Using da = New SqlDataAdapter(strSQL, con)
da.SelectCommand.Parameters.AddWithValue("#workorder_number", WONum)
Dim DS As New DataSet
da.Fill(DS)
Return DS
End Using
End Using
End Function
Note that i've also used Using-statements to ensure that all gets diposed even in case of an exception.
Bye the way, the reason for your exception: you had an opening brace here: Where(customer_id which was never closed.
As long as workorder_number is a string then putting single quote ' around the WONum is all you need.
You won't need # or square brackets.
If it's not working with the single quote then ensure you've identified/isolated your problem correctly. Remove the And workorder_number = " & WONum & "" from the end of your sql and see if it works without that. If not, then your problem isn't in the WONum, it's earlier in the string.