SELECT 表名 = CASE WHEN A.COLORDER=1 THEN D.NAME ELSE '' END, 表备注 = CASE WHEN A.COLORDER=1 THEN ISNULL(F.VALUE,'') ELSE '' END, 列序号 = A.COLORDER, 列名称 = A.NAME, 标识 = CASE WHEN COLUMNPROPERTY(A.ID,A.NAME,'ISIDENTITY')=1 THEN '√ ' ELSE '' END, 主键 = CASE WHEN EXISTS(SELECT 1 FROM SYSOBJECTS WHERE XTYPE='PK' AND PARENT_OBJ=A.ID AND NAME IN ( SELECT NAME FROM SYSINDEXES WHERE INDID IN( SELECT INDID FROM SYSINDEXKEYS WHERE ID=A.ID AND COLID=A.COLID))) THEN '√' ELSE '' END, 类型 = B.NAME, 字节 = A.LENGTH, 长度 = COLUMNPROPERTY(A.ID,A.NAME,'PRECISION'), 小数位 = ISNULL(COLUMNPROPERTY(A.ID,A.NAME,'SCALE'),0), 允许空 = CASE WHEN A.ISNULLABLE=1 THEN '√ 'ELSE '' END, 默认值 = ISNULL(E.TEXT,''), 列备注 = ISNULL(G.[VALUE],'') FROM SYSCOLUMNS A LEFT JOIN SYSTYPES B ON A.XUSERTYPE=B.XUSERTYPE INNER JOIN SYSOBJECTS D ON A.ID=D.ID AND D.XTYPE='U ' --AND D.NAME<>'DTPROPERTIES' LEFT JOIN SYSCOMMENTS E ON A.CDEFAULT=E.ID LEFT JOIN sys.extended_properties G ON A.ID=G.major_id AND A.COLID=G.minor_id LEFT JOIN sys.extended_properties F ON D.ID=F.major_id AND F.minor_id=0 --where D.NAME='tbname' --查询这个表 ORDER BY A.ID,A.COLORDER 写个游标,用bcp创建导出excel
我先给你发第一种方法.这种方法不保存输出的结果.只是把结果直接输出到Excel.但有一缺点...就是windows本身在不程序的数据传递间存在着一个缓存区域.而且小得可怜,且不可调....所以数据量大往往会有溢出错误..在XP常有这种情况.Private Sub EXCEL() '这里我直接定义成按钮,你也可以定义成公共模块用别一个按钮去激活它 'Public Function ExporToExcel2(strOpen As String) 公共模块的写法,然后在另一个按钮定义strOpen的内容 '在另一按钮写ExporToExcel2("select * from table")Dim Rs_Data As New ADODB.Recordset Dim Irowcount As Long Dim Icolcount As Long Dim LngPageSize As Integer Dim IntPageCount As Integer Dim mIndex As Integer Dim Rs_Temp As New ADODB.Recordset Dim mRow As Integer Dim mCol As Integer Dim strStruct As String Dim m_Title As Integer Dim ArrTitle As Integer Dim strOpen As StringstrOpen = "select * from part order by id" //你输入的数据表 Dim xlApp As New EXCEL.Application Dim xlBook As EXCEL.Workbook Dim xlSheet As EXCEL.Worksheet Dim xlQuery As EXCEL.QueryTable
If Rs_Data.State = 1 Then Rs_Data.Close Rs_Data.CursorLocation = adUseClient Rs_Data.Open strOpen, ConnectString, adOpenKeyset, adLockReadOnly '有句话有点有一个参数很重要,但我忘了..你查一下这种写法的变法,不好意思啊 Set Rs_Data.ActiveConnection = Nothing strStruct = Replace(strOpen, "Select", "Select Top 0", 1, 1, vbTextCompare) With Rs_Data '记录总数 Irowcount = .RecordCount '栏位总数 Icolcount = .Fields.Count End With '设置每页最大行数 LngPageSize = 10000 '我这里是为保证不出错,故意写少一点的行数,excel最大行数是65536.你可以试试65535会不会出错. IntPageCount = Round(Irowcount / LngPageSize, 0) If IntPageCount * LngPageSize < Irowcount Then IntPageCount = IntPageCount + 1 End If Set xlApp = CreateObject("Excel.Application") Set xlBook = Nothing Set xlSheet = Nothing Set xlBook = xlApp.Workbooks().ADD xlApp.Visible = True '添加Sheet数量 mIndex = IntPageCount - xlBook.Sheets.Count If mIndex > 0 Then Set xlSheet = xlBook.Worksheets("sheet3") xlBook.Sheets.ADD , xlSheet, mIndex End If If IntPageCount > 1 Then If Rs_Temp.State = 1 Then Rs_Temp.Close Rs_Temp.CursorLocation = adUseClient Rs_Temp.Open strStruct, ConnectString, adOpenKeyset, adLockBatchOptimistic Set Rs_Temp.ActiveConnection = Nothing End If For mIndex = 1 To IntPageCount Set xlSheet = xlBook.Worksheets("sheet" + CStr(mIndex)) xlSheet.Select xlSheet.Range("A1").Value = "正在处理第 " + CStr(mIndex) + " 页数据,请稍等......" If IntPageCount > 1 Then If Rs_Temp.RecordCount > 0 Then Rs_Temp.CancelBatch End If Rs_Data.MoveFirst Rs_Data.Move LngPageSize * (mIndex - 1), 1 mRow = 1 Do Until (mRow > LngPageSize Or Rs_Data.EOF) Rs_Temp.AddNew For mCol = 0 To Rs_Data.Fields.Count - 1 Rs_Temp(mCol).Value = Rs_Data(mCol).Value Next Rs_Data.MoveNext mRow = mRow + 1 Loop Else Set Rs_Temp = Rs_Data.Clone End If Irowcount = Rs_Temp.RecordCount '添加查询语句,导入EXCEL资料 Set xlQuery = xlSheet.QueryTables.ADD(Rs_Temp, xlSheet.Range("a1")) xlQuery.Refresh Next
Set xlSheet = xlBook.Worksheets("sheet1") xlSheet.Select xlApp.Application.Visible = True Set xlApp = Nothing '"交还控制给Excel Set xlBook = Nothing Set xlSheet = Nothing If Rs_Temp.State = 1 Then Rs_Temp.Close Set Rs_Temp = Nothing If Rs_Data.State = 1 Then Rs_Data.Close Set Rs_Data = Nothing End Sub 先研究吧...迟一点再发输出文件的方法给你
SELECT
表名 = CASE WHEN A.COLORDER=1 THEN D.NAME ELSE '' END,
表备注 = CASE WHEN A.COLORDER=1 THEN ISNULL(F.VALUE,'') ELSE '' END,
列序号 = A.COLORDER,
列名称 = A.NAME,
标识 = CASE WHEN COLUMNPROPERTY(A.ID,A.NAME,'ISIDENTITY')=1 THEN '√ ' ELSE '' END,
主键 = CASE WHEN EXISTS(SELECT 1 FROM SYSOBJECTS WHERE XTYPE='PK' AND PARENT_OBJ=A.ID AND NAME IN (
SELECT NAME FROM SYSINDEXES WHERE INDID IN(
SELECT INDID FROM SYSINDEXKEYS WHERE ID=A.ID AND COLID=A.COLID))) THEN '√' ELSE '' END,
类型 = B.NAME,
字节 = A.LENGTH,
长度 = COLUMNPROPERTY(A.ID,A.NAME,'PRECISION'),
小数位 = ISNULL(COLUMNPROPERTY(A.ID,A.NAME,'SCALE'),0),
允许空 = CASE WHEN A.ISNULLABLE=1 THEN '√ 'ELSE '' END,
默认值 = ISNULL(E.TEXT,''),
列备注 = ISNULL(G.[VALUE],'')
FROM
SYSCOLUMNS A
LEFT JOIN SYSTYPES B ON A.XUSERTYPE=B.XUSERTYPE
INNER JOIN SYSOBJECTS D ON A.ID=D.ID AND D.XTYPE='U ' --AND D.NAME<>'DTPROPERTIES'
LEFT JOIN SYSCOMMENTS E ON A.CDEFAULT=E.ID
LEFT JOIN sys.extended_properties G ON A.ID=G.major_id AND A.COLID=G.minor_id
LEFT JOIN sys.extended_properties F ON D.ID=F.major_id AND F.minor_id=0
--where D.NAME='tbname' --查询这个表
ORDER BY A.ID,A.COLORDER 写个游标,用bcp创建导出excel
'Public Function ExporToExcel2(strOpen As String) 公共模块的写法,然后在另一个按钮定义strOpen的内容
'在另一按钮写ExporToExcel2("select * from table")Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Long
Dim Icolcount As Long
Dim LngPageSize As Integer
Dim IntPageCount As Integer
Dim mIndex As Integer
Dim Rs_Temp As New ADODB.Recordset
Dim mRow As Integer
Dim mCol As Integer
Dim strStruct As String
Dim m_Title As Integer
Dim ArrTitle As Integer
Dim strOpen As StringstrOpen = "select * from part order by id" //你输入的数据表 Dim xlApp As New EXCEL.Application
Dim xlBook As EXCEL.Workbook
Dim xlSheet As EXCEL.Worksheet
Dim xlQuery As EXCEL.QueryTable
If Rs_Data.State = 1 Then Rs_Data.Close Rs_Data.CursorLocation = adUseClient Rs_Data.Open strOpen, ConnectString, adOpenKeyset, adLockReadOnly '有句话有点有一个参数很重要,但我忘了..你查一下这种写法的变法,不好意思啊 Set Rs_Data.ActiveConnection = Nothing strStruct = Replace(strOpen, "Select", "Select Top 0", 1, 1, vbTextCompare)
With Rs_Data '记录总数 Irowcount = .RecordCount '栏位总数 Icolcount = .Fields.Count End With '设置每页最大行数 LngPageSize = 10000 '我这里是为保证不出错,故意写少一点的行数,excel最大行数是65536.你可以试试65535会不会出错. IntPageCount = Round(Irowcount / LngPageSize, 0) If IntPageCount * LngPageSize < Irowcount Then IntPageCount = IntPageCount + 1 End If Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().ADD
xlApp.Visible = True
'添加Sheet数量 mIndex = IntPageCount - xlBook.Sheets.Count If mIndex > 0 Then Set xlSheet = xlBook.Worksheets("sheet3") xlBook.Sheets.ADD , xlSheet, mIndex End If If IntPageCount > 1 Then If Rs_Temp.State = 1 Then Rs_Temp.Close Rs_Temp.CursorLocation = adUseClient Rs_Temp.Open strStruct, ConnectString, adOpenKeyset, adLockBatchOptimistic Set Rs_Temp.ActiveConnection = Nothing End If For mIndex = 1 To IntPageCount Set xlSheet = xlBook.Worksheets("sheet" + CStr(mIndex)) xlSheet.Select xlSheet.Range("A1").Value = "正在处理第 " + CStr(mIndex) + " 页数据,请稍等......" If IntPageCount > 1 Then If Rs_Temp.RecordCount > 0 Then Rs_Temp.CancelBatch End If Rs_Data.MoveFirst Rs_Data.Move LngPageSize * (mIndex - 1), 1 mRow = 1 Do Until (mRow > LngPageSize Or Rs_Data.EOF) Rs_Temp.AddNew For mCol = 0 To Rs_Data.Fields.Count - 1 Rs_Temp(mCol).Value = Rs_Data(mCol).Value Next Rs_Data.MoveNext mRow = mRow + 1 Loop Else Set Rs_Temp = Rs_Data.Clone End If Irowcount = Rs_Temp.RecordCount
'添加查询语句,导入EXCEL资料
Set xlQuery = xlSheet.QueryTables.ADD(Rs_Temp, xlSheet.Range("a1")) xlQuery.Refresh Next
With xlSheet '如果这个整个不要,那你输出的时候就会是你数据表的字段名,这个是用来替代你的字段名的注解...
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体" '这个地方你注意看了,如果你需要的话就算一下,cells(1,1)指的一行一列.下面如此类推....
.Range(.Cells(1, 1), .Cells(1, 1)).Value = "客户名称"
.Range(.Cells(1, 2), .Cells(1, 2)).Value = "物料编码"
.Range(.Cells(1, 3), .Cells(1, 3)).Value = "产品编码"
.Range(.Cells(1, 4), .Cells(1, 4)).Value = "物料名称"
.Range(.Cells(1, 5), .Cells(1, 5)).Value = "SMT代码"
.Range(.Cells(1, 6), .Cells(1, 6)).Value = "封装形式"
.Range(.Cells(1, 7), .Cells(1, 7)).Value = "物料类型"
.Range(.Cells(1, 8), .Cells(1, 8)).Value = "物料规格"
.Range(.Cells(1, 9), .Cells(1, 9)).Value = "备注说明"
.Range(.Cells(1, 10), .Cells(1, 10)).Value = "操作员"
.Range(.Cells(1, 11), .Cells(1, 11)).Value = "客户代码"
.Range(.Cells(1, 12), .Cells(1, 12)).Value = "修改日期"
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
'设表格边框样式
End With
Set xlSheet = xlBook.Worksheets("sheet1") xlSheet.Select xlApp.Application.Visible = True Set xlApp = Nothing '"交还控制给Excel Set xlBook = Nothing Set xlSheet = Nothing If Rs_Temp.State = 1 Then Rs_Temp.Close Set Rs_Temp = Nothing If Rs_Data.State = 1 Then Rs_Data.Close Set Rs_Data = Nothing
End Sub
先研究吧...迟一点再发输出文件的方法给你