VB6.0 导出excel 方法源代码

VB6.0 导出excel 方法源代码

方法一：   

用Msflexgrid的Textmatrix属性取Msflexgrid中每一个单元格的内容，然后填到Excel表中，或者写成CSV格式   

    

方法二：   

直接把查询结果导出成Excel工作表

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   

            

End   Function   

==============================

'*********************************************************   

'*   名称：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   

一个按钮，点击出现对话框（对话框控件已经有），在硬盘里面查找excel文件（当然，后缀名是xls了），找到目标excel文件后，该excel文件里面是一些数据，点击确定，就可以把excel里面的内容保存到MSFlexGrid控件里面了

还有一个，按钮，点击后出现对话框，可以保存MSFlexGrid里面的东西到一个excel里面

谢谢大家了

用CommonDialog可以解决选定打开.xls文件问题 然后就是读取进去 哈哈 保存代码如下 

'添加command控件一个 MSFlexGrid控件一个 

Private Sub Command1_Click() 

On Error Resume Next 

Dim fileadd As String 

CommonDialog1.ShowOpen 

CommonDialog1.Filter = "xls文件(*.xls)|*.xls" '选择你要的文件 

fileadd = CommonDialog1.FileName 

MSHFlexGrid1.Redraw = False '关闭表格重画，加快运行速度 

Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象 

Set xlBook = xlApp.Workbooks.Open(fileadd) '打开已经存在的EXCEL工件簿文件 

xlApp.Visible = True '设置EXCEL对象可见（或不可见） 

Set xlsheet = xlBook.Worksheets("Sheet1") '设置活动工作表 

For R = 0 To MSHFlexGrid1.Rows - 1 '行循环 

For C = 0 To MSHFlexGrid1.Cols - 1 '列循环 

MSHFlexGrid1.Row = R 

MSHFlexGrid1.Col = C 

xlBook.Worksheets("Sheet1").Cells(R + 1, C + 1) = MSHFlexGrid1.Text '保存到EXCEL 

Next C 

Next R 

MSHFlexGrid1.Redraw = True 

xlApp.DisplayAlerts = False '不进行安全提示 

'Set xlsheet = Nothing 

'Set xlBook = Nothing 

'xlApp.Quit 

'Set xlApp = Nothing 

End Sub