VB: 怎样将查询结果导出到Excel
如果你想将查询结果导出到Excel另存,以便日后查看或打印的话,那么我这里说的就是怎样将查询结果导出到Excel。先来写一个函数
FillDataArray,该函数的主要作用是将查询语句中的字段名和查到的记录导入到Excel中。
Public Function FillDataArray(asArray(), adoRS As ADODB.Recordset) As Long
'将数据送 Excel 函数
Dim nRow As Integer
Dim nCol As Integer
On Error GoTo FillError
ReDim asArray(100000, adoRS.Fields.Count)
nRow = 0
For nCol = 0 To adoRS.Fields.Count - 1
asArray(nRow, nCol) = adoRS.Fields(nCol).name
Next nCol
nRow = 1
Do While Not adoRS.EOF
For nCol = 0 To adoRS.Fields.Count - 1
asArray(nRow, nCol) = adoRS.Fields(nCol).Value
Next nCol
adoRS.MoveNext
nRow = nRow + 1
Loop
nRow = nRow + 1
FillDataArray = nRow
Exit Function
FillError:
MsgBox Error$
Exit Function
Resume
End Function
然后再来写一个过程PrintList,来调用前面的这个函数。
Private Sub PrintList()
Dim strSource, strDestination As String
Dim asTempArray()
Dim INumRows As Long
Dim objExcel As Excel.Application
Dim objRange As Excel.Range
On Error GoTo ExcelError
Set objExcel = New Excel.Application '新建一个Excel
Dim rs As New ADODB.Recordset
Set rs = Conn.Execute(sqlall)‘sqlall是查询语句
If Not rs.EOF Then
objExcel.Workbooks.Open App.Path & "/vvv.xls"
MsgBox "查询结果导出后,请将其另存为一个.xls文件,使vvv.xls中的内容为空,确保后面查询结果的正确导出。"
INumRows = FillDataArray(asTempArray, rs) '调填充数组函数
objExcel.cells(1, 1) = "查询结果" '填表头
Set objRange = objExcel.Range(objExcel.cells(2, 1), objExcel.cells(INumRows, rs.Fields.Count))
objRange.Value = asTempArray '填数据
End If
objExcel.Visible = True '显示Excel
objExcel.DisplayAlerts = True '提示保存Excel
Exit Sub
ExcelError:
If Err <> 432 And Err > 0 Then
MsgBox Error$
Set objExcel = Nothing
Exit Sub
Else
Resume Next
End If
End Sub
其中用到的vvv.xls必须是先建好了的xls文件。结果导出后不要直接保存,而要将其另存为一个.xls文件,使vvv.xls中的内容为空,确保
后面查询结果的正确导出?
------------------------------------------------------------------------------------------------
如何操作Excel文件
全面控制 Excel
首先创建 Excel 对象,使用ComObj:
Dim ExcelID as Excel.Application
Set ExcelID as new Excel.Application
1) 显示当前窗口:
ExcelID.Visible := True;
2) 更改 Excel 标题栏:
ExcelID.Caption := '应用程序调用 Microsoft Excel';
3) 添加新工作簿:
ExcelID.WorkBooks.Add;
4) 打开已存在的工作簿:
ExcelID.WorkBooks.Open( 'C:/Excel/Demo.xls' );
5) 设置第2个工作表为活动工作表:
ExcelID.WorkSheets[2].Activate;
或 ExcelID.WorkSheets[ 'Sheet2' ].Activate;
6) 给单元格赋值:
ExcelID.Cells[1,4].Value := '第一行第四列';
7) 设置指定列的宽度(单位:字符个数),以第一列为例:
ExcelID.ActiveSheet.Columns[1].ColumnsWidth := 5;
8) 设置指定行的高度(单位:磅)(1磅=0.035厘米),以第二行为例:
ExcelID.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米
9) 在第8行之前插入分页符:
ExcelID.WorkSheets[1].Rows[8].PageBreak := 1;
10) 在第8列之前删除分页符:
ExcelID.ActiveSheet.Columns[4].PageBreak := 0;
11) 指定边框线宽度:
ExcelID.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;
1-左 2-右 3-顶 4-底 5-斜( / ) 6-斜( / )
12) 清除第一行第四列单元格公式:
ExcelID.ActiveSheet.Cells[1,4].ClearContents;
13) 设置第一行字体属性:
ExcelID.ActiveSheet.Rows[1].Font.Name := '隶书';
ExcelID.ActiveSheet.Rows[1].Font.Color := clBlue;
ExcelID.ActiveSheet.Rows[1].Font.Bold := True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine := True;
14) 进行页面设置:
a.页眉:
ExcelID.ActiveSheet.PageSetup.CenterHeader := '报表演示';
b.页脚:
ExcelID.ActiveSheet.PageSetup.CenterFooter := '第&P页';
c.页眉到顶端边距2cm:
ExcelID.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;
d.页脚到底端边距3cm:
ExcelID.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;
e.顶边距2cm:
ExcelID.ActiveSheet.PageSetup.TopMargin := 2/0.035;
f.底边距2cm:
ExcelID.ActiveSheet.PageSetup.BottomMargin := 2/0.035;
g.左边距2cm:
ExcelID.ActiveSheet.PageSetup.LeftMargin := 2/0.035;
h.右边距2cm:
ExcelID.ActiveSheet.PageSetup.RightMargin := 2/0.035;
i.页面水平居中:
ExcelID.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;
j.页面垂直居中:
ExcelID.ActiveSheet.PageSetup.CenterVertically := 2/0.035;
k.打印单元格网线:
ExcelID.ActiveSheet.PageSetup.PrintGridLines := True;
15) 拷贝操作:
a.拷贝整个工作表:
ExcelID.ActiveSheet.Used.Range.Copy;
b.拷贝指定区域:
ExcelID.ActiveSheet.Range[ 'A1:E2' ].Copy;
c.从A1位置开始粘贴:
ExcelID.ActiveSheet.Range.[ 'A1' ].PasteSpecial;
d.从文件尾部开始粘贴:
ExcelID.ActiveSheet.Range.PasteSpecial;
16) 插入一行或一列:
a. ExcelID.ActiveSheet.Rows[2].Insert;
b. ExcelID.ActiveSheet.Columns[1].Insert;
17) 删除一行或一列:
a. ExcelID.ActiveSheet.Rows[2].Delete;
b. ExcelID.ActiveSheet.Columns[1].Delete;
18) 打印预览工作表:
ExcelID.ActiveSheet.PrintPreview;
19) 打印输出工作表:
ExcelID.ActiveSheet.PrintOut;
20) 工作表保存:
If not ExcelID.ActiveWorkBook.Saved then
ExcelID.ActiveSheet.PrintPreview
End if
21) 工作表另存为:
ExcelID.SaveAs( 'C:/Excel/Demo1.xls' );
22) 放弃存盘:
ExcelID.ActiveWorkBook.Saved := True;
23) 关闭工作簿:
ExcelID.WorkBooks.Close;
24) 退出 Excel:
ExcelID.Quit;
25) 设置工作表密码:
ExcelID.ActiveSheet.Protect "123", DrawingObjects:=True, Contents:=True, Scenarios:=True
26) EXCEL的显示方式为最大化
ExcelID.Application.WindowState = xlMaximized
27) 工作薄显示方式为最大化
ExcelID.ActiveWindow.WindowState = xlMaximized
28) 设置打开默认工作薄数量
ExcelID.SheetsInNewWorkbook = 3
29) '关闭时是否提示保存(true 保存;false 不保存)
ExcelID.DisplayAlerts = False
30) 设置拆分窗口,及固定行位置
ExcelID.ActiveWindow.SplitRow = 1
ExcelID.ActiveWindow.FreezePanes = True
31) 设置打印时固定打印内容
ExcelID.ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
32) 设置打印标题
ExcelID.ActiveSheet.PageSetup.PrintTitleColumns = ""
33) 设置显示方式(分页方式显示)
ExcelID.ActiveWindow.View = xlPageBreakPreview
34) 设置显示比例
ExcelID.ActiveWindow.Zoom = 100
35) 让Excel 响应 DDE 请求
Ex.Application.IgnoreRemoteRequests = False
用VB操作EXCEL
Private Sub Command3_Click()
On Error GoTo err1
Dim i As Long
Dim j As Long
Dim objExl As Excel.Application '声明对象变量
Me.MousePointer = 11 '改变鼠标样式
Set objExl = New Excel.Application '初始化对象变量
objExl.SheetsInNewWorkbook = 1 '将新建的工作薄数量设为1
objExl.Workbooks.Add '增加一个工作薄
objExl.Sheets(objExl.Sheets.Count).Name = "book1" '修改工作薄名称
objExl.Sheets.Add , objExl.Sheets("book1") ‘增加第二个工作薄在第一个之后
objExl.Sheets(objExl.Sheets.Count).Name = "book2"
objExl.Sheets.Add , objExl.Sheets("book2") ‘增加第三个工作薄在第二个之后
objExl.Sheets(objExl.Sheets.Count).Name = "book3"
objExl.Sheets("book1").Select '选中工作薄<book1>
For i = 1 To 50 '循环写入数据
For j = 1 To 5
If i = 1 Then
objExl.Selection.NumberFormatLocal = "@" '设置格式为文本
objExl.Cells(i, j) = " E " & i & j
Else
objExl.Cells(i, j) = i & j
End If
Next
Next
objExl.Rows("1:1").Select '选中第一行
objExl.Selection.Font.Bold = True '设为粗体
objExl.Selection.Font.Size = 24 '设置字体大小
objExl.Cells.EntireColumn.AutoFit '自动调整列宽
objExl.ActiveWindow.SplitRow = 1 '拆分第一行
objExl.ActiveWindow. SplitColumn = 0 '拆分列
objExl.ActiveWindow.FreezePanes = True '固定拆分 objExl.ActiveSheet.PageSetup.PrintTitleRows = "$1:$1" '设置打印固定行
objExl.ActiveSheet.PageSetup.PrintTitleColumns = "" '打印标题 objExl.ActiveSheet.PageSetup.RightFooter = "打印时间: " & _
Format(Now, "yyyy年mm月dd日 hh:MM:ss")
objExl.ActiveWindow.View = xlPageBreakPreview '设置显示方式
objExl.ActiveWindow.Zoom = 100 '设置显示大小
'给工作表加密码
objExl.ActiveSheet.Protect "123", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
objExl.Application.IgnoreRemoteRequests = False
objExl.Visible = True '使EXCEL可见
objExl.Application.WindowState = xlMaximized 'EXCEL的显示方式为最大化
objExl.ActiveWindow.WindowState = xlMaximized '工作薄显示方式为最大化
objExl.SheetsInNewWorkbook = 3 '将默认新工作薄数量改回3个
Set objExl = Nothing '清除对象
Me.MousePointer = 0 '修改鼠标
Exit Sub
err1:
objExl.SheetsInNewWorkbook = 3
objExl.DisplayAlerts = False '关闭时不提示保存
objExl.Quit '关闭EXCEL
objExl.DisplayAlerts = True '关闭时提示保存
Set objExl = Nothing
Me.MousePointer = 0
End Sub
------------------------------------------------------------------------------------------
'利用 Word 打印的例子
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim sTemp, sHeadline, sTitle As String
Dim i As Integer
Dim oldRec As Long
On Error GoTo eh
If adc_card.Recordset.RecordCount = 0 Then MsgBox "没有可打印的数据!", vbCritical: Exit Sub
oldRec = adc_card.Recordset.AbsolutePosition
' Create an instance of Word
Set oWord = CreateObject("Word.Application")
' Add a new, blank document
Set oDoc = oWord.Documents.add
oDoc.PageSetup.Orientation = wdOrientLandscape
' Get the current document's range object
Set oRange = oDoc.Range
sTitle = Format(DTPicker1.value, "yyyy年mm月dd日") & Combo1 & IIf(Len(Text4), "(", "") & Text4 & IIf(Len(Text4), ")", "") & "消费记录明细表" & vbCrLf & vbCrLf
oRange.Text = sTitle
oRange.SetRange Len(sTitle) + 1, Len(sTitle) + 1
adc_card.Recordset.MoveFirst
sTemp = adc_card.Recordset.GetString(adClipString, -1, vbTab)
For i = 0 To Datagrid1.Columns.Count - 1
sHeadline = sHeadline & Datagrid1.Columns(i).Caption & vbTab
Next i
sHeadline = Left(sHeadline, Len(sHeadline) - 1) & vbCrLf
' Insert a heading on the string
sTemp = sHeadline & sTemp
' Insert the data into the Word document
oRange.Text = sTemp
' Convert the text to a table and format the table
oRange.ConvertToTable vbTab, , , , 36
oRange.SetRange oRange.End + 1, oRange.End + 1
oRange.Text = vbCrLf & "制表人:" & AdminName & vbTab & vbTab _
& "制表日期:" & Format(Date, "long date")
oRange.ParagraphFormat.Alignment = wdAlignParagraphRight
oDoc.Tables(1).Select
With oWord.Selection
.Cells.HeightRule = wdRowHeightAtLeast
.Cells.Height = 16
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
oDoc.Tables(1).Columns(2).Width = 40
oDoc.Tables(1).Columns(8).Width = oDoc.Tables(1).Columns(8).Width + 50
For i = 2 To adc_card.Recordset.RecordCount + 1
oDoc.Tables(1).Cell(i, 4).Select
oWord.Selection.Text = Format(Val(oWord.Selection.Text), "currency")
Next i
oDoc.Tables(1).Cell(1, 4).Select
oWord.Selection.SelectColumn
oWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
oDoc.Tables(1).Cell(1, 4).Select
oWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
oWord.Selection.HomeKey Unit:=wdStory
'Formating the Title
oRange.SetRange 0, Len(sTitle) - 4
With oRange
.Font.Name = "宋体"
.Font.size = 16
.Font.Bold = True
.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
' Show Word to the user
oWord.Visible = True
If oldRec >= 1 Then
adc_card.Recordset.MoveFirst
adc_card.Recordset.Move oldRec - 1
End If
'CheckBox on form says "立即打印"
If Check1 Then oWord.PrintOut
-------------------------------------------------------------------------------------------
datagrid 导出到 EXCEL
Private Sub Command1_Click()
Dim i As Integer
Dim j As Integer
Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.add
On Error Resume Next
Set xlBook = xlApp.Workbooks.Open("d:/text2.xls")
Set xlSheet = xlBook.Worksheets(1)
For j = 0 To mgrid.Columns.Count - 1
xlSheet.Cells(1, j + 1) = mgrid.Columns.Item(j).Caption
Next j
xlSheet.Cells(6, 1) = "i"
Adodc1.Recordset.MoveFirst
For i = 0 To Adodc1.Recordset.RecordCount - 1
mgrid.Row = i
For j = 0 To mgrid.Columns.Count - 1
mgrid.Col = j
'MsgBox DataGrid1.Text
If IsNull(mgrid.Text) = False Then
xlSheet.Cells(i + 2, j + 1) = mgrid.Text
End If
Next j
Next i
End Sub
------------------------------------------------------------------------------------------