form1.frm

金融机构电子显示屏幕理财信息批量更新

Dim FundId As String
Dim SQLSTRING As String
Dim BondIndex As String
Dim NewVal, LastVal, DZF, DINC, AllVal As Double
cnNew.Execute "delete from fund"
Set XML_Doc = New DOMDocument


XML_Doc.Load GetINI("设置项目", "外接非货币数据路径", App.Path & "\setting.ini")
If XML_Doc.documentElement Is Nothing Then
MsgBox "外界非货币基金数据不存在，请核对路径", vbCritical, "提示"

Exit Sub
End If


Set XML_Root = XML_Doc.documentElement
Set XML_NodeList = XML_Root.selectNodes("Table1")
For Each XML_Node In XML_NodeList
'Debug.Print XML_Node.selectSingleNode("NEWNET").Text & "--" & XML_Node.selectSingleNode("lastNet").Text
FundId = Left(XML_Node.selectSingleNode("JYDM").Text, 6)
If XML_Node.selectSingleNode("NEWNET") Is Nothing Then NewVal = 0 Else NewVal = XML_Node.selectSingleNode("NEWNET").Text
If XML_Node.selectSingleNode("lastNet") Is Nothing Then LastVal = 0 Else LastVal = XML_Node.selectSingleNode("lastNet").Text
If XML_Node.selectSingleNode("DZF") Is Nothing Then DZF = 0 Else DZF = XML_Node.selectSingleNode("DZF").Text
If XML_Node.selectSingleNode("DINC") Is Nothing Then DINC = 0 Else DINC = Left(XML_Node.selectSingleNode("DINC").Text, 6) / 100
If XML_Node.selectSingleNode("newTNet") Is Nothing Then AllVal = 0 Else AllVal = XML_Node.selectSingleNode("newTNet").Text

If XML_Node.selectSingleNode("newTNet") Is Nothing Then
  'If NewVal = 0 Then
  'If NewVal = 1 Then BondIndex = "1"
  GoTo Next_spot:
Else
BondIndex = "0"
End If


 SQLSTRING = "insert into Fund([FundID],[FundVal],[FundLastVal],[FundChange],[ChangeRate],[FundAllVal],[FundBond]) values('" & FundId & "'," & NewVal & "," & LastVal & "," & DZF & "," & DINC & "," & AllVal & ",'" & BondIndex & "')"
cnNew.Execute SQLSTRING
Next_spot: Next


XML_Doc.Load GetINI("设置项目", "外接货币数据路径", App.Path & "\setting.ini")
If XML_Doc.documentElement Is Nothing Then
MsgBox "外界货币基金数据不存在，请核对路径", vbCritical, "提示"

Exit Sub
End If


Set XML_Root = XML_Doc.documentElement
Set XML_NodeList = XML_Root.selectNodes("Table1")
For Each XML_Node In XML_NodeList
'Debug.Print XML_Node.selectSingleNode("NEWNET").Text & "--" & XML_Node.selectSingleNode("lastNet").Text
FundId = Left(XML_Node.selectSingleNode("JYDM").Text, 6)
If XML_Node.selectSingleNode("DWSY") Is Nothing Then NewVal = 0 Else NewVal = XML_Node.selectSingleNode("DWSY").Text
If XML_Node.selectSingleNode("NSYL") Is Nothing Then DINC = 0 Else DINC = XML_Node.selectSingleNode("NSYL").Text / 100
'If XML_Node.selectSingleNode("DZF") Is Nothing Then DZF = 0 Else DZF = XML_Node.selectSingleNode("DZF").Text
'If XML_Node.selectSingleNode("DINC") Is Nothing Then DINC = 0 Else DINC = Left(XML_Node.selectSingleNode("DINC").Text, 6) / 100
'If XML_Node.selectSingleNode("newTNet") Is Nothing Then AllVal = 0 Else AllVal = XML_Node.selectSingleNode("newTNet").Text


BondIndex = "1"



 SQLSTRING = "insert into Fund([FundID],[FundVal],[ChangeRate],[FundBond]) values('" & FundId & "'," & NewVal & "," & DINC & ",'" & BondIndex & "')"
cnNew.Execute SQLSTRING
 Next
MsgBox "已经成功获得数据", vbInformation, "提示"

End Sub




Private Sub Command2_Click()


On Error GoTo Err_1
Dim Exist_sheet As Boolean
Dim cnExcel As New ADODB.Connection
Dim rstSchema     As ADODB.Recordset
Dim tmp As String
Cdl1.InitDir = "c:\"
Cdl1.Filter = "Excel (*.xls)|*.xls"
Label1.Caption = ""
Cdl1.ShowOpen
Label1.Caption = Cdl1.FileName
Combo3.Clear
If Label1.Caption = "" Then
MsgBox "没有选择文件", vbCritical, "提示"
Exit Sub
End If

    cnExcel.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Label1.Caption & ";" & _
"Extended Properties=""Excel 8.0;"""
  Set rstSchema = cnExcel.OpenSchema(adSchemaTables)
     Do Until rstSchema.EOF
     tmp = Right(rstSchema!TABLE_NAME, 1)
     If tmp = "$" Then
     tmp = Left$(rstSchema!TABLE_NAME, Len(rstSchema!TABLE_NAME) - 1)
     Else
     tmp = rstSchema!TABLE_NAME
     End If

     
Combo3.AddItem tmp
'& vbCr & _
 ' '"Table   type:   " & rstSchema!TABLE_TYPE & vbCr
 rstSchema.MoveNext
  Loop
  rstSchema.Close
  Set rstSchema = Nothing
  
cnExcel.Close
Set cnExcel = Nothing
Combo3.Text = "请选择Excel表"
Combo3.Enabled = True
ExcelName = Cdl1.FileName
Exit Sub
Err_1: MsgBox "不可预计错误，检查文件并重新启动计算机，再次运行", vbCritical, "提示"



End Sub

Private Sub Command3_Click()

On Error GoTo Err_Update
Dim ExcelCon As Connection
Dim ExcelRes As Recordset
Dim SQLSTRING As String

Set ExcelCon = New ADODB.Connection

ExcelCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=;Extended properties=Excel 5.0;Data Source=" & ExcelName
Select Case DateUpflag
Case 0
SQLSTRING = GetINI("SQL", "基金", App.Path & "\setting.ini")
Next_Return0: Set ExcelRes = ExcelCon.Execute(SQLSTRING)

'Next_Return: Set ExcelRes = ExcelCon.Execute("select [基金代码],[单位净值],[累计净值],[涨跌额],[涨跌幅] from [基金$]")
 SQLSTRING = "delete from Fund where fundbond='0'"
cnNew.Execute SQLSTRING
While Not ExcelRes.EOF


 SQLSTRING = "insert into fund([FundID],[FundVal],[FundAllVal],[FundChange],[ChangeRate],[FundBond]) values('" & Format(ExcelRes.Fields(0), "00####") & "'," & ExcelRes.Fields(1) & "," & ExcelRes.Fields(2) & "," & ExcelRes.Fields(3) & "," & ExcelRes.Fields(4) & ",'0')"
'CDbl(Left(ExcelRes.Fields(4), Len(ExcelRes.Fields(4) - 1)))
'Debug.Print SQLSTRING
cnNew.Execute SQLSTRING
ExcelRes.MoveNext
Wend
MsgBox "股票及债券基金数据导入成功", vbInformation, "提示"

Case 1
SQLSTRING = GetINI("SQL", "货币", App.Path & "\setting.ini")
Next_Return1: Set ExcelRes = ExcelCon.Execute(SQLSTRING)

'Set ExcelRes = ExcelCon.Execute("select [基金代码],[每万份基金净收益],[7日年化收益率] from [货币$]")
SQLSTRING = "delete from Fund where fundbond='1'"
cnNew.Execute SQLSTRING
While Not ExcelRes.EOF
 SQLSTRING = "insert into fund([FundID],[FundVal],[ChangeRate],[FundBond]) values('" & Format(ExcelRes.Fields(0), "00####") & "'," & ExcelRes.Fields(1) & "," & ExcelRes.Fields(2) & ",'1')"
'Debug.Print SqlString
cnNew.Execute SQLSTRING
ExcelRes.MoveNext
Wend
MsgBox "货币基金数据导入成功", vbInformation, "提示"
End Select
DateUpflag = 3
Command3.Enabled = False
Exit Sub
Err_Update:
Select Case Err.Number
Case -2147217904
MsgBox "Excel表头命名不合规范，请更正", vbCritical, "提示": Exit Sub
Case -2147217865
MsgBox "Excel表名不合规范，请更正为[基金]或[货币]", vbCritical, "提示": Exit Sub

Case -2147467259
'MsgBox "Excel排序问题，请重新导入一次", vbCritical, "提示"
If DateUpflag = 0 Then GoTo Next_Return0
If DateUpflag = 1 Then GoTo Next_Return1
End Select
MsgBox Err.Description
End Sub



Private Sub Command4_Click()
Dim IniString As String
Dim ScreenNum As Integer
IniString = Trim$(GetINI("设置项目", "固定屏", App.Path & "\setting.ini"))
If IsNumeric(IniString) = False Then
    MsgBox "请设置固定屏幕数量", vbInformation, "提示"
    Exit Sub
Else

ScreenNum = CInt(IniString)
cnNew.Execute "delete from Data where [Screen] >" & ScreenNum
End If
MsgBox "数据已经清空", vbInformation, "提示"
End Sub

Private Sub Command5_Click()
Dim VestCodeRes As ADODB.Recordset
Set VestCodeRes = New ADODB.Recordset
cnNew.Execute "delete from VestName where FundID='" & Text1.Text & "'"
VsGrid.ClearFields
VestCodeRes.Open "select [FundID] as 产品代码,[FundName] as 产品名称 from vestname", cnNew, adOpenStatic, adLockOptimistic

Set VsGrid.DataSource = VestCodeRes
Command7.Enabled = False
Command5.Enabled = False
End Sub

Private Sub Command6_Click()
Text1.Text = "": Text2.Text = ""
Text1.Enabled = True: Text2.Enabled = True
Command8.Visible = True
Command7.Enabled = False
Command5.Enabled = False
Insertflag = 1
End Sub

Private Sub Command7_Click()
Text2.Enabled = True
Command8.Visible = True
Insertflag = 0
End Sub

Private Sub Command8_Click()
Dim VestCodeRes As ADODB.Recordset
Set VestCodeRes = New ADODB.Recordset
If IsNull(Text1.Text) = True And IsNull(Text2.Text) = True Then MsgBox "要素不能空", vbInformation, "提醒": GoTo ExitSpot
If IsNumeric(Text1.Text) = False Then MsgBox "代码为数字", vbInformation, "提醒": GoTo ExitSpot
If Len(Text2.Text) > 16 Then MsgBox "名称太长", vbInformation, "提醒": GoTo ExitSpot

If Insertflag = 1 Then
    Set VestCodeRes = cnNew.Execute("select * from VestName where [FundID]='" & Format(Text1.Text, "00####") & "'")
    If VestCodeRes.BOF = False Then
        MsgBox "已经有该代码的品种", vbCritical, "提示"
        VestCodeRes.Close
        GoTo Spot_Next
    End If
    cnNew.Execute "insert into VestName([FundID],[FundName],[FundKind]) values('" & Format(Text1.Text, "00####") & "','" & Text2.Text & "'," & Left(Combo1.Text, 1) & ")"
ElseIf Insertflag = 0 Then
    cnNew.Execute "update VestName set [FundName]='" & Text2.Text & "' where [FundID]='" & Format(Text1.Text, "00####") & "'"
End If
Spot_Next: VsGrid.ClearFields
VestCodeRes.Open "select [FundID] as 产品代码,[FundName] as 产品名称 from vestname", cnNew, adOpenStatic, adLockOptimistic

Set VsGrid.DataSource = VestCodeRes
ExitSpot: Text1.Text = "": Text2.Text = ""
Text1.Enabled = False: Text2.Enabled = False
Command7.Enabled = False
Command5.Enabled = False
End Sub

Private Sub Command9_Click()
Unload Me
End Sub

Private Sub Form_Load()
On Error GoTo Err_Spot
Dim VestCodeRes As ADODB.Recordset
Dim DbName As String
Set VestCodeRes = New ADODB.Recordset


DbName = Trim$(GetINI("设置项目", "服务器名", App.Path & "\setting.ini"))
Text4.Text = DbName
Text5.Text = Trim$(GetINI("设置项目", "速度", App.Path & "\setting.ini"))
If DbName = "" Then
MsgBox "请设置服务器名称", vbInformation, "提示"
Exit Sub
End If
'ICBCOA -DE350357
'DbCon = OpenCn("ICBCOA -DE350357", "mixdbsource", "sa", "")
DbCon = OpenCn(DbName, "mixdbsource", "sa", "")
VestCodeRes.CursorLocation = adUseClient
VestCodeRes.Open "select [FundID] as 产品代码,[FundName] as 产品名称 from vestname", cnNew, adOpenKeyset, adLockOptimistic
Set VsGrid.DataSource = VestCodeRes
Text3.Text = Trim$(GetINI("设置项目", "固定屏", App.Path & "\setting.ini"))
Exit Sub
Err_Spot: MsgBox Err.Description, vbCritical, "提示"
End Sub





Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next

Clocn
End Sub

Private Sub Text3_LostFocus()
If IsNumeric(Text3.Text) = False Then
MsgBox "要求数字，1到20", vbCritical, "提示"
Exit Sub
End If
I = WritePrivateProfileString("设置项目", "固定屏", Text3.Text, App.Path & "\setting.ini")
End Sub


Private Sub Text4_LostFocus()
I = WritePrivateProfileString("设置项目", "服务器名", Text4.Text, App.Path & "\setting.ini")
End Sub

Private Sub Text5_LostFocus()
If IsNumeric(Text5.Text) = False Then
MsgBox "要求数字，1到20", vbCritical, "提示"
Exit Sub
End If

I = WritePrivateProfileString("设置项目", "速度", Text5.Text, App.Path & "\setting.ini")
End Sub


Private Sub VsGrid_RowColChange(LastRow As Variant, ByVal LastCol As Integer)
Text1.Text = VsGrid.Columns(0).Text
Text2.Text = VsGrid.Columns(1).Text
Command7.Enabled = True
Command5.Enabled = True
Command8.Visible = False
End Sub