1181
社区成员
- 主页
导入数据到EXCEL中
通过查询后，我的listbox中最多将有700条记录，请问，我如何在一按钮上编写程序，使得将listbox中的数据导入到EXCEL中。
...全文
请发表友善的回复…
发表回复
Andy__Huang 2004-10-22
'請你自己加個CommonDialog控件
Private Sub Command3_Click()
Dim objFileSystem As Object
Dim objExcelText As Object
Dim strTableString As String, i As Integer, strFileName As String
Dim pubConn As New ADODB.Connection
Dim rsTable As New ADODB.Recordset
Dim strConn As String
Dim strSQL As String
strConn = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=develop; password=12345;Data Source=ServerNmae"
pubConn.Open strConn
rsTable.CursorLocation = adUseClient
strSQL = "select top 10 * from gate_register"
rsTable.Open strSQL, pubConn, adOpenDynamic, adLockOptimistic
For i = 0 To rsTable.Fields.Count - 1
strTableString = strTableString & rsTable.Fields(i).Name & Chr(9) '獲取字段名
Next
strTableString = strTableString & rsTable.GetString '字段名+數據庫的記錄
cmDialog.CancelError = False
cmDialog.FileName = "FileName" '默認生成的文件名
cmDialog.DialogTitle = "Save Export File"
cmDialog.Filter = "Excel (*.xls)|*.xls|文本文件(*.DBF)|*.DBF|檔案文件(*.doc)|*.doc|所有文件(*.*)|*.*"
cmDialog.DefaultExt = "*.xls"
cmDialog.ShowSave
strFileName = cmDialog.FileName
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objExcelText = objFileSystem.createtextfile(strFileName, True)
objExcelText.writeline (strTableString)
objExcelText.Close
Set objFileSystem = Nothing
End Sub
Private Sub Command3_Click()
Dim objFileSystem As Object
Dim objExcelText As Object
Dim strTableString As String, i As Integer, strFileName As String
Dim pubConn As New ADODB.Connection
Dim rsTable As New ADODB.Recordset
Dim strConn As String
Dim strSQL As String
strConn = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=develop; password=12345;Data Source=ServerNmae"
pubConn.Open strConn
rsTable.CursorLocation = adUseClient
strSQL = "select top 10 * from gate_register"
rsTable.Open strSQL, pubConn, adOpenDynamic, adLockOptimistic
For i = 0 To rsTable.Fields.Count - 1
strTableString = strTableString & rsTable.Fields(i).Name & Chr(9) '獲取字段名
Next
strTableString = strTableString & rsTable.GetString '字段名+數據庫的記錄
cmDialog.CancelError = False
cmDialog.FileName = "FileName" '默認生成的文件名
cmDialog.DialogTitle = "Save Export File"
cmDialog.Filter = "Excel (*.xls)|*.xls|文本文件(*.DBF)|*.DBF|檔案文件(*.doc)|*.doc|所有文件(*.*)|*.*"
cmDialog.DefaultExt = "*.xls"
cmDialog.ShowSave
strFileName = cmDialog.FileName
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objExcelText = objFileSystem.createtextfile(strFileName, True)
objExcelText.writeline (strTableString)
objExcelText.Close
Set objFileSystem = Nothing
End Sub
shpyw 2004-10-22
不好意思，因为我从来没有写过这种导入的程序，所以不是很懂啊，能不能帮我写得详细一点
最好拿来就用，很急，用了再说，下次再好好的学一下
在这个listbox中，每一条记录形式是这样的“编号：1234567 姓名：张三”
我只需将以上内容导入进EXCEL就行了。谢谢大家了。
最好拿来就用，很急，用了再说，下次再好好的学一下
在这个listbox中，每一条记录形式是这样的“编号：1234567 姓名：张三”
我只需将以上内容导入进EXCEL就行了。谢谢大家了。
hansong_ll 2004-10-22
给你一段把ListView中数据导入Excel中的代码.
Option Explicit
Private Const xlCenter = -4108
Private Const xlNone = -4142
Private Const xlContinuous = 1
Private Const xlDiagonalDown = 5
Private Const xlDiagonalUp = 6
Private Const xlEdgeLeft = 7
Private Const xlEdgeTop = 8
Private Const xlEdgeBottom = 9
Private Const xlEdgeRight = 10
Private Const xlInsideVertical = 11
Private Const xlInsideHorizontal = 12
Private Function CheckExcel() As Boolean
Dim oExcel As Object
On Error GoTo errHandle
CheckExcel = False
Set oExcel = CreateObject("Excel.Application")
If Val(oExcel.Version) < 7 Then
Err.Raise vbObjectError
Else
CheckExcel = True
End If
Set oExcel = Nothing
Exit Function
errHandle:
Set oExcel = Nothing
Err.Clear
MsgBox "请确认在本机已经安装了Microsoft Excel 97或以上版本", vbOKOnly + vbCritical, "系统提示"
End Function
Public Sub ListViewExportToExcel(lv As ListView, Optional ByVal psTitle As String, Optional ByVal pbShow As Boolean = True)
Dim oExcel As Object
Dim oSheet As Object
Dim iRowCount As Integer
Dim i As Integer, k As Integer
If CheckExcel = False Then Exit Sub
On Error GoTo errHandle
Set oExcel = CreateObject("Excel.Application")
Call oExcel.Workbooks.Add
Set oSheet = oExcel.Sheets(1)
If pbShow = True Then
oExcel.Visible = True
End If
'生成标题
iRowCount = 1
If Trim(psTitle) <> "" Then
oSheet.Cells(iRowCount, 1) = psTitle
End If
'合并居中
With oSheet
.Range(.Cells(iRowCount, 1), .Cells(iRowCount, lv.ColumnHeaders.Count)).Merge '这儿要改报表的栏位数
.Range(.Cells(iRowCount, 1), .Cells(iRowCount, 1)).HorizontalAlignment = xlCenter '-4108
End With
'生成列标题
iRowCount = iRowCount + 1
For i = 1 To lv.ColumnHeaders.Count
oSheet.Cells(iRowCount, i) = lv.ColumnHeaders.Item(i).Text
Next i
'画表格线
If lv.ListItems.Count > 0 Then
With oSheet.Range(oSheet.Cells(iRowCount, 1), oSheet.Cells(iRowCount + lv.ListItems.Count, lv.ColumnHeaders.Count)) '这儿要改报表的栏位数
.Borders(xlDiagonalDown).LineStyle = xlNone '-4142
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlContinuous '1
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
End If
'生成内容
iRowCount = iRowCount + 1
For i = 1 To lv.ListItems.Count
oSheet.Cells(iRowCount, 1) = lv.ListItems.Item(i).Text
For k = 1 To lv.ColumnHeaders.Count - 1
oSheet.Cells(iRowCount, k + 1) = lv.ListItems.Item(i).SubItems(k)
Next k
iRowCount = iRowCount + 1
Next i
'显示
oExcel.Visible = True
Set oExcel = Nothing
Exit Sub
errHandle:
oExcel.Visible = True
Set oExcel = Nothing
Call RaiseError("ClsExportToExcel.ListViewExportToExcel")
End Sub
Option Explicit
Private Const xlCenter = -4108
Private Const xlNone = -4142
Private Const xlContinuous = 1
Private Const xlDiagonalDown = 5
Private Const xlDiagonalUp = 6
Private Const xlEdgeLeft = 7
Private Const xlEdgeTop = 8
Private Const xlEdgeBottom = 9
Private Const xlEdgeRight = 10
Private Const xlInsideVertical = 11
Private Const xlInsideHorizontal = 12
Private Function CheckExcel() As Boolean
Dim oExcel As Object
On Error GoTo errHandle
CheckExcel = False
Set oExcel = CreateObject("Excel.Application")
If Val(oExcel.Version) < 7 Then
Err.Raise vbObjectError
Else
CheckExcel = True
End If
Set oExcel = Nothing
Exit Function
errHandle:
Set oExcel = Nothing
Err.Clear
MsgBox "请确认在本机已经安装了Microsoft Excel 97或以上版本", vbOKOnly + vbCritical, "系统提示"
End Function
Public Sub ListViewExportToExcel(lv As ListView, Optional ByVal psTitle As String, Optional ByVal pbShow As Boolean = True)
Dim oExcel As Object
Dim oSheet As Object
Dim iRowCount As Integer
Dim i As Integer, k As Integer
If CheckExcel = False Then Exit Sub
On Error GoTo errHandle
Set oExcel = CreateObject("Excel.Application")
Call oExcel.Workbooks.Add
Set oSheet = oExcel.Sheets(1)
If pbShow = True Then
oExcel.Visible = True
End If
'生成标题
iRowCount = 1
If Trim(psTitle) <> "" Then
oSheet.Cells(iRowCount, 1) = psTitle
End If
'合并居中
With oSheet
.Range(.Cells(iRowCount, 1), .Cells(iRowCount, lv.ColumnHeaders.Count)).Merge '这儿要改报表的栏位数
.Range(.Cells(iRowCount, 1), .Cells(iRowCount, 1)).HorizontalAlignment = xlCenter '-4108
End With
'生成列标题
iRowCount = iRowCount + 1
For i = 1 To lv.ColumnHeaders.Count
oSheet.Cells(iRowCount, i) = lv.ColumnHeaders.Item(i).Text
Next i
'画表格线
If lv.ListItems.Count > 0 Then
With oSheet.Range(oSheet.Cells(iRowCount, 1), oSheet.Cells(iRowCount + lv.ListItems.Count, lv.ColumnHeaders.Count)) '这儿要改报表的栏位数
.Borders(xlDiagonalDown).LineStyle = xlNone '-4142
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlContinuous '1
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
End If
'生成内容
iRowCount = iRowCount + 1
For i = 1 To lv.ListItems.Count
oSheet.Cells(iRowCount, 1) = lv.ListItems.Item(i).Text
For k = 1 To lv.ColumnHeaders.Count - 1
oSheet.Cells(iRowCount, k + 1) = lv.ListItems.Item(i).SubItems(k)
Next k
iRowCount = iRowCount + 1
Next i
'显示
oExcel.Visible = True
Set oExcel = Nothing
Exit Sub
errHandle:
oExcel.Visible = True
Set oExcel = Nothing
Call RaiseError("ClsExportToExcel.ListViewExportToExcel")
End Sub