[VBA][Excel] ดึงราคาทองคำจากสมาคมค้าทองคำ มาแสดงผลใน Excel พร้อม JSON Parser

ThaiGoldPrice.vba

'-------------------------------------------------------------------
' VBA JSON Parser
'-------------------------------------------------------------------
Option Explicit
Public dic
Private p&, token

Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function

Private Function ParseObj(key$)
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If
                
            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function

Private Function ParseArr(key$)
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Private Function Tokenize(s$)
    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
    Tokenize = RExtract(s, Pattern, True)
End Function
Private Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
  Dim c&, m, n, v
  With CreateObject("vbscript.regexp")
    .Global = bGlobal
    .MultiLine = False
    .IgnoreCase = True
    .Pattern = Pattern
    If .Test(s) Then
      Set m = .Execute(s)
      ReDim v(1 To m.Count)
      For Each n In m
        c = c + 1
        v(c) = n.Value
        If bGroup1Bias Then If Len(n.submatches(0)) Or n.Value = """""" Then v(c) = n.submatches(0)
      Next
    End If
  End With
  RExtract = v
End Function
Private Function ArrayID$(e)
    ArrayID = "(" & e & ")"
End Function

Private Function ReducePath$(key$)
    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key
End Function

Function ListPaths(dic)
    Dim s$, v
    For Each v In dic
        s = s & v & " --> " & dic(v) & vbLf
    Next
    Debug.Print s
End Function
Private Function GetFilteredValues(dic, match)
    Dim c&, i&, v, w
    v = dic.Keys
    ReDim w(1 To dic.Count)
    For i = 0 To UBound(v)
        If v(i) Like match Then
            c = c + 1
            w(c) = dic(v(i))
        End If
    Next
    ReDim Preserve w(1 To c)
    GetFilteredValues = w
End Function
Private Function GetFilteredTable(dic, cols)
    Dim c&, i&, j&, v, w, z
    v = dic.Keys
    z = GetFilteredValues(dic, cols(0))
    ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
    For j = 1 To UBound(cols) + 1
         z = GetFilteredValues(dic, cols(j - 1))
         For i = 1 To UBound(z)
            w(i, j) = z(i)
         Next
    Next
    GetFilteredTable = w
End Function
Private Function OpenTextFile$(f)
    With CreateObject("ADODB.Stream")
        .Charset = "utf-8"
        .Open
        .LoadFromFile f
        OpenTextFile = .ReadText
    End With
End Function

Function ThaiGold(Optional BahtWg As Double = 1, Optional ODisp As String = "sell")
'สำหรับใช้ดึงราคาทองในประเทศไทย ที่ประกาศโดยสมาคมค้าทองคำ
'http://www.thaigold.info/RealTimeDataV2/gtdata_.txt
'Odisp can be use: sell, buy, all

Dim json As Object
Dim sURL As String
Dim Reslt, resp$

sURL = "https://www.thaigold.info/RealTimeDataV2/gtdata_.txt"
resp = WorksheetFunction.WebService(sURL)
Set json = ParseJSON(resp)
'Debug.Print ListPaths(dic)
Select Case ODisp
    Case "sell"
        'bar
        Reslt = dic("obj(4).ask") * BahtWg
    Case "buy"
        Reslt = dic("obj(4).bid") * BahtWg
    Case "all"
        Reslt = Array("ราคาซื้อ:", dic("obj(4).bid") * BahtWg, "ราคาขาย:", dic("obj(4).ask") * BahtWg, "เปลี่ยนแปลง:", dic("obj(4).diff"), "ทองรูปพรรณ", dic("obj(4).ask") + 800, "GoldSpot", dic("obj(1).bid"), "เปลี่ยนแปลง", dic("obj(1).diff"), "ค่าเงินบาท", dic("obj(3).bid"), "เปลี่ยนแปลง", dic("obj(3).diff"), "ปรับปรุง", dic("obj(0).ask"))
    Case "allv"
        Reslt = Array("ราคาซื้อ:", dic("obj(4).bid") * BahtWg, "ราคาขาย:", dic("obj(4).ask") * BahtWg, "เปลี่ยนแปลง:", dic("obj(4).diff"), "ทองรูปพรรณ", dic("obj(4).ask") + 800, "GoldSpot", dic("obj(1).bid"), "เปลี่ยนแปลง", dic("obj(1).diff"), "ค่าเงินบาท", dic("obj(3).bid"), "เปลี่ยนแปลง", dic("obj(3).diff"), "ปรับปรุง", dic("obj(0).ask"))
        Reslt = Application.WorksheetFunction.Transpose(Reslt)
End Select

ThaiGold = Reslt

End Function