Nhờ anh em sửa lỗi dùm ạ, sao không load được dữ liệu. Thanks all.
Option Explicit
'http://priceboard.vcbs.com.vn/Priceboard/
Public Sub ShowForm()
UserForm1.Show
End Sub
Public Sub hello(ByVal selectedStocks As String, ByVal criteriaId As String, ByVal pthMktId As String)
Dim str As String, payload As String, arr
'template Payload:{"selectedStocks":"AAM,ABT","criteriaId":"-11","marketId":0,"lastSeq":0,"isReqTL":false,"isReqMK":false,"tlSymbol":"","pthMktId":""}
payload = "{""selectedStocks
""" & selectedStocks & """,""criteriaId""" & criteriaId & """,""marketId0,""lastSeq0," & _
"""isReqTLfalse,""isReqMKfalse,""tlSymbol"""",""pthMktId""" & pthMktId & """}"
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "POST", "http://priceboard.vcbs.com.vn/Priceboard/", False
.setRequestHeader "Content-Type", "application/json"
.send (payload)
str = .ResponseText
End With
If Len(pthMktId) = 0 Then
arr = tachBangGia(str)
Else
arr = tachGDTT(str)
End If
Sheet1.Range("A5").Resize(UBound(arr) + 1000, UBound(arr, 2) + 50).ClearContents
Sheet1.Range("A5").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
Private Function tachBangGia(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, arr, dArr, dicColName As Object, r As Long
Dim rowData, cellData, c As Long, colIndex As Long
Dim regec As Object, mats As Object, mat As Object
Set dicColName = CreateObject("Scripting.Dictionary")
dicColName.CompareMode = vbTextCompare
arr = Array("SB", "CL", "FL", "RE", "B3", "V3", "B2", "V2", "B1", "V1", "CH", "CP", "CV", "S1", _
"U1", "S2", "U2", "S3", "U3", "TT", "OP", "HI", "LO", "FB", "FS", "FR")
For r = 0 To UBound(arr) Step 1
dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachBangGia = dArr
lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """f["))
lEnd = InStr(lStart, stResponse, "],")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 1), "\""", "")
arr = Split(stResponse, "Id:")
Set regec = CreateObject("VBScript.RegExp")
regec.Pattern = "[A-Z][A-Z0-9]\:[^,]*(,\d+)*"
'[A-Z][A-Z0-9]\:.*?(?=,[A-Z][A-Z0-9]\
regec.Global = True
For r = LBound(arr) + 1 To UBound(arr) Step 1
Set mats = regec.Execute(arr(r))
For Each mat In mats
cellData = Split(mat, ":")
If dicColName.exists(cellData(0)) Then
colIndex = dicColName(cellData(0))
dArr(r, colIndex) = IIf(CStr(cellData(1)) = "null", "", cellData(1))
End If
Next
Next
tachBangGia = dArr
End Function
Private Function tachGDTT(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, dicColName As Object, arr, dArr, r As Long
Dim colIndex As Long, rowData, colName As String, cellData, c As Long
Set dicColName = CreateObject("Scripting.Dictionary")
arr = Array("Symbol", "Price", "MatchVol", "fake", "Time")
For r = 0 To UBound(arr) Step 1
dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachGDTT = dArr
lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """pm["))
lEnd = InStr(lStart, stResponse, "}]")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 2), """", "")
arr = Split(stResponse, "{Id:")
For r = LBound(arr) + 1 To UBound(arr) Step 1
rowData = Split(arr(r), ",")
For c = LBound(rowData) + 1 To UBound(rowData) Step 1
lStart = InStr(1, rowData(c), ":")
If lStart > 0 Then
cellData = Mid(rowData(c), lStart + 1)
colName = Left(rowData(c), lStart - 1)
If dicColName.exists(colName) Then
colIndex = dicColName(colName)
If colIndex = 2 Then
dArr(r, colIndex) = cellData / 1000
dArr(r, 4) = "=RC[-2] * RC[-1]"
Else
dArr(r, colIndex) = cellData
End If
End If
End If
Next
Next
tachGDTT = dArr
End Function
Public Function createVcbsList()
Dim arr(1 To 50, 1 To 4), curRow As Long, str As String
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "GET", "http://priceboard.vcbs.com.vn/Priceboard/", False
.send
str = .ResponseText
End With
tachGroup str, arr, "HOSE", curRow
tachGroup str, arr, "HNX", curRow
tachGroup str, arr, "UPCOM", curRow
createVcbsList = arr
End Function
Private Sub tachGroup(ByVal stResponse As String, ByRef arr, groupName As String, ByRef curRow As Long)
Dim lStart As Long, lEnd As Long, mats As Object, mat As Object
Static regec As Object, domDoc As Object
lStart = InStr(1, stResponse, "id=""" & groupName & "_Group""")
lEnd = InStr(lStart, stResponse, "</ul>")
If regec Is Nothing Then
Set regec = CreateObject("VBScript.RegExp")
regec.Pattern = "onclick\=\""selectTab\(([^\)]+)[\s\S]+?(<p>[\s\S]+?</p>)[\s\S]+?(value\=\""([\s\S]+?))?</li>"
regec.IgnoreCase = True
regec.Global = True
Set domDoc = CreateObject("Msxml2.DOMDocument")
End If
Set mats = regec.Execute(Mid(stResponse, lStart, lEnd - lStart + 5))
For Each mat In mats
curRow = curRow + 1
arr(curRow, 1) = groupName
domDoc.LoadXML mat.submatches(1)
arr(curRow, 2) = domDoc.Text
arr(curRow, 3) = mat.submatches(0)
If Len(mat.submatches(3)) > 0 Then
arr(curRow, 4) = Left(mat.submatches(3), InStr(1, mat.submatches(3), """") - 1)
End If
Next
End Sub
Option Explicit
'http://priceboard.vcbs.com.vn/Priceboard/
Public Sub ShowForm()
UserForm1.Show
End Sub
Public Sub hello(ByVal selectedStocks As String, ByVal criteriaId As String, ByVal pthMktId As String)
Dim str As String, payload As String, arr
'template Payload:{"selectedStocks":"AAM,ABT","criteriaId":"-11","marketId":0,"lastSeq":0,"isReqTL":false,"isReqMK":false,"tlSymbol":"","pthMktId":""}
payload = "{""selectedStocks
""" & selectedStocks & """,""criteriaId""" & criteriaId & """,""marketId0,""lastSeq0," & _"""isReqTL
false,""isReqMKfalse,""tlSymbol"""",""pthMktId""" & pthMktId & """}"With CreateObject("MSXML2.ServerXMLHTTP")
.Open "POST", "http://priceboard.vcbs.com.vn/Priceboard/", False
.setRequestHeader "Content-Type", "application/json"
.send (payload)
str = .ResponseText
End With
If Len(pthMktId) = 0 Then
arr = tachBangGia(str)
Else
arr = tachGDTT(str)
End If
Sheet1.Range("A5").Resize(UBound(arr) + 1000, UBound(arr, 2) + 50).ClearContents
Sheet1.Range("A5").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
Private Function tachBangGia(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, arr, dArr, dicColName As Object, r As Long
Dim rowData, cellData, c As Long, colIndex As Long
Dim regec As Object, mats As Object, mat As Object
Set dicColName = CreateObject("Scripting.Dictionary")
dicColName.CompareMode = vbTextCompare
arr = Array("SB", "CL", "FL", "RE", "B3", "V3", "B2", "V2", "B1", "V1", "CH", "CP", "CV", "S1", _
"U1", "S2", "U2", "S3", "U3", "TT", "OP", "HI", "LO", "FB", "FS", "FR")
For r = 0 To UBound(arr) Step 1
dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachBangGia = dArr
lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """f
["))lEnd = InStr(lStart, stResponse, "],")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 1), "\""", "")
arr = Split(stResponse, "Id:")
Set regec = CreateObject("VBScript.RegExp")
regec.Pattern = "[A-Z][A-Z0-9]\:[^,]*(,\d+)*"
'[A-Z][A-Z0-9]\:.*?(?=,[A-Z][A-Z0-9]\
regec.Global = True
For r = LBound(arr) + 1 To UBound(arr) Step 1
Set mats = regec.Execute(arr(r))
For Each mat In mats
cellData = Split(mat, ":")
If dicColName.exists(cellData(0)) Then
colIndex = dicColName(cellData(0))
dArr(r, colIndex) = IIf(CStr(cellData(1)) = "null", "", cellData(1))
End If
Next
Next
tachBangGia = dArr
End Function
Private Function tachGDTT(ByVal stResponse As String)
Dim lStart As Long, lEnd As Long, dicColName As Object, arr, dArr, r As Long
Dim colIndex As Long, rowData, colName As String, cellData, c As Long
Set dicColName = CreateObject("Scripting.Dictionary")
arr = Array("Symbol", "Price", "MatchVol", "fake", "Time")
For r = 0 To UBound(arr) Step 1
dicColName(arr(r)) = r + 1
Next
ReDim dArr(1 To 1000, 1 To dicColName.Count)
tachGDTT = dArr
lStart = WorksheetFunction.Max(1, InStr(1, stResponse, """pm
["))lEnd = InStr(lStart, stResponse, "}]")
If lStart < 2 Or lEnd < 2 Then Exit Function
stResponse = Replace(Mid(stResponse, lStart, lEnd - lStart + 2), """", "")
arr = Split(stResponse, "{Id:")
For r = LBound(arr) + 1 To UBound(arr) Step 1
rowData = Split(arr(r), ",")
For c = LBound(rowData) + 1 To UBound(rowData) Step 1
lStart = InStr(1, rowData(c), ":")
If lStart > 0 Then
cellData = Mid(rowData(c), lStart + 1)
colName = Left(rowData(c), lStart - 1)
If dicColName.exists(colName) Then
colIndex = dicColName(colName)
If colIndex = 2 Then
dArr(r, colIndex) = cellData / 1000
dArr(r, 4) = "=RC[-2] * RC[-1]"
Else
dArr(r, colIndex) = cellData
End If
End If
End If
Next
Next
tachGDTT = dArr
End Function
Public Function createVcbsList()
Dim arr(1 To 50, 1 To 4), curRow As Long, str As String
With CreateObject("MSXML2.ServerXMLHTTP")
.Open "GET", "http://priceboard.vcbs.com.vn/Priceboard/", False
.send
str = .ResponseText
End With
tachGroup str, arr, "HOSE", curRow
tachGroup str, arr, "HNX", curRow
tachGroup str, arr, "UPCOM", curRow
createVcbsList = arr
End Function
Private Sub tachGroup(ByVal stResponse As String, ByRef arr, groupName As String, ByRef curRow As Long)
Dim lStart As Long, lEnd As Long, mats As Object, mat As Object
Static regec As Object, domDoc As Object
lStart = InStr(1, stResponse, "id=""" & groupName & "_Group""")
lEnd = InStr(lStart, stResponse, "</ul>")
If regec Is Nothing Then
Set regec = CreateObject("VBScript.RegExp")
regec.Pattern = "onclick\=\""selectTab\(([^\)]+)[\s\S]+?(<p>[\s\S]+?</p>)[\s\S]+?(value\=\""([\s\S]+?))?</li>"
regec.IgnoreCase = True
regec.Global = True
Set domDoc = CreateObject("Msxml2.DOMDocument")
End If
Set mats = regec.Execute(Mid(stResponse, lStart, lEnd - lStart + 5))
For Each mat In mats
curRow = curRow + 1
arr(curRow, 1) = groupName
domDoc.LoadXML mat.submatches(1)
arr(curRow, 2) = domDoc.Text
arr(curRow, 3) = mat.submatches(0)
If Len(mat.submatches(3)) > 0 Then
arr(curRow, 4) = Left(mat.submatches(3), InStr(1, mat.submatches(3), """") - 1)
End If
Next
End Sub
