Public Sub Export(formname As Form, flexgridname As String) Dim xlApp As Object 'Excel.Application Dim xlBook As Object 'Excel.Workbook Dim xlSheet As Object 'Excel.Worksheet Screen.MousePointer = vbHourglass On Error GoTo Err_Proc Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) 'Begin to fill data to sheet Dim i As Long Dim j As Integer Dim k As Integer With formname.Controls(flexgridname) For i = 0 To .rows - 1 k = 0 For j = 0 To .Cols - 1 If .colwidth(j) > 20 Or .colwidth(j) < 0 Then k = k + 1 xlSheet.Cells(i + 1, k).Value = "'" & .TextMatrix(i, j) End If Next j Next i End With xlApp.Visible = True Screen.MousePointer = vbDefault Exit Sub Err_Proc: Screen.MousePointer = vbDefault MsgBox "请确认您的电脑已安装Excel!", vbExclamation,"提示"
End Sub
Public Function ExporToExcel(strOpen As String) '********************************************************* '* 名称:ExporToExcel '* 功能:导出数据到EXCEL '* 用法:ExporToExcel(sql查询字符串) '********************************************************* Dim Rs_Data As New ADODB.Recordset Dim Irowcount As Integer Dim Icolcount As Integer Dim cn As New ADODB.Connection Dim xlApp As New Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim xlQuery As Excel.QueryTable With Rs_Data If .State = adStateOpen Then .Close End If .ActiveConnection = "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=D:\DBF;" .CursorLocation = adUseClient .CursorType = adOpenStatic .Source = strOpen .Open End With With Rs_Data If .RecordCount < 1 Then MsgBox ("没有记录!") Exit Function End If '记录总数 Irowcount = .RecordCount '字段总数 Icolcount = .Fields.Count End With
Set xlApp = CreateObject("Excel.Application") 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(Rs_Data, xlSheet.Range("a1"))
xlQuery.FieldNames = True '显示字段名 xlQuery.Refresh
xlApp.Application.Visible = True Set xlApp = Nothing '"交还控制给Excel Set xlBook = Nothing Set xlSheet = Nothing
'********************************************************* '* 名称:OutDataToExcel '* 功能:将MsFlexGrid控件中显示的内容输出到Excel表格中进行打印 '********************************************************* Public Sub OutDataToExcel(Flex As MSFlexGrid) '导出至Excel Dim s As String Dim i As Integer Dim j As Integer Dim k As Integer On Error GoTo Ert Me.MousePointer = 11 Dim Excelapp As Excel.Application Set Excelapp = New Excel.Application On Error Resume Next DoEvents Excelapp.SheetsInNewWorkbook = 1 Excelapp.Workbooks.Add Excelapp.ActiveSheet.Cells(1, 3) = s Excelapp.Range("C1").Select Excelapp.Selection.Font.FontStyle = "Bold" Excelapp.Selection.Font.Size = 16 With Flex k = .Rows For i = 0 To k - 1 For j = 0 To .Cols - 1 DoEvents Excelapp.ActiveSheet.Cells(3 + i, j + 1) = "'" & .TextMatrix(i, j) Next j Next i End With Me.MousePointer = 0 Excelapp.Visible = True Excelapp.Sheets.PrintPreview Ert: If Not (Excelapp Is Nothing) Then Excelapp.Quit End If End Sub
Dim xlApp As Object 'Excel.Application
Dim xlBook As Object 'Excel.Workbook
Dim xlSheet As Object 'Excel.Worksheet
Screen.MousePointer = vbHourglass
On Error GoTo Err_Proc
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
'Begin to fill data to sheet
Dim i As Long
Dim j As Integer
Dim k As Integer
With formname.Controls(flexgridname)
For i = 0 To .rows - 1
k = 0
For j = 0 To .Cols - 1
If .colwidth(j) > 20 Or .colwidth(j) < 0 Then
k = k + 1
xlSheet.Cells(i + 1, k).Value = "'" & .TextMatrix(i, j)
End If
Next j
Next i
End With
xlApp.Visible = True
Screen.MousePointer = vbDefault
Exit Sub
Err_Proc:
Screen.MousePointer = vbDefault
MsgBox "请确认您的电脑已安装Excel!", vbExclamation,"提示"
End Sub
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim cn As New ADODB.Connection
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = "provider=msdasql;DRIVER=Microsoft Visual FoxPro Driver;UID=;Deleted=yes;Null=no;Collate=Machine;BackgroundFetch=no;Exclusive=No;SourceType=DBF;SourceDB=D:\DBF;"
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
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(Rs_Data, xlSheet.Range("a1"))
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
End Function
用Msflexgrid的Textmatrix属性取Msflexgrid中每一个单元格的内容,然后填到Excel表中,或者写成CSV格式方法二:
直接把查询结果导出成Excel工作表
'* 名称:OutDataToExcel
'* 功能:将MsFlexGrid控件中显示的内容输出到Excel表格中进行打印
'*********************************************************
Public Sub OutDataToExcel(Flex As MSFlexGrid) '导出至Excel
Dim s As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
On Error GoTo Ert
Me.MousePointer = 11
Dim Excelapp As Excel.Application
Set Excelapp = New Excel.Application
On Error Resume Next
DoEvents
Excelapp.SheetsInNewWorkbook = 1
Excelapp.Workbooks.Add
Excelapp.ActiveSheet.Cells(1, 3) = s
Excelapp.Range("C1").Select
Excelapp.Selection.Font.FontStyle = "Bold"
Excelapp.Selection.Font.Size = 16
With Flex
k = .Rows
For i = 0 To k - 1
For j = 0 To .Cols - 1
DoEvents
Excelapp.ActiveSheet.Cells(3 + i, j + 1) = "'" & .TextMatrix(i, j)
Next j
Next i
End With
Me.MousePointer = 0
Excelapp.Visible = True
Excelapp.Sheets.PrintPreview
Ert:
If Not (Excelapp Is Nothing) Then
Excelapp.Quit
End If
End Sub