form1.frm

本软件可以实现从sqlserver数据库的表中导出所有的数据到excel表格中

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   6780
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   9225
   LinkTopic       =   "Form1"
   ScaleHeight     =   6780
   ScaleWidth      =   9225
   StartUpPosition =   3  'Windows Default
   Begin VB.ComboBox Combo2 
      Height          =   315
      Left            =   2280
      TabIndex        =   8
      Top             =   2640
      Width           =   1935
   End
   Begin VB.CommandButton Command2 
      Caption         =   "退出"
      Height          =   495
      Left            =   5520
      TabIndex        =   7
      Top             =   5640
      Width           =   2415
   End
   Begin VB.ComboBox Combo1 
      Height          =   315
      Left            =   4440
      TabIndex        =   6
      Text            =   "是"
      Top             =   1800
      Width           =   1095
   End
   Begin MSComCtl2.DTPicker DTPicker2 
      Height          =   495
      Left            =   6240
      TabIndex        =   4
      Top             =   600
      Width           =   1815
      _ExtentX        =   3201
      _ExtentY        =   873
      _Version        =   393216
      Format          =   25231361
      CurrentDate     =   39586
   End
   Begin MSComCtl2.DTPicker DTPicker1 
      Height          =   495
      Left            =   2160
      TabIndex        =   1
      Top             =   600
      Width           =   2175
      _ExtentX        =   3836
      _ExtentY        =   873
      _Version        =   393216
      Format          =   25231361
      CurrentDate     =   39586
   End
   Begin VB.CommandButton Command1 
      Caption         =   "导出数据到EXCEL表"
      Height          =   495
      Left            =   720
      TabIndex        =   0
      Top             =   5640
      Width           =   3255
   End
   Begin VB.Label Label4 
      Caption         =   "服务器选择"
      Height          =   495
      Left            =   240
      TabIndex        =   9
      Top             =   2520
      Width           =   1575
   End
   Begin VB.Label Label3 
      Caption         =   "是否导出数据同时删除表中数据"
      Height          =   495
      Left            =   840
      TabIndex        =   5
      Top             =   1800
      Width           =   3375
   End
   Begin VB.Label Label2 
      Caption         =   "结束时间"
      Height          =   495
      Left            =   4560
      TabIndex        =   3
      Top             =   600
      Width           =   1455
   End
   Begin VB.Label Label1 
      Caption         =   "起始时间"
      Height          =   495
      Left            =   840
      TabIndex        =   2
      Top             =   600
      Width           =   1215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Strcfgfilename, strChoiceFile, strFile, strTrainPath As String
Dim DelDBString As String
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long


Public Function toexcel(objrs As ADODB.Recordset) As Boolean
'*********************************************************
'* 名称：ToExcel
'* 功能：将ado记录集导出为电子表格
'* 用法：call toexcel(rs)
'*********************************************************

Dim irowcount As Integer '行数
Dim Icolcount As Integer '列数

Dim xlApp As New Excel.Application 'excel对象
Dim xlBook As Excel.Workbook '工作簿对象
Dim xlsheet As Excel.Worksheet '工作表对象
Dim xlQuery As Excel.QueryTable '用完已释放？原代码没释放，我修改之
Dim connflag As Long '原来是否连接标志[1:原来已连，0:原来未连]
toexcel = False '首先赋初值为假

If conn.State = adStateOpen Then
connflag = 1
Else
connflag = 0
End If

'如未连接则先连接
If connflag = 0 Then
If Not mainmoudle.getlink Then
toexcel = False '因连接不成功，故返值为假
Exit Function
End If
End If

With objrs
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With

Set xlApp = CreateObject("Excel.Application") '创建excel对象
Set xlBook = Nothing '工作簿
Set xlsheet = Nothing '工作表
Set xlBook = xlApp.Workbooks().Add '添加一个工作簿
Set xlsheet = xlBook.Worksheets("sheet1") '工作表
'xlApp.Visible = True '意思不明白，加上没影响！

'添加查询语句，导入EXCEL数据
Set xlQuery = xlsheet.QueryTables.Add(objrs, xlsheet.Range("a1")) 'A1是确定起始行的位置

With xlQuery
.FieldNames = True '不知何用[是否是指字段名]
.RowNumbers = False '设置第一列是否显示序号
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True '使用合适的列宽
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With

xlQuery.FieldNames = True '设置是否在第一行处显示字段名
xlQuery.Refresh

With xlsheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous '如果第一行不显示字段，则不用加一
'设表格边框样式
End With

With xlsheet.PageSetup
Rem 以下页面设置因其个性化太强，故不用
'.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" ' & Gsmc
'.CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
'.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
'.LeftFooter = "&""楷体_GB2312,常规""&10制表人："
'.CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
'.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
End With

xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlsheet = Nothing
Set xlQuery = Nothing

'如果原来没有连接，本程序自建连接，则关闭时要关闭连接，如原来有连接则不管
If connflag = 0 Then
If conn.State = adStateOpen Then conn.Close
Set conn = Nothing
End If
toexcel = True
End Function

'主程序必须以main命名
Public Sub Main()
On Error GoTo errhandler
Dim strmess As String
frmlogon.Show vbModal
Exit Sub
errhandler:
strmess = "主程序启动时发生问题：" & Chr(13) & _
Err.Description
MsgBox strmess, 16, "错误提示"
End Sub
Public Function rstoexcel(rstable As ADODB.Recordset, cexcelname As String) As Boolean
'未解决关闭已打开文件，再按此文件名存贮的问题
On Error GoTo gherr
'On Error Resume Next
Dim icol As Integer '列数，用于保存字段个数
Dim ijlts As Long '记录条数
Dim yesorno As Long '确认或是取消的标志

Dim AppExcel As Excel.Application '定义尚未创建
Dim BookExcel As Excel.Workbook '工作簿对象
Dim sheetexcel As Excel.Worksheet '工作表

'如果没传过来文件名则返回
If Len(cexcelname) = 0 Then
Exit Function
End If

With rstable
If .RecordCount < 1 Then
MsgBox ("没有记录可供导出,该操作已经取消！")
rstoexcel = False
Exit Function
Else
icol = .Fields.Count '求字段数
ijlts = .RecordCount '求记录数
End If
End With

If Dir$(cexcelname) <> "" Then
yesorno = MsgBox("这个文件名已经存在，是否选择覆盖？如果该文件正处于打开状态由不能写入，请首先关闭该文件！", vbYesNo + vbDefaultButton2 + vbQuestion)
Else
yesorno = 6 '如果文件名并不存存，则置标志为可导出
End If

If yesorno <> 6 Then
rstoexcel = False
Exit Function
End If

Set AppExcel = New Excel.Application '创建excel对象

'AppExcel.Visible = False '什么用处？
Set BookExcel = AppExcel.Workbooks.Add '添加工作簿
Set sheetexcel = BookExcel.Worksheets("sheet1") '添加工作表

' AppExcel.Worksheets(1).Name = "工作表一" '在Text1中输入表名
For icol = 0 To rstable.Fields.Count - 1
AppExcel.Worksheets(1).Cells(1, icol + 1).Value = rstable.Fields(icol).Name
Next

'由于第一行是字段，故从第二行开始复制记录
AppExcel.Worksheets(1).Range("A2").CopyFromRecordset rstable

With sheetexcel
'.Range(.Cells(1, 1), .Cells(1, icol)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, icol)).Font.Bold = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(ijlts + 1, icol)).Borders.LineStyle = xlContinuous '如果第一行不显示字段，则不用加一
'设表格边框样式
End With

BookExcel.SaveAs (cexcelname)

'MsgBox ("该文件名已经存在，不能导出，否则将覆盖,请给出新的名称")
'rstoexcel = False
' Exit Function
' Set BookExcel = AppExcel.Workbooks.Open(ExcelFileName)
' AppExcel.Worksheets(1).Name = "zgh2 table" '在Text1中输入表名
' AppExcel.Worksheets(1).Range("A70").CopyFromRecordset rsTable
' BookExcel.SaveAs (ExcelFileName)


AppExcel.Quit
Set sheetexcel = Nothing
Set BookExcel = Nothing
Set AppExcel = Nothing
rstoexcel = True
Exit Function
gherr:
'MsgBox "电子表格导出失败，请检查该文件是否处理打开状态，错误信息如下：" & Chr(13) & Err.Number & "," & Err.Description
'MsgBox "由于未知原因，导出失败！", vbQuestion
rstoexcel = False
End Function

Public Sub getconn() '获取连接子程序,在主窗体的load事件中调用该函数
'如果不处于连接状态，则进行连接
On Error GoTo gherr
If conn.State <> adStateOpen Then
With conn
.ConnectionString = connstring
.ConnectionTimeout = 6
.Open '连接
End With
End If
Exit Sub
gherr:
MsgBox Err.Description
End Sub


Public Function getlink() As Boolean '连接数据库，正常返回真
'如果不处于连接状态，则进行连接
'conn是全局对象
On Error GoTo gherr
If conn.State <> adStateOpen Then
With conn
.ConnectionString = connstring
.ConnectionTimeout = 6
.Open '连接
End With
End If
If conn.State = adStateOpen Then
getlink = True
Else
getlink = False
End If
Exit Function
gherr:
getlink = False
MsgBox Err.Description
End Function
Public Function getconnobj() As ADODB.Connection '获取连接子程序,暂不使用该模块
Dim connobj As ADODB.Connection
Set connobj = New ADODB.Connection
Dim connstr As String
'connstr = "driver={" & VarDriver & "};server=" & VarServer & ";database=" & VarDbase & ";uid=" & VarUser & ";pwd=" & VarPassword & ""

If Combo2.Text = "监控室" Then
    VarServer = "10.69.3.20"
    VarPassword = "0823261"
ElseIf Combo2.Text = "检测室" Then
    VarServer = "10.69.3.19"
    VarPassword = "omis"
Else
        VarServer = "10.69.3.20"
    VarPassword = "0823261"
End If

connstr = "Provider=SQLOLEDB.1;Driver={" & VarDriver & "};server=" & VarServer & ";UID=" & VarUser & ";PWD=" & VarPassword & "; database=" & VarDbase & ";Persist Security Info=False " '不采用集成安全机制
                    
'connstr = "driver={sql server};server=(local);database=hepph;uid=sa;pwd=7006"
With connobj
.ConnectionString = connstr
.ConnectionTimeout = 6
.Open '连接
End With
Set getconnobj = connobj
'Set connobj = Nothing
End Function

Rem 导出电子表格的函数,源于李洪根的代码
Public Function ExportToExcel(stropen As String)
On Error Resume Next
'*********************************************************
'* 名称：exportToExcel
'* 功能：导出数据到EXCEL
'* 用法：exportToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset '定义记录集对象，用完已释放？原代码没释放，我修改之
Dim Ds_Data As New ADODB.Recordset '定义删除记录集对象，用完已释放
Dim irowcount As Long '行数
Dim Icolcount As Long '列数

Dim xlApp As New Excel.Application 'excel对象
Dim xlBook As Excel.Workbook '工作簿对象
Dim xlsheet As Excel.Worksheet '工作表对象
Dim xlQuery As Excel.QueryTable '用完已释放？原代码没释放，我修改之

'If Not mainmoudle.getlink Then
'Exit Function
'End If

With Rs_Data '记录集对象
If .State = adStateOpen Then
.Close '如果记录集处于打开状态，则先关闭它
End If
.ActiveConnection = getconnobj '连接
.CursorLocation = adUseClient '本地游标
.CursorType = adOpenStatic '静态游标
.LockType = adLockReadOnly '只读
.Source = stropen '通过函数传过来的字符串
.Open
End With

With Rs_Data
If .RecordCount < 1 Then