您所在位置：主题：实时看股代码（上）
一江秋水
[专家分：9680] 发布于 2019-02-25 15:49:23
实时看股票代码
年后的股市像打了鸡血针，一个劲地往上涨。我忽然心血来潮，想自己用VB编一个简单的查看股票实时数据的程序（纯粹是吃饱了饭没事干）。于是上网查询有有关资料，发现大部分都是从新浪接口取数据以大秦铁路为例的转抄文章，可就是没有如何接收数据的VB代码！整整找了一个钟头，终于找到一小段用VBA写的代码，如获至宝，就在这其中几句关键代码的基础上加以扩充。
本代码的股票实时数据取自新浪网。以钧达股份为例，输入这样的URL：http://hq.sinajs.cn/list=sz002865，最后8个字符的前2个是“深圳”的拼音缩写（如果是上海股票，拼音缩写为sh），后6个是股票代码。取回的数据是一个字符串，形式如：var hq_str_sz002865="……";（最后有个英文分号），双引号之间有31个数据，每个数据用逗号分隔。各数据的含义见Form1的代码，要说明一下：06数据和07数据原为买一价和卖一价，但它们与11数据和21数据重复了，所以我改成了涨跌和涨幅。
如果要同时获取多只股票的数据，可以在URL的股票编码后面添加别的股票编码，以英文逗号隔开，如：http://hq.sinajs.cn/list=sz002865,sh600001，这样获取的字符串，后面的股票数据紧接着前面的股票数据，以分号隔开。但本代码没有采取这种形式，因为处理取回的数据有点啰嗦。
笔者设计了三种窗体来显示股票数据，其中Form3仿照股票软件的设计（但股票的换手率、外盘、内盘等指标都没有，这是由于新浪的数据接口不输出相关数据，无法计算）。朋友们可任选一种，如果有兴趣，也可自己设计。代码中的text1用于输入股票编码。计时器用于每过预定的秒数就自动取一次数据，默认是15秒。
特别约定：在Form2的文本框中输入沪综指编码时，为了避免与深圳的股票编码混肴，请在前面加个6：6000001（7位数）。
Form3使用说明：首先在Text1中输入股票编码，每输入一个编码都要回车，编码输入完后点击保存按纽。在列表框中会即时显示出各股票的实时数据。要查看股票的图形（有分时图、日K线、周K线、月K线等四种图形），可点击该股票所在的行。要查看沪、深指数图形，可点击图形下面的沪、深标签。
Form1.frm 的代码如下（代码复制到记事本再另存为）：
VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "实时股票"
ClientHeight = 8085
ClientLeft = 150
ClientTop = 825
ClientWidth = 10815
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 8085
ScaleWidth = 10815
StartUpPosition = 3 '窗口缺省
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 15000
Left = 1680
Top = 2760
End
Begin VB.TextBox Text1
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1815
Left = 6840
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 1
Text = "Form1.frx":000C
Top = 6240
Width = 1455
End
Begin VB.CommandButton Command1
BackColor = &H00C0C0FF&
Caption = "Command1"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 8760
Style = 1 'Graphical
TabIndex = 0
Top = 7080
Width = 1695
End
Begin VB.Label Label
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 8055
Index = 1
Left = 3480
TabIndex = 5
Top = 0
Width = 3255
End
Begin VB.Label Label2
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 3015
Index = 1
Left = 6840
TabIndex = 4
Top = 3120
Width = 3855
End
Begin VB.Label Label2
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 3135
Index = 0
Left = 6840
TabIndex = 3
Top = 0
Width = 3855
End
Begin VB.Label Label
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 8055
Index = 0
Left = 120
TabIndex = 2
Top = 0
Width = 3255
End
Begin VB.Menu 转到Form2
Caption = "转到Form2"
End
Begin VB.Menu 转到Form3
Caption = "转到Form3"
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub 获取股票数据()
Dim xmlobject As Object
Dim stUrl As String, s As String
Dim arry() As String, share1() As String, share2(1) As String
Dim tem1() As String, tem2(11) As String, tem3(31) As String
Dim L As Integer, i As Integer, k As Integer
Dim Pic()
Set xmlobject = CreateObject("microsoft.xmlhttp")
s = "00指数名称|01今 开 盘|02昨 收 盘|03当前指数|04最高指数|05最低指数|06涨跌(±)|07涨幅(％)|08成 交 量|09成 交 额|10交易日期|11交易时间"
tem1 = Split(s, "|")
share2(0) = "sh000001" '沪综指
share2(1) = "sz399001" '深成指
For k = 0 To 1
stUrl = "http://hq.sinajs.cn/list=" & share2(k)
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
s = xmlobject.responsetext '获得整个数据字符串，每个数据以逗号分隔
L = Len(s) - 27
s = Mid(s, 22, L) '剔除无关字符
arry = Split(s, ",")
arry(6) = Round(arry(3) - arry(2), 2)
arry(7) = Round(arry(6) / arry(2) * 100, 2)
arry(8) = Format$(arry(8) / 100, "###,###,###,###") & "(手)"
arry(9) = Format$(arry(9) / 10000, "##,###,###,###,###") & "(万元)"
arry(10) = arry(30)
arry(11) = arry(31)
For i = 0 To 11: tem2(i) = tem1(i) & "：" & arry(i): Next
s = Join(tem2, vbCrLf)
Label2(k) = s
End If
Next
s = "00股票名称|01今 开 盘|02昨 收 盘|03当 前 价|04最 高 价|05最 低 价|06涨跌(±)|07涨幅(％)|08成 交 量|09成 交 额|10买一数量|11买 一 价|" & _
"12买二数量|13买 二 价|14买三数量|15买 三 价|16买四数量|17买 四 价|18买五数量|19买 五 价|20卖一数量|21卖 一 价|22卖二数量|23卖 二 价|" & _
"24卖三数量|25卖 三 价|26卖四数量|27卖 四 价|28卖五数量|29卖 五 价|30交易日期|31交易时间"
tem1 = Split(s, "|")
s = Text1
Do While Right(s, 2) = Chr(13) & Chr(10): s = Left(s, Len(s) - 2): Loop
share1 = Split(s, vbCrLf)
For k = 0 To UBound(share1)
s = IIf(Left(share1(k), 1) = "6", "sh", "sz") & share1(k) '股票代码，沪股前缀为sz，深股为sh
stUrl = "http://hq.sinajs.cn/list=" & s
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
s = xmlobject.responsetext
L = Len(s) - 27
s = Mid(s, 22, L)
arry = Split(s, ",")
arry(6) = Round(arry(3) - arry(2), 2)
arry(7) = Round(arry(6) / arry(2) * 100, 2)
arry(8) = Val(arry(8)) \ 100
arry(9) = Val(arry(9)) \ 10000 & "(万元)"
For i = 10 To 28 Step 2: arry(i) = Val(arry(i)) \ 100: Next
For i = 0 To 31: tem3(i) = tem1(i) & "：" & arry(i): Next
s = Join(tem3, vbCrLf)
Label(k) = s
End If
Next
Set xmlobject = Nothing
End Sub
Private Sub Command1_Click()
获取股票数据
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
获取股票数据
End Sub
Private Sub 转到Form3_Click()
Unload Me
Form3.Show
End Sub
Private Sub 转到Form2_Click()
Unload Me
Form2.Show
End Sub
Form2.frm 的代码如下（代码复制到记事本再另存为）：
VERSION 5.00
Begin VB.Form Form2
Caption = "Form2"
ClientHeight = 8280
ClientLeft = 195
ClientTop = 870
ClientWidth = 11175
LinkTopic = "Form2"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 8280
ScaleWidth = 11175
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command
BackColor = &H00FFFF80&
Caption = "月K线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Index = 3
Left = 8520
Style = 1 'Graphical
TabIndex = 8
Top = 7680
Width = 1200
End
Begin VB.CommandButton Command
BackColor = &H00FFFF80&
Caption = "周K线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Index = 2
Left = 7080
Style = 1 'Graphical
TabIndex = 7
Top = 7680
Width = 1200
End
Begin VB.CommandButton Command
BackColor = &H00FFFF80&
Caption = "日K线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Index = 1
Left = 5640
Style = 1 'Graphical
TabIndex = 6
Top = 7680
Width = 1200
End
Begin VB.CommandButton Command
BackColor = &H00FFFF80&
Caption = "分时线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Index = 0
Left = 4200
Style = 1 'Graphical
TabIndex = 5
Top = 7680
Width = 1200
End
Begin VB.Timer Timer1
Interval = 15000
Left = 3480
Top = 2280
End
Begin VB.CommandButton Command1
BackColor = &H00FFC0FF&
Caption = "保存列表"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 1320
Style = 1 'Graphical
TabIndex = 4
Top = 7680
Width = 1200
End
Begin VB.TextBox Text1
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2295
Left = 9960
MaxLength = 64
MultiLine = -1 'True
TabIndex = 3
ToolTipText = "股票名称列表"
Top = 360
Width = 1215
End
Begin VB.CommandButton Command2
BackColor = &H00C0E0FF&
Caption = "实时数据"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 2760
Style = 1 'Graphical
TabIndex = 2
Top = 7680
Width = 1200
End
Begin VB.Image Image1
BorderStyle = 1 'Fixed Single
Height = 2415
Index = 0
Left = 60
Stretch = -1 'True
Top = 2760
Width = 2775
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H00FFFFC0&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 285
Index = 0
Left = 0
TabIndex = 1
Top = 360
Width = 9840
End
Begin VB.Label Label
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 285
Left = 0
TabIndex = 0
Top = 0
Width = 11160
End
Begin VB.Menu 转到Form1
Caption = "转到Form1"
End
Begin VB.Menu 转到Form3
Caption = "转到Form3"
End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Sub 获取股票数据()
On Error GoTo 100
Dim xmlobject As Object
Dim stUrl As String, s As String, arry() As String, share() As String
Dim L As Integer, k As Integer
If Len(Text1) < 6 Then Exit Sub
Set xmlobject = CreateObject("microsoft.xmlhttp")
s = Text1
Do While Right(s, 2) = Chr(13) & Chr(10): s = Left(s, Len(s) - 2): Loop
share = Split(s, vbCrLf)
For k = 0 To UBound(share)
If share(k) = "6000001" Then
s = "sh000001" '股票编码，沪股前缀为sh，深股为sz
Else
s = IIf(Left(share(k), 1) = "6", "sh", "sz") & share(k)
End If
stUrl = "http://hq.sinajs.cn/list=" & s
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
s = xmlobject.responsetext '获得整个数据字符串，每个数据以逗号分隔
L = Len(s) - 27
s = Mid(s, 22, L) '剔除无关字符
arry = Split(s, ",")
If arry(3) Then
arry(0) = arry(0) & Space(8 - lstrlen(arry(0)))
arry(1) = Right(Space(9) & Format(arry(1), "##0.00"), 9)
arry(4) = Right(Space(9) & Format(arry(4), "##0.00"), 9)
arry(5) = Right(Space(9) & Format(arry(5), "##0.00"), 9)
arry(6) = Right(Space(10) & Format(arry(3) - arry(2), "##0.00"), 10)
arry(7) = Right(Space(10) & Format(arry(6) / arry(2) * 100, "##0.00"), 10)
arry(3) = Right(Space(9) & Format(arry(3), "##0.00"), 9)
arry(8) = Right(Space(12) & Format(arry(8) / 100, "#########0"), 12)
arry(11) = Right(Space(8) & Format(arry(11), "##0.00"), 8)
arry(21) = Right(Space(8) & Format(arry(21), "##0.00"), 8)
s = arry(0) & arry(3) & arry(6) & arry(7) & arry(8) & arry(1) & arry(4) & arry(5) & arry(11) & arry(21)
Label1(k) = s
End If
End If
Next
100
Set xmlobject = Nothing
End Sub
Private Sub Command_Click(Index As Integer)
On Error GoTo 100
Dim xmlobject As Object
Dim stUrl As String, s As String, t As String
Dim arry() As String, share() As String, tem() As Byte
Dim k As Integer
If Len(Text1) < 6 Then Exit Sub
Set xmlobject = CreateObject("microsoft.xmlhttp")
s = Text1
Do While Right(s, 2) = Chr(13) & Chr(10): s = Left(s, Len(s) - 2): Loop
share = Split(s, vbCrLf)
t = "http://image.sinajs.cn/newchart/" & Choose(Index + 1, "min", "daily", "weekly", "monthly") & "/n/"
For k = 0 To UBound(share)
If share(k) = "6000001" Then
s = "sh000001" '股票编码，沪股前缀为sh，深股为sz
Else
s = IIf(Left(share(k), 1) = "6", "sh", "sz") & share(k)
End If
stUrl = t & s & ".gif"
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
tem() = xmlobject.ResponseBody
Set Image1(k).Picture = GetPictureFromByteStream(tem())
End If
Next
100
Set xmlobject = Nothing
End Sub
Private Function GetPictureFromByteStream(picData() As Byte) As IPicture
On Error GoTo 100
Dim bCount As Long, hMem As Long, lpMem As Long
Dim IID_IPicture(15)
Dim IStream As stdole.IUnknown
bCount = UBound(picData) + 1 ' 计算数组大小
hMem = GlobalAlloc(&H2 Or &H40, bCount) '按数组大小分配内存空间
If hMem Then '若分配内存成功
lpMem = GlobalLock(hMem) '锁定内存, 返回第一块的指针
If lpMem Then
CopyMemory ByVal lpMem, picData(0), bCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, IStream) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(IStream), bCount, 0, IID_IPicture(0), GetPictureFromByteStream)
End If
End If
End If
End If
GlobalFree hMem
Exit Function
100
MsgBox Err.Number & " - " & Err.Description
End Function
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If SendMessage(Text1.hWnd, 186, 0, 0) > 8 Then
MsgBox "最多只能有8只股票"
End If
End If
End Sub
Private Sub Timer1_Timer()
获取股票数据
End Sub
Private Sub Command2_Click()
获取股票数据
Timer1.Enabled = True
End Sub
Private Sub Command1_Click()
Dim i As Integer, st As String
If Len(Text1) < 6 Then MsgBox "没有股票": Exit Sub
Open App.Path & "\股票列表.txt" For Output As #1
Print #1, Text1
Close #1
MsgBox "已保存"
End Sub
Private Sub Form_Load()
On Error GoTo 100
Dim d1 As String, d2 As String, k As Integer
Label = "股票名称 当前价 涨跌(±) 涨幅(％) 成交量(手) 开盘价 最高价 最低价 买入价 卖出价 股票编码"
For k = 1 To 7
Load Label1(k): Label1(k).Visible = True: Label1(k).Move Label1(0).Left, Label1(k - 1).Height * k + 360
Load Image1(k): Image1(k).Visible = True
If k < 4 Then
Image1(k).Move Image1(0).Width * k + Image1(0).Left, Image1(0).Top
Else
Image1(k).Move Image1(0).Width * (k - 4) + Image1(0).Left, Image1(0).Top + Image1(0).Height
End If
Next
If Len(Dir(App.Path & "\股票列表.txt")) Then
Open App.Path & "\股票列表.txt" For Input As #1
Do Until EOF(1)
Line Input #1, d1
d2 = d2 & d1 & vbCrLf
Loop
Do While Right(d2, 2) = Chr(13) & Chr(10): d2 = Left(d2, Len(d2) - 2): Loop '剔除后面多余的回车换行符
Text1 = d2
End If
100
Close
End Sub
Private Sub 转到Form1_Click()
Unload Me
Form1.Show
End Sub
Private Sub 转到Form3_Click()
Unload Me
Form3.Show
End Sub
