combine three macros into one

[henryvii99]

Hello everyone,

I had found a way to quote real time prices from aastocks by the following user defined functions, by extracting the span class pos/neg/unc bold from the xml elements. For example, the price for 

http://www.aastocks.com/en/ltp/rtquote.aspx?symbol=00008 

is red, therefore the span class id is "neg bold".

I had created 3 scripts to extract the span class for positive price, negative price and unchanged price separately, using the following scripts:

For rising (positive) price:

[CODE]Public Function stockpos(ByVal dm As String) As String
    On Error GoTo er
    Set xlhttp = CreateObject("Msxml2.XMLHTTP")
    With xlhttp
        .Open "get", "http://www.aastocks.com/sc/ltp/rtquote.aspx?symbol=" & dm & "&time=" & Timer, False
        .send
        stockpos = Split(Split(StrConv(.responsebody, vbUnicode), "<span class=""pos bold"">")(1), "<")(0)
    End With
    Set xlhttp = Nothing
    Exit Function
er:
    stockpos = "err"
End Function

For negative (falling)) price:

Public Function stockneg(ByVal dm As String) As String
    On Error GoTo er
    Set xlhttp = CreateObject("Msxml2.XMLHTTP")
    With xlhttp
        .Open "get", "http://www.aastocks.com/sc/ltp/rtquote.aspx?symbol=" & dm & "&time=" & Timer, False
        .send
        stockneg = Split(Split(StrConv(.responsebody, vbUnicode), "<span class=""neg bold"">")(1), "<")(0)
    End With
    Set xlhttp = Nothing
    Exit Function
er:
    stockneg = "err"
End Function

And unchanged price:

Public Function stockunc(ByVal dm As String) As String
    On Error GoTo er
    Set xlhttp = CreateObject("Msxml2.XMLHTTP")
    With xlhttp
        .Open "get", "http://www.aastocks.com/sc/ltp/rtquote.aspx?symbol=" & dm & "&time=" & Timer, False
        .send
        stockunc = Split(Split(StrConv(.responsebody, vbUnicode), "<span class=""unc bold"">")(1), "<")(0)
    End With
    Set xlhttp = Nothing
    Exit Function
er:
    stockunc = "err"
End Function

The problem is I have to ask VB to search for the correct price span id. e.g. if the price is rising, the UDF for falling price and unchanged price will give me a percentage from somewhere apart from the real time quote (which is unwanted), or error message Therefore Excel spends most of the time updating unwanted data for me. And I have to set formula to extract the correct numerical result.

I think the 3 scripts can be combined into one, with the following priority:

1. If the span class id "pos bold" gives a numerical number, report;

2. If the span class id "pos bold" gives a number with % character or err, search for "neg bold" and report the numerical number;

3. If the span class id "neg bold" gives a number with % character or err, search for "unc bold" and report the numerical number.

Can anyone help? I know it may be challenging, many thanks in advance.

 

[pbornemeier]

The three samples of code appear to be identical. When I ran the code, .responsebody became a 70941 byte array and the line after the .send line errorred out each time.

However I belive this code can be adapted to do what you need metacode in red:

