Public Sub SaveAsExcel()
Dim s As String
s = "EXCEL(*.xls)|*.xls"
FrmFlexGrid.CDG.Filter = s
FrmFlexGrid.CDG.FilterIndex = 1
FrmFlexGrid.CDG.Action = 2
If .......
End Sub
s = "EXCEL(*.xls)|*.xls"
FrmFlexGrid.CDG.Filter = s
FrmFlexGrid.CDG.FilterIndex = 1
FrmFlexGrid.CDG.Action = 2
If FrmFlexGrid.CDG.Filename <> "" Then
Screen.MousePointer = 11
filenum = FreeFile
Open FrmFlexGrid.CDG.Filename For Output As filenum
Set xlApp = Nothing
xlApp.Quit
End If
Public Function ExportToExcelByFlexGrid(FLex As MSHFlexGrid, Merr As Boolean, Starrow As Long, Starcol As Long, title As String)
'------------------------------------------------
'功能:将MSHFlexGrid表中内容导出至Excel中
'参数:
' [Flex]................MSHFlexGrid表格
' [Merr]...............是否带合并单元格
' [Starrow]..............开始行
' [Starcol]..............开始列
' [title] ...............表头文字
'------------------------------------------------
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlApp.Workbooks(1).Worksheets(1)
On Error GoTo err
Screen.MousePointer = 13
With xlSheet
''''''''''''''''''''''
'如果不需要合并单位格'
''''''''''''''''''''''
If Merr = False Then
''''''''''
'导出数据'
''''''''''
For I = Starrow To FLex.Rows - 1
DoEvents
For J = Starcol To FLex.Cols - 1
.Cells(I + 2, J + 1).Value = FLex.TextMatrix(I, J)
Next
Next
''''''''''''''''''''
'加表头,调整表格式'
''''''''''''''''''''
.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, J)).Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
.Cells(1, 1) = title
Else
''''''''''''''''
'需要合并单元格'
''''''''''''''''
''''''''''
'导出数据'
''''''''''
For I = Starrow + 1 To FLex.Rows - 1
DoEvents
For J = Starcol To FLex.Cols - 1
.Cells(I + 2, J + 1).Value = FLex.TextMatrix(I, J)
Next
Next
'''''''''''''''''''''''''''''''
'写合并单元格的表头,表头第二行'
'''''''''''''''''''''''''''''''
For J = 3 To FLex.Cols Step 4
.Range(xlSheet.Cells(2, J), xlSheet.Cells(2, J + 3)).Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
.Cells(2, J) = FLex.TextMatrix(0, J)
Next
''''''''
'写标题'
''''''''
.Rows("1:1").RowHeight = 40
.Range(.Cells(1, 1), .Cells(1, FLex.Cols)).Select
With xlApp.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = True
End With
.Cells(1, 1) = title
End If
''''''''''''''
'标题字体加粗'
''''''''''''''
.Range(.Cells(1, 1), .Cells(1, FLex.Cols)).Select
With xlApp.ActiveCell.Characters.Font
.Name = "宋体"
.FontStyle = "常规"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
xlApp.Visible = True
Screen.MousePointer = 0
err:
If err.Number <> 0 Then
Screen.MousePointer = 0
MsgBox err.Description, vbInformation, "导出失败"
Exit Function
End If
End Function
Function ExporToExcelfile(strOpen As String, cn As Connection, Filename As String)
'strOpeny为MSHFlexgrid对应的SQL查询语句
'*********************************************************
'* 名称:ExporToExcel
'* 功能:直接导出数据集EXCE文件
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
On Error Resume Next
Dim xlsApp As Object
Dim lngj As Integer
Set Adopostcode = New Recordset
Adopostcode.Open strOpen, cn, adOpenStatic, adLockOptimistic
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Workbooks.Add (1)
If Adopostcode.RecordCount > 0 Then
Adopostcode.MoveFirst
xlsApp.ActiveWorkbook.ActiveSheet.Name = "test"
'保存字段名
For lngj = 0 To Adopostcode.Fields.Count - 1
xlsApp.ActiveSheet.Cells(1, lngj + 1).Value = Adopostcode.Fields(lngj).Name
' xlsApp.Range(Chr(lngj) & 1).AutoOutline
Next
xlsApp.Rows(1).Font.ColorIndex = 5
xlsApp.ActiveSheet.Range("A" & 2).CopyFromRecordset Adopostcode, Adopostcode.RecordCount, Adopostcode.Fields.Count
xlsApp.Cells.Select
xlsApp.Cells.EntireColumn.AutoFit
xlsApp.Range("A1").Select
End If
xlsApp.ActiveWorkbook.SaveAs Filename
xlsApp.Application.Quit
Set xlsApp = Nothing
MsgBox "文件已存为" & Filename, vbInformation, "信息"