您所在位置：主题：实时看股代码（下）
一江秋水
[专家分：9680] 发布于 2019-02-25 16:09:37
Form3.frm 的代码如下（代码复制到记事本再另存为）：
VERSION 5.00
Begin VB.Form Form3
BackColor = &H00FF8080&
Caption = "Form3"
ClientHeight = 8550
ClientLeft = 195
ClientTop = 870
ClientWidth = 11790
LinkTopic = "Form3"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 8550
ScaleWidth = 11790
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton 计时键
BackColor = &H000000FF&
Caption = "计时"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 10800
Style = 1 'Graphical
TabIndex = 33
Top = 8130
Width = 900
End
Begin VB.Frame Frame1
BackColor = &H00000000&
Height = 3015
Left = 9180
TabIndex = 11
Top = 3180
Width = 2595
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label19"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 19
Left = 840
TabIndex = 32
Top = 2640
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label16"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 16
Left = 1680
TabIndex = 28
Top = 2370
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label15"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 15
Left = 840
TabIndex = 27
Top = 2130
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label14"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 14
Left = 1680
TabIndex = 26
Top = 2130
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label13"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 13
Left = 840
TabIndex = 25
Top = 1905
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label12"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 12
Left = 1680
TabIndex = 24
Top = 1905
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label11"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 11
Left = 840
TabIndex = 23
Top = 1665
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label10"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 10
Left = 1680
TabIndex = 22
Top = 1665
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label21"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 21
Left = 840
TabIndex = 21
Top = 1245
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label20"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 20
Left = 1680
TabIndex = 20
Top = 1245
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label23"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 23
Left = 840
TabIndex = 19
Top = 1020
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label22"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 22
Left = 1680
TabIndex = 18
Top = 1020
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label25"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 25
Left = 840
TabIndex = 17
Top = 750
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label24"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 24
Left = 1680
TabIndex = 16
Top = 750
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label27"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 27
Left = 840
TabIndex = 15
Top = 510
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label26"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 26
Left = 1680
TabIndex = 14
Top = 510
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label29"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Index = 29
Left = 840
TabIndex = 13
Top = 240
Width = 720
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "Label28"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 28
Left = 1680
TabIndex = 12
Top = 240
Width = 720
End
Begin VB.Line Line1
BorderColor = &H00FFFFFF&
BorderStyle = 3 'Dot
X1 = 0
X2 = 2520
Y1 = 1575
Y2 = 1575
End
End
Begin VB.CommandButton Command2
BackColor = &H00C0FFFF&
Caption = "保存"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 10800
Style = 1 'Graphical
TabIndex = 6
ToolTipText = "保存左边的股票列表"
Top = 7800
Width = 900
End
Begin VB.ListBox List1
Appearance = 0 'Flat
BackColor = &H00000000&
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 2910
Left = 0
TabIndex = 1
Top = 285
Width = 11775
End
Begin VB.TextBox Text1
Appearance = 0 'Flat
BackColor = &H00C0FFC0&
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 2070
Left = 9360
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 0
ToolTipText = "在这里添加股票编码，每添加一只请回车"
Top = 6360
Width = 1215
End
Begin VB.PictureBox Pic
Appearance = 0 'Flat
ForeColor = &H80000008&
Height = 4935
Left = 0
ScaleHeight = 4905
ScaleWidth = 9180
TabIndex = 9
Top = 3240
Width = 9205
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 15000
Left = 8520
Top = 1440
End
End
Begin VB.CommandButton Command1
BackColor = &H00FFFF00&
Caption = "周K线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 2
Left = 10800
Style = 1 'Graphical
TabIndex = 4
Top = 7140
Width = 900
End
Begin VB.CommandButton Command1
BackColor = &H00FFFF00&
Caption = "日K线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 1
Left = 10800
Style = 1 'Graphical
TabIndex = 3
Top = 6810
Width = 900
End
Begin VB.CommandButton Command1
BackColor = &H00FFFF00&
Caption = "分时线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 0
Left = 10800
Style = 1 'Graphical
TabIndex = 2
Top = 6480
Width = 900
End
Begin VB.CommandButton Command1
BackColor = &H00FFFF00&
Caption = "月K线"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 3
Left = 10800
Style = 1 'Graphical
TabIndex = 5
Top = 7470
Width = 900
End
Begin VB.Label Labe5
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 = 10
Top = 0
Width = 11760
End
Begin VB.Label Label3
BackColor = &H00FFFF80&
Caption = "Label3"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 1
Left = 4605
TabIndex = 8
Top = 8190
Width = 4590
End
Begin VB.Label Label3
BackColor = &H00FFFFC0&
Caption = "Label3"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 0
Left = 0
TabIndex = 7
Top = 8190
Width = 4590
End
Begin VB.Menu 转到Form1
Caption = "转到Form1"
End
Begin VB.Menu 转到Form2
Caption = "转到Form2"
End
End
Attribute VB_Name = "Form3"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
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 Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Dim xmlobject As Object
Dim share As String '股票编码
Dim iType As Integer '图形类型
Private Sub Form_Load()
Dim k As Integer, d1 As String, d2 As String
Set xmlobject = CreateObject("microsoft.xmlhttp")
For k = 1 To 9
Load Label2(k): Label2(k).Visible = True: Label2(k).Move Label2(0).Left, Label2(k - 1).Top + Label2(0).Height - (k = 5) * 150
Next
Label2(0) = "卖5": Label2(1) = "卖4": Label2(2) = "卖3": Label2(3) = "卖2": Label2(4) = "卖1"
Label2(5) = "买1": Label2(6) = "买2": Label2(7) = "买3": Label2(8) = "买4": Label2(9) = "买5"
Labe5 = "股票编码 股票名称 当前价 涨跌± 涨幅％ 成 交 量 开盘价 最高价 最低价 买入价 卖出价"
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
Close #1
Do While Right(d2, 2) = Chr(13) & Chr(10): d2 = Left(d2, Len(d2) - 2): Loop '剔除后面多余的回车换行符
Text1 = d2
If Len(Text1) > 5 Then
d1 = Left(Text1, 6)
share = IIf(Left(d1, 1) = "6", "sh", "sz") & d1 '股票编码，沪股前缀为sz，深股为sh
获取交易数据
获取图形数据
End If
End If
获取股票数据
End Sub
Private Sub 获取股票数据()
On Error GoTo 100
Dim stUrl As String, s As String, arry() As String, share() As String
Dim k As Integer
For k = 0 To 1
stUrl = "http://hq.sinajs.cn/list=" & IIf(k = 0, "sh000001", "sz399001")
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
s = xmlobject.responsetext '获得整个数据字符串，每个数据以逗号分隔
s = Mid(s, 22, Len(s) - 27) '剔除无关字符
arry = Split(s, ",")
arry(6) = Round(arry(3) - arry(2), 2): arry(6) = IIf(arry(6) < 0, "-", "+") & arry(6)
arry(9) = Format(arry(9) / 100000000, "###,###") & "(亿元)"
arry(3) = Round(arry(3), 2)
Label3(k) = arry(0) & "：" & arry(3) & " " & arry(6) & " " & arry(9)
End If
Next
If Len(Text1) < 6 Then Exit Sub
List1.Clear
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)
s = IIf(Left(share(k), 1) = "6", "sh", "sz") & share(k)
stUrl = "http://hq.sinajs.cn/list=" & s
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
s = xmlobject.responsetext
s = Mid(s, 22, Len(s) - 27)
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(8) & Format(arry(4), "##0.00"), 8)
arry(5) = Right(Space(9) & Format(arry(5), "##0.00"), 9)
arry(6) = Right(Space(8) & Format(arry(3) - arry(2), "##0.00"), 8)
arry(7) = Right(Space(8) & Format(arry(6) / arry(2) * 100, "##0.00"), 8)
arry(3) = Right(Space(8) & Format(arry(3), "##0.00"), 8)
arry(8) = Right(Space(11) & Format(arry(8) / 100, "#######0"), 11)
arry(11) = Right(Space(8) & Format(arry(11), "##0.00"), 8)
arry(21) = Right(Space(8) & Format(arry(21), "##0.00"), 8)
s = share(k) & " " & arry(0) & arry(3) & arry(6) & arry(7) & arry(8) & arry(1) & arry(4) & arry(5) & arry(11) & arry(21)
List1.AddItem s
End If
End If
Next
100
End Sub
Private Sub 获取交易数据()
On Error GoTo 100
Dim stUrl As String, s As String
Dim arry() As String, i As Integer, k As Integer
stUrl = "http://hq.sinajs.cn/list=" & share
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
s = xmlobject.responsetext
s = Mid(s, 22, Len(s) - 27)
arry = Split(s, ",")
arry(6) = arry(3) - arry(2) '涨跌
For i = 10 To 28 Step 2 '买卖量
Label1(i) = Right(Space(6) & Round(arry(i) / 100), 6)
Next
For i = 11 To 29 Step 2 '买卖价
Label1(i).ForeColor = IIf(arry(6) = 0, &HFFFFFF, IIf(arry(6) > 0, &HFF&, &HFF00&))
Label1(i) = Format(arry(i), "##0.00")
Next
arry(7) = Format(arry(6) / arry(2) * 100, "##0.00") '涨幅
arry(6) = Format(arry(6), "##0.00") '涨跌
arry(8) = Round(arry(8) / 100) '成交量
End If
100
End Sub
Private Sub 获取图形数据()
On Error GoTo 100
Dim stUrl As String, tem() As Byte
stUrl = "http://image.sinajs.cn/newchart/" & Choose(iType + 1, "min", "daily", "weekly", "monthly") & "/n/" & share & ".gif"
xmlobject.Open "GET", stUrl, False
xmlobject.SEnd
If xmlobject.ReadyState = 4 Then
tem() = xmlobject.ResponseBody
Set Pic.Picture = GetPictureFromByteStream(tem())
End If
100
End Sub
Private Function GetPictureFromByteStream(picData() As Byte) As IPicture
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
End Function
Private Sub Label3_Click(Index As Integer)
share = IIf(Index = 0, "sh000001", "sz399001") '沪综指,深成指
获取图形数据
End Sub
Private Sub List1_Click()
share = Left(List1.List(List1.ListIndex), 6)
share = IIf(Left(share, 1) = "6", "sh", "sz") & share
获取图形数据
获取交易数据
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then 获取股票数据
End Sub
Private Sub 计时键_Click()
Timer1.Enabled = Not Timer1.Enabled
End Sub
Private Sub Timer1_Timer()
Dim listLine As Integer '列表框当前行
listLine = List1.ListIndex
获取股票数据
List1.ListIndex = listLine
Text1.SetFocus
SendMessage Text1.hWnd, 177, listLine * 8, ByVal listLine * 8 + 6
SendMessage Text1.hWnd, 183, 0, 0
获取交易数据
End Sub
Private Sub Command1_Click(Index As Integer)
If Len(share) < 8 Then share = "sh000001"
iType = Index
获取图形数据
End Sub
Private Sub Command2_Click()
Dim i As Integer, st As String
If Len(Text1) < 6 Then MsgBox "没有股票": Exit Sub
Open App.Path & "\股票列表.txt" For Output As #2
Print #2, Text1
Close #2
MsgBox "已保存"
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set xmlobject = Nothing
End Sub
Private Sub 转到Form1_Click()
Unload Me
Form1.Show
End Sub
Private Sub 转到Form2_Click()
Unload Me
Form2.Show
End Sub
