vb导入数据到mysql_VB6操作EXCEL导入数据库

'-----------------

'从数据从数据库导出至excel，并弹出保存文件对话框

'-------------------

Private Function FunExpExcel()

On Error GoTo hErr

'注意引用excel组件，也可以直接定义为对象object

Dim xlsApp As New Excel.Application

Dim xlsWb As Excel.Workbook

Dim xlsWs As Excel.Worksheet

Dim strFilePath As String

Dim strFileNm As String

Dim iColIdx As Integer

Dim objTmp As Object

'创建excel

Set xlsApp = CreateObject("Excel.Application")

xlsApp.Visible = False

xlsApp.SheetsInNewWorkbook = 1 '定义表格个数

'新增一张表格， 这里可以增加多张表

Set xlsWb = xlsApp.Workbooks.Add

'指定sheet，指定第一张，如果有多张，可以具体指定哪一个

Set xlsWs = xlsWb.Worksheets(1)

'xlsApp.Visible = False

xlsWs.Activate

xlsWs.Select

'第一行为标题

xlsWs.Cells(1, 1).Value = "表格标题"

'第二行为列名,第一列列名“序号”

xlsWs.Cells(2, 1).Value = "序号"

....

xlsWs.Cells(2, n).Value = "序号"

'如果是datagrid，可以直接用对应的列名

'For iColIdx = 0 To Me.grdQryInst.Columns.Count - 1

'    xlsWs.Cells(2, iColIdx + 2).Value = Me.datagrid1.Columns(iColIdx).Caption

'Next

'设置第一列序号为数字格式

xlsWs.Columns("A:A").NumberFormatLocal = "0_ "

'设置其它列为文本格式,函数NumToChar26能将数字转化为对应的excel列名，如2->B,3->C,自已实现

'xlsWs.Columns(NumToChar26(2) & ":" & NumToChar26(Me.datagrid1.Columns.Count)).NumberFormatLocal = "@"

'----这里打开数据库，查询数据略，自己实现，如果是datagrid,则可以按下面的方法

'Dim RS As ADODB.Recordset

'Set RS = Me.datagrid1.DataSource

'从第三行开始写明细数据

RS.MoveFirst

For iRowIdx = 0 To RS.RecordCount - 1

xlsWs.Cells(iRowIdx + 3, 1).Value = CStr(iRowIdx + 1)

'对第一行，按顺序逐列写单元格

For iColIdx = 0 To RS.Fields.Count - 1

xlsWs.Cells(iRowIdx + 3, iColIdx + 2).Value = RS.Fields(iColIdx).Value

Next

RS.MoveNext

Next

'-----写完数据，下面设置导出excel格式

'标题格式设置

Set objTmp = xlsWs.Range(xlsWs.Cells(1, 1), xlsWs.Cells(1, iColIdx + 2 - 1))

objTmp.Merge　'合并单元格

'标题排版

With objTmp

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

With objTmp.Font

.Name = "宋体"

.Size = 18

End With

'第2行开始，设置边框，字体与标题不同

Set objTmp = xlsApp.Range(xlsWs.Cells(2, 1), xlsWs.Cells(iRowIdx + 3 - 1, iColIdx + 2 - 1))

With objTmp.Font

.Name = "宋体"

.Size = 10

.Underline = xlUnderlineStyleNone

.ColorIndex = xlAutomatic

End With

objTmp.Borders(xlDiagonalDown).LineStyle = xlNone

objTmp.Borders(xlDiagonalUp).LineStyle = xlNone

With objTmp.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With objTmp.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With objTmp.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With objTmp.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With objTmp.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With objTmp.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

'设置列宽，自动扩展

For iColIdx = 1 To Me.grdQryInst.Columns.Count + 1

xlsWs.Columns(NumToChar26(iColIdx) & ":" &　NumToChar26(iColIdx)).EntireColumn.AutoFit

Next

'弹出保存文件对话框，要在窗体上增加commondialog控件，控件命名dlgFile

Me.dlgFile.DialogTitle = "保存至"

Me.dlgFile.Flags = &H200

Me.dlgFile.DefaultExt = ".xls"

Me.dlgFile.Filter = "Excel数据文件 *.xls|*.xls" '过滤器

Me.dlgFile.InitDir = App.Path

Me.dlgFile.FileName = strFileNm & ".xls"

Me.dlgFile.ShowSave

If Err <> 32755 Then strFilePath = dlgFile.FileName

If "" <> strFilePath Then

xlsWb.SaveAs strFilePath

Else

mdlPub.ShowInfo "文件未保存"

End If

xlsWb.Close

xlsApp.Quit

Set xlsWs = Nothing

Set xlsWb = Nothing

Set xlsApp = Nothing

FunExpExcel = 0 '成功则返回0

mdlPub.ShowInfo "已保存至" & strFilePath

Exit Sub

hErr:

FunExpExcel = -1'失败则返回1

If Err.Number <> 0 Then mdlPub.ShowErrMsg "导出错"

If Not (xlsWb Is Nothing) Then Set xlsWs = Nothing

If Not (xlsWb Is Nothing) Then

xlsWb.Close

Set xlsWb = Nothing

End If

If Not (xlsWb Is Nothing) Then

xlsApp.Quit

Set xlsApp = Nothing

End If

End Function