excel.frm

将SQL数据库中的数据倒入到excel表格中

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3090
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   495
      Left            =   1080
      TabIndex        =   0
      Top             =   720
      Width           =   1455
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
    Dim conn As ADODB.Connection
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim rs1 As ADODB.Recordset
    Dim vkmdm, vkmmc, vkbsl As String
    
    Dim sql As String
    Dim connstring As String
    Dim ss As String
    connstring = "Driver={Microsoft Excel Driver (*.xls)};DBQ=" & App.Path & "\" & "zmhh.xls"
    Set conn = New ADODB.Connection
    conn.Open connstring
    sql = "select * from [xuexiao]"
    Set rs = New ADODB.Recordset
    rs.Open sql, conn, 2, 2
    'Do While Not rs.EOF
    '   ss = ""
    '   ss = rs("科目代码") & "  " & rs("科目名称") & "  " & rs("课本数")
    '   MsgBox ss
    '   rs.MoveNext
    'Loop
    MsgBox "excel 连接正确！"
    connstring = "driver={SQL Server};database=fs;server=ysgs01;uid=sa;password=12315"
    Set cn = New ADODB.Connection
    cn.Open connstring
    MsgBox "SQL SERVER 连接正确！"
    Set rs1 = New ADODB.Recordset
    
    Do While Not rs.EOF
       vkmdm = rs("科目代码")
       vkmmc = rs("科目名称")
       vkbsl = rs("课本数")
       MsgBox vkmdm & "  " & vkmmc & "  " & vkbsl
       sql = "select kmdm from excel where kmdm='" & vkmdm & "'"
       rs1.Open sql, cn, adOpenKeyset, adLockReadOnly
       If rs1.EOF Then
           sql = "insert into excel(kmdm,kmmc,kbsl) values('" & vkmdm & "','" & vkmmc & "','" & vkbsl & "')"
           cn.Execute sql
       End If
       rs1.Close
       rs.MoveNext
    Loop
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
End Sub

Public Sub connect_sql(ByVal strConnect As String)
 Dim err As ADODB.Error
 Dim Msg As String
 Screen.MousePointer = vbHourglass
 Set cn = New ADODB.Connection
  On Error GoTo ER
   'strConnect = "driver={SQL Server};database=fs;server=10.68.7.1;uid=sa;password=12315"
   'strConnect = "driver={SQL Server};database=UTC;server=" & server & ";uid=sa;password=12315"
   
   cn.Open strConnect
   Screen.MousePointer = vbDefault
  ' MsgBox "连接SQL数据库成功！", vbOKOnly + vbExclamation, "祝贺"
   Exit Sub
ER:
  For Each err In cn.Errors
   Msg = Msg & vbCrLf & err.Description
  Next err
  
  If Screen.MousePointer = vbHourglass Then
    Screen.MousePointer = vbDefault
  End If
  
  i = MsgBox("连接数据库出错！" & vbCrLf & Msg, vbExclamation + vbOKOnly, "出错")
  End
  Exit Sub
End Sub