Public Function StockVal(ByVal dm As String) As String
    Dim sOutput As String
    Dim sExtract As String
    Dim lPosition As String
 
    On Error GoTo er
    Set xlhttp = CreateObject("Msxml2.XMLHTTP")
    With xlhttp
        .Open "get", "http://www.aastocks.com/sc/ltp/rtquote.aspx?symbol=" & dm & "&time=" & Timer, False
        .send
 
        sOutput = StrConv(.responsebody, vbUnicode)
 
        lPosition = InStr(sOutput, "pos bold")
        If lPosition > 0 Then 'pos bold was found
            sExtract = Mid(sOutput, lPosition, 100) 'get enough of a string to include the % if it exists
            If InStr(sExtract, "%") > 0 Then
                'Don't want
            Else
             'extract the numeric value from sExtract
             'stockval =
            End If
        End If
 
        lPosition = InStr(sOutput, "neg bold")
        If lPosition > 0 Then 'neg bold was found
            sExtract = Mid(sOutput, lPosition, 100) 'get enough of a string to include the % if it exists
            If InStr(sExtract, "%") > 0 Then
                'Don't want
            Else
             'extract the numeric value from sExtract
             'stockval =
            End If
        End If
 
        lPosition = InStr(sOutput, "unc bold")
        If lPosition > 0 Then 'unc bold was found
            sExtract = Mid(sOutput, lPosition, 100) 'get enough of a string to include the % if it exists
            If InStr(sExtract, "%") > 0 Then
                'Don't want
            Else
             'extract the numeric value from sExtract
             'stockval =
            End If
        End If
 
 
    End With
    Set xlhttp = Nothing
    Exit Function
er:
    StockVal = "err"
End Function

If you don't need different routines to extract the pos, neg, unc cases, then the code can be further condensed.

 

[henryvii99]

Thanks for your help!, but it doesn't seem to be working.

I can see the code is much less clumsy, but I got no values output when using the UDF. (The cells are blank, without any error message like #NAME?)

The stock code (i.e. the input for UDF) is a 5 digit number, to give a start,

00001
00002
00003
00004
00005

These are valid inputs. Any ideas?

 

[pbornemeier]

The code is not complete. Replace each instance of

'extract the numeric value from sExtract
with
Debug.Print sExtract
Stop

Then run the code and look in the immediate window and figure out if the part of the response (sExtract) is the values you can use to get the figures you want.

 

[henryvii99]

Thanks for your help! But there is still problems.

I replaced the code and ran the UDF. But it crashs when the macro tried to write the data to Excel. And breaks on the STOP line.

If the query is 00003, the UDF failed to quote the number in pos bold (19.380) and breaks on the first STOP line.

If the query is 00001, the UDF skipped the pos bold successfully as it recgonized the % character, and tried to quote the number in neg bold (120.700), but the macro breaks on the second STOP line, and failed to report the number.

 

[henryvii99]

Is it somthing wrong with the STOP

It got highlighted in yellow...

 

[pbornemeier]

The Stop command halts execution and allows you to examine the variables.

Here is code that should do what you want. The Debug.Print statements write intermediate values to the Immediate window. They can be deleted if you like.

Public Function StockVal(ByVal dm As String) As String

    Dim sOutput As String
    Dim sExtract As String
    Dim lPosition As String
    Dim sType As String
    Dim aryTypes As Variant
    
    aryTypes = Array("pos bold", "neg bold", "unc bold")
 
    On Error GoTo er
    Set xlhttp = CreateObject("Msxml2.XMLHTTP")
    With xlhttp
        .Open "get", "http://www.aastocks.com/sc/ltp/rtquote.aspx?symbol=" & dm & "&time=" & Timer, False
        .send
 
        sOutput = StrConv(.responsebody, vbUnicode)
        For lx = LBound(aryTypes) To UBound(aryTypes)
            lPosition = InStr(sOutput, aryTypes(lx))
            If lPosition > 0 Then 'search value was found
                sExtract = Mid(sOutput, lPosition, 100) 'get enough of a string to include the % if it exists
                'Debug.Print aryTypes(lx), Trim(sExtract)
                If InStr(sExtract, "%") > 0 Then
                    'Don't want
                Else
                    sType = aryTypes(lx)
                    Exit For
                End If
            End If
        Next
        
        sExtract = Mid(sExtract, InStr(sExtract, ">") + 1, 100)
        StockVal = Left(sExtract, InStr(sExtract, "<") - 1)
        'Debug.Print dm, sType, StockVal
        
    End With
    Set xlhttp = Nothing
    Exit Function
er:
    StockVal = "err"
End Function

 

[henryvii99]

That's exactly what I needed! Thanks very much!!!