form1.frm

数据连接程序放到数据库里

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "数据库测试"
   ClientHeight    =   5775
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   7620
   ControlBox      =   0   'False
   DrawStyle       =   1  'Dash
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   Moveable        =   0   'False
   ScaleHeight     =   288.75
   ScaleMode       =   0  'User
   ScaleWidth      =   381
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   375
      Left            =   3840
      TabIndex        =   8
      Top             =   600
      Width           =   735
   End
   Begin VB.CommandButton Command4 
      Caption         =   "确定"
      Height          =   405
      Left            =   6240
      TabIndex        =   7
      Top             =   135
      Width           =   1170
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   7200
      Top             =   1080
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command3 
      Caption         =   "退 出"
      Height          =   405
      Left            =   6240
      TabIndex        =   6
      Top             =   570
      Width           =   1170
   End
   Begin MSDataGridLib.DataGrid DataGrid1 
      Height          =   4530
      Left            =   225
      TabIndex        =   5
      Top             =   1140
      Width           =   7245
      _ExtentX        =   12779
      _ExtentY        =   7990
      _Version        =   393216
      HeadLines       =   1
      RowHeight       =   15
      BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ColumnCount     =   2
      BeginProperty Column00 
         DataField       =   ""
         Caption         =   ""
         BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} 
            Type            =   0
            Format          =   ""
            HaveTrueFalseNull=   0
            FirstDayOfWeek  =   0
            FirstWeekOfYear =   0
            LCID            =   2052
            SubFormatType   =   0
         EndProperty
      EndProperty
      BeginProperty Column01 
         DataField       =   ""
         Caption         =   ""
         BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED} 
            Type            =   0
            Format          =   ""
            HaveTrueFalseNull=   0
            FirstDayOfWeek  =   0
            FirstWeekOfYear =   0
            LCID            =   2052
            SubFormatType   =   0
         EndProperty
      EndProperty
      SplitCount      =   1
      BeginProperty Split0 
         BeginProperty Column00 
         EndProperty
         BeginProperty Column01 
         EndProperty
      EndProperty
   End
   Begin MSComCtl2.DTPicker DTPicker1 
      Height          =   360
      Left            =   1050
      TabIndex        =   4
      Top             =   585
      Width           =   1380
      _ExtentX        =   2434
      _ExtentY        =   635
      _Version        =   393216
      Format          =   19726337
      CurrentDate     =   38222
   End
   Begin VB.TextBox Text1 
      Height          =   330
      Left            =   1065
      TabIndex        =   2
      Top             =   165
      Width           =   4170
   End
   Begin VB.CommandButton Command1 
      Height          =   360
      Left            =   5295
      TabIndex        =   0
      Top             =   150
      Width           =   390
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "日期"
      Height          =   180
      Left            =   165
      TabIndex        =   3
      Top             =   660
      Width           =   360
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "目录文件"
      Height          =   180
      Left            =   180
      TabIndex        =   1
      Top             =   240
      Width           =   720
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Strconnect As String
Dim mySQL As String
Dim StrDate As String
Dim gcnnLink As New ADODB.Connection     'DBF数据文件联接
Dim gcnnLink1 As New ADODB.Connection    '联接后台数据SQL Server
Dim RsHQZJC As New ADODB.Recordset
Dim RssqlHQZJC As New ADODB.Recordset
Dim Rs1 As New ADODB.Recordset
Dim ErrH As Boolean
Private Sub Command1_Click()
    On Error GoTo ErrHand:
    CommonDialog1.CancelError = True
    CommonDialog1.Filter = "数据文件（*.bdf）|*.dbf"
    CommonDialog1.ShowOpen
    Text1.Text = CommonDialog1.FileName
ErrHand:
End Sub
Sub LoadDBF()
    On Error GoTo ErrHander:
    Dim i, j As Integer
    Dim pathName As String
    i = Len(CommonDialog1.FileTitle)
    j = Len(Text1.Text) - i
    pathName = Left(Text1.Text, j)
    StrDate = CStr(Format(Me.DTPicker1.Value, "yyyymmdd"))
    Set gcnnLink = Nothing
    Set gcnnLink = New ADODB.Connection
    Strconnect = "Driver=Microsoft Visual Foxpro Driver;SourceDB=" & pathName & ";SourceType=DBF;Deleted=No "
    With gcnnLink
        .ConnectionString = Strconnect
        .CursorLocation = adUseClient
        .Open
    End With
    Set RsHQZJC = Nothing
    Set RsHQZJC = New ADODB.Recordset
    mySQL = "select * from sjshq where hqzqjc = '" & StrDate & "'"
    RsHQZJC.Open mySQL, gcnnLink, adOpenDynamic, adLockOptimistic
    If RsHQZJC.RecordCount < 1 Then
        MsgBox "数据日期不符", vbOKOnly + vbInformation, "提示"
        Text1.Text = ""
        mySQL = ""
        ErrH = True
    Else
       mySQL = "select * from sjshq where hqzqjc <> '" & StrDate & "'order by HQZJCJ"
    End If
    Exit Sub
ErrHander:
    MsgBox "读取DBF数据文件错误！"
    Text1.Text = ""
    Text1.SetFocus
    ErrH = True
End Sub

Private Sub Command2_Click()
    Dim i As Integer
    Dim j, k As Double
    
    Dim Rs2 As New ADODB.Recordset '
    Set Rs2 = Nothing
    Set Rs2 = New ADODB.Recordset
    mySQL = "SELECT fkmh as kh,cast(sum(case when fjd='J' then fbal else 0 end) as dec(18,2)) as jje,cast(sum(case when fjd='D' then fbal else 0 end) as dec(18,2)) as dje FROM [A2004001fcwvch] WHERE fkmh='10101'and (fpzly='FHD' or fpzly='YHHG') GROUP BY fkmh ORDER BY fkmh "
    'Rs2.Open mySQL, gcnnLink1, adOpenStatic, adLockBatchOptimistic
    'Rs2.Open mySQL, gcnnLink1, adOpenStatic, adLockOptimistic
    'Rs2.Open mySQL, gcnnLink1, adOpenStatic, adLockPessimistic
    Rs2.Open mySQL, gcnnLink1, adOpenStatic, adLockReadOnly
    i = Rs2.Fields(0)
    j = Rs2.Fields(1)
    k = Rs2.Fields(2)
    
End Sub

Private Sub Command3_Click()
    gcnnLink1.Close
    End
End Sub
Sub Griddata()
    Dim RsGrid As New ADODB.Recordset
    On Error GoTo ErrHand:
    Set RsGrid = Nothing
    Set RsGrid = New ADODB.Recordset
    RsGrid.Open mySQL, gcnnLink1, adOpenDynamic, adLockOptimistic
    Set DataGrid1.DataSource = RsGrid
    Exit Sub
ErrHand:
'    MsgBox "绑定数据失败！"
    ErrH = True
End Sub

Private Sub Command4_Click()
    ErrH = False
    If Trim(Text1.Text) = "" Then
        MsgBox "请选择目录文件！"
        Text1.SetFocus
        Exit Sub
    End If
    Set RssqlHQZJC = Nothing
    Set RssqlHQZJC = New ADODB.Recordset
    mySQL = "select * from sysobjects where name = 'sjshq'"
    RssqlHQZJC.Open mySQL, gcnnLink1, adOpenDynamic, adLockBatchOptimistic
    If RssqlHQZJC.RecordCount < 1 Then CreateTable  '创建数据表
    If ErrH = False Then LoadDBF
    If ErrH = False Then InputData
    mySQL = "select * from sjshq where Indate = '" & StrDate & "'"
    If ErrH = False Then Griddata
End Sub
Private Sub DataGrid1_HeadClick(ByVal ColIndex As Integer)
    mySQL = "select * from sjshq where Indate = '" & StrDate & "'order by " & DataGrid1.Columns(ColIndex).DataField
    Griddata
End Sub

Sub CreateTable()
    On Error GoTo ErrHander:
    Set RssqlHQZJC = Nothing
    Set RssqlHQZJC = New ADODB.Recordset
    mySQL = "Create table SJSHQ" _
     & "(Indate varchar(8) not null , " _
     & "hqzqdm varchar(6) not null primary key,hqzqjc varchar(8) not null,hqzrsp numeric(9,3)not null,hqjrkp numeric(9,3) not null, " _
     & "hqzjcj numeric(9,3)not null,hqcjsl numeric(12,0)not null,hqcjje numeric(17,3)not null,hqcjbs numeric(9,0)not null," _
     & "hqzgcj numeric(9,3)not null,hqzdcj numeric(9,3)not null,hqsyl1 numeric(7,2)not null,hqsyl2 numeric(7,2)not null," _
     & "hqjsd1 numeric(9,3)not null,hqjsd2 numeric(9,3)not null,hqhycc numeric(12,0)not null,hqsjw4 numeric(9,3)not null," _
     & "hqssl4 numeric(12,0)not null,hqsjw3 numeric(9,3)not null,hqssl3 numeric(12,0)not null,hqsjw2 numeric(9,3)not null," _
     & "hqssl2 numeric(12,0)not null,hqsjw1 numeric(9,3)not null,hqssl1 numeric(12,0)not null,hqbjw1 numeric(9,3)not null," _
     & "hqbsl1 numeric(12,0)not null,hqbjw2 numeric(9,3)not null,hqbsl2 numeric(12,0)not null,hqbjw3 numeric(9,3)not null," _
     & "hqbsl3 numeric(12,0)not null,hqbjw4 numeric(9,3)not null,hqbsl4 numeric(12,0)not null)"
     RssqlHQZJC.Open mySQL, gcnnLink1, adOpenDynamic, adLockBatchOptimistic
     Exit Sub
ErrHander:
    MsgBox "数据表创建失败", vbOKOnly, "提示"
    ErrH = True
End Sub
Sub InputData()
    On Error GoTo Err:
    Dim i, j As Integer

    Set Rs1 = Nothing
    Set Rs1 = New ADODB.Recordset
    Rs1.Open mySQL, gcnnLink, adOpenDynamic, adLockBatchOptimistic
    
    Set RssqlHQZJC = Nothing
    Set RssqlHQZJC = New ADODB.Recordset
    mySQL = "select * from sjshq where indate = '" & StrDate & "'"   '查询数据表中是否有当天的行情数据
    RssqlHQZJC.Open mySQL, gcnnLink1, adOpenKeyset, adLockBatchOptimistic
    If RssqlHQZJC.RecordCount > 0 Then
       If MsgBox("当前行情数据己存在，是否重新生成？", vbOKCancel, "提示") = vbOK Then
            gcnnLink1.Execute "delete from sjshq where indate = '" & StrDate & "'" '删除所有存在的当天行情数据
       Else
            mySQL = "select * from sjshq where Indate = '" & StrDate & "'"
            Call Griddata
            Exit Sub
       End If
    End If
    i = Rs1.Fields.Count
    Do While Not Rs1.EOF
       RssqlHQZJC.AddNew
       RssqlHQZJC.Fields(0) = StrDate
       For j = 1 To i
          RssqlHQZJC.Fields(j).Value = Rs1.Fields(j - 1).Value
          Next j
       Rs1.MoveNext
    Loop
    RssqlHQZJC.UpdateBatch
    RssqlHQZJC.Close
    Exit Sub
Err:
    MsgBox "数据提交失败！", vbOKOnly, "提示"
    ErrH = True
End Sub

Private Sub DTPicker1_Change()
    StrDate = CStr(Format(Me.DTPicker1.Value, "yyyymmdd"))
    mySQL = "select * from sjshq where Indate = '" & StrDate & "'"
    Griddata
End Sub

Private Sub Form_Load()
    Set gcnnLink1 = Nothing
    Set gcnnLink1 = New ADODB.Connection
'    Strconnect = "driver={SQL Server};server=DOHIBJB;uid=;pwd=;database=Test"
    Strconnect = "driver={SQL Server};server=SamFU;uid=;pwd=;database=yhfund"
    With gcnnLink1
'        .CursorLocation = adUseClient
         .CursorLocation = adUseServer
        .ConnectionString = Strconnect
        .Open
    End With
End Sub