'**********************
'备份数据库到excel表中
'**********************
Public Function BackUpDataBase(ctlOpt As Object, blnBak As Boolean) As Boolean
Dim sql As String
Dim i
Dim rst As ADODB.Recordset
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
BackUpDataBase = False
'首先赋初值为假
sql = "select FPBH as 磅单号,BWTAR as 进出货,DYDAT as 打印时间,CHEHAO as 车号,MATNR as 货物名称,CHARG as 件数,EBELN as 通知单号,LIFNR as 进出货单位,MZQTY as 毛重,PZQTY as 皮重,JZQTY as 净重,MZDAT as 毛重时间,PZDAT as 皮重时间,MZJLY as 毛重计量员,BFNAME as 毛重磅房,PZJLY as 皮重计量员,LGORT_T as 皮重磅房,KOSTL as 随车物品 FROM ZJLRESTMP where PZFLAG=2"
Debug.Print sql
If ctlOpt(0).Value = True Then
If conConnect.ConLocal.State <> 1 Then
MsgBox "本地数据库链接失败！", vbCritical + vbOKOnly, "提示"
Exit Function
Else
Call conConnect.ExecuteSQL(sql, conConnect.ConLocal, rst)
End If
Else
If conConnect.conServer.State <> 1 Then
MsgBox "服务器链接失败！", vbCritical + vbOKOnly, "提示"
Exit Function
Else
Call conConnect.ExecuteSQL(sql, conConnect.conServer, rst)
End If
End If
If rst.EOF Then
MsgBox "数据库中没有数据！", vbCritical + vbOKOnly, "提示"
Exit Function
End If
frmMain.StatusBar1.Panels.Item(1).Text = "正在备份数据库..."
With rst
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(rst, xlsheet.Range("A1")) '是确定起始行的位置
' For i = 2 To rst.RecordCount + 1
'If rst.Fields(rst.Fields(1).Name) = 1 Then
'
xlsheet.Cells(i, 2) = "进货"
'
Else
'
xlsheet.Cells(i, 2) = "出货"
'
End If
'
Next
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
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlsheet = Nothing
Set xlQuery = Nothing
BackUpDataBase = True
ShowConserverState
End Function
2008-11-24 10:26
