常务董事与股价相对曲线

Sub 股东与股价相对曲线()
    Dim obj As AcadObject
    For Each obj In ThisDrawing.ModelSpace
        obj.Delete
    Next
    ThisDrawing.Application.Update
    Dim a() As Double, p() As Double
    f = "002106"
    On Error Resume Next
    Set oDoc = CreateObject("htmlfile")
    Set ww = CreateObject("WinHttp.WinHttpRequest.5.1")
    With CreateObject("Microsoft.XMLHTTP")
        .Open "GET", "http://stock.finance.qq.com/corp1/stk_holder_count.php?zqdm=" & f, False
        .send
        oDoc.body.innerHTML = .responsetext
        Set r = oDoc.all.tags("table")(1).Rows
        ReDim a(0 To 3 * r.Length - 7), p(0 To 3 * r.Length - 7)
        c = 10000000.00011
        d = 0.0000035
        s = 10000
        t = 0.0000000035
        For i = 1 To r.Length - 2
            a((i - 1) * 3) = r.Length - i
            p((i - 1) * 3) = r.Length - i

            a((i - 1) * 3 + 1) = r(i).Cells(2).innerText / r(i).Cells(3).innerText
            If c > a((i - 1) * 3 + 1) Then
                c = a((i - 1) * 3 + 1)
                g = r.Length - i
            End If
            If d < a((i - 1) * 3 + 1) Then d = a((i - 1) * 3 + 1)
            a((i - 1) * 3 + 2) = 0
            p((i - 1) * 3 + 2) = 0

            h = r(i).Cells(0).innerText
1:
            ww.Open "GET", "http://q.stock.sohu.com/hisHq?code=cn_" & f & "&start=" & Format(h, "yyyymmdd") & "&end=" & Format(h, "yyyymmdd") & "&stat=1&order=D&period=d&callback=a&rt=jsonp", False
            ww.send
            p((i - 1) * 3 + 1) = Split(ww.responsetext, """,""")(2)
            If p((i - 1) * 3 + 1) < 0.01 Then
                h = DateAdd("d", -1, h)
                GoTo 1
            End If
            If i < 20 And s > p((i - 1) * 3 + 1) Then
                s = p((i - 1) * 3 + 1)
                t = r.Length - i
            End If
            'Debug.Print h, p((i - 1) * 3 + 1)
        Next i
        For i = 1 To r.Length - 1
            a((i - 1) * 3 + 1) = a((i - 1) * 3 + 1) / c
            p((i - 1) * 3 + 1) = p((i - 1) * 3 + 1) / s
        Next i
    End With

    Dim splineobj As AcadSpline
    Dim starttan(0 To 2) As Double
    Dim endtan(0 To 2) As Double
    Dim point1(0 To 2) As Double
    Dim point2(0 To 2) As Double
    Dim fitpoints(0 To 8) As Double
    starttan(0) = 0: starttan(1) = 0: starttan(2) = 0
    endtan(0) = 0: endtan(1) = 0: endtan(2) = 0
    point1(0) = g: point1(1) = 1: point1(2) = 0
    point2(0) = r.Length: point2(1) = d / s: point2(2) = 0
    Set splineobj = ThisDrawing.ModelSpace.AddSpline(a, starttan, endtan)
    splineobj.color = acRed
    Set Annotation = ThisDrawing.ModelSpace.AddMText(point1, 20, Format(c, "0.000"))
    Annotation.Height = 1
    
    point1(0) = t: point1(1) = 2: point1(2) = 0
    Set splineobj = ThisDrawing.ModelSpace.AddSpline(p, starttan, endtan)
    Set Annotation = ThisDrawing.ModelSpace.AddMText(point1, 20, s)
    Annotation.Height = 1
    ThisDrawing.Application.ZoomWindow starttan, point2
    ThisDrawing.Application.Update
End Sub