如何将MSHFlexgrid控件里面内容另存为Excel文件啊

[homebysea]

我想实现这样的一个功能，点击按钮，出现另存为对话框，文件格式列表为xls，即Excel格式的。然后点击保存按钮，则将MSHFlexgrid控件里面内容按按照顺序存为Excel文件。

希望各位帮忙。

[hhjjhjhj]

一格格地输出到EXCEL去啊

[abc10]

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, "信息"

End Function

[abc10]

以上为mshflexgrid控件可以用ADO + SQL查询语句
以下为直接一个一个写到Excel

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

[flc]

帮你UP

[since1990]

up

[qifanghcy]

Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
........

不显示就调用: xlApp.Visible=False '不让EXCEL显示出来
.....[执行保存代码]
set xlApp=Nothing
xlApp.Quit
这样就不会显示EXCEL了!

[MSSQL]

楼上的几位说的也不是没有道理。
不过如果机子上没有EXCEL的话就麻烦了。
我个人认为还是存为HTML文件后将文件扩展名改为：。XLS好点了。

[wangzhenzhu1975]

用EXCEL的对象速度太慢,建议不使用,:)

[doudou8090]

U{P

[bigpig]

up

[homebysea]

Qifanghcy的方法我大概知道，可是我就是不知道怎么写那段保存的代码，下面是我尝试着写的，肯定不对，因为刚才的那个表格虽然有内容了，但是没有保存，而这个保存的只是一个空的表格。请大家继续帮忙。

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

[homebysea]

如果只是默认保存在运行的程序目录中，保存的那一快代码怎么写啊。

真是不好意思，麻烦各位了。

[明镜台2014]

关注！！

[homebysea]

谢谢 abc10 的解答，很详细

还想问一下，如果点击按钮，出现另存为对话框，然后输入Excel的文件名，点击保存后把上述数据保存，Excel文件就不用打开了，这样的代码应该怎么写。

就是省略号的部分不会写。

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

[homebysea]

我的意思是，实现点击保存按钮，就调用 ExportToExcelByFlexGrid ，用输入的文件名保存文件。

[homebysea]

自己顶一下，没有人回复就结账了。

[qjqmoney]

abc10(什么时候才会有五个角？) 的方法是可行的，我以前一直都是这样把数据转化为Excel的，速度也不是很慢。

[Hermit007]

abc10(什么时候才会有五个角？) 发的代码中,如果要让导出的EXCEL列宽能自动适应,如果做到这点?