Public Function Rs_To_Excel(Rs_data As ADODB.Recordset)
On Error Resume Next
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Dim Irowcount As Long
Dim Icolcount As Long
Dim xlApp As New excel.Application
Dim xlBook As excel.Workbook
Dim xlSheet As excel.Worksheet
Dim xlQuery As excel.QueryTable
If Rs_data.RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = Rs_data.RecordCount
'字段总数
Icolcount = Rs_data.Fields.Count
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"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With
xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
'设置中文标题
Dim zddz As ADODB.Recordset, i As Integer, bm As String
Set zddz = New ADODB.Recordset
Dim sql As String
sql = "select * from zddz where bm='" & getbm(Rs_data.Source) & "'"
zddz.Open sql, conn, 3, adLockReadOnly
'If zddz.BOF = True Then Exit Function
For i = 0 To Rs_data.Fields.Count - 1
zddz.movefirst
zddz.Find ("zdm='" & Rs_data.Fields(i).Name & "'")
xlSheet.Cells(1, i + 1) = Trim(zddz("zdzwmc"))
Next
'xlSheet.Cells(2, 2) = "sjqw"
'With xlSheet.PageSetup
' .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称：" ' & Gsmc
' .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
' .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
' .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
' .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
' .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
' End With
xlApp.Visible = True
'xlSheet.PrintPreview
xlApp.Application.Visible = True
'xlApp.Quit
Set xlApp = Nothing '"交还控制给Excel
' Set xlBook = Nothing
' Set xlSheet = Nothing
Exit Function
doerr:
MsgBox (Err.Description)
End Function
Public Function msgd_ExporToExcel(MSHFlexGrid1 As MSHFlexGrid)
On Error GoTo exitt
Dim jsexcel As New excel.Application
Dim jsbook As excel.Workbook
Dim jssheet As excel.Worksheet
Dim str As String
Set jsexcel = CreateObject("Excel.Application")
Set jsbook = Nothing
Set jssheet = Nothing
Set jsbook = jsexcel.Workbooks().add
Set jssheet = jsbook.Worksheets("sheet1")
jsexcel.Visible = True
Dim i As Long
Dim Row As Long
Dim k As Integer
Dim Col As Integer
Row = MSHFlexGrid1.Rows
Col = MSHFlexGrid1.Cols
If Row >= 1 Then
For i = 1 To Row
For k = 1 To Col - 1
If k > 26 Then
str = Chr(65 + k \ 26 - 1) + Chr(65 + k - (k \ 26) * 26 - 1)
Else
str = Chr(65 + k - 1)
End If
jsexcel.ActiveSheet.Range(str + CStr(i)) = MSHFlexGrid1.TextMatrix(i - 1, k)
DoEvents
Next k
Next i
End If
With jssheet
.Range(.Cells(1, 1), .Cells(1, Col)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Col)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Row, Col - 1)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With
jsexcel.Application.Visible = True
Set jsexcel = Nothing '"交还控制给Excel
Set jsbook = Nothing
Set jssheet = Nothing
'打印设置
'With jssheet
'.PageSetup
'.LeftFooter = "&""宋体,常规""第&P页" '页
'.CenterFooter = "制表时间：" + CStr(Date)
'.RightFooter = "制表人："
'End With
exitt:
MsgBox ("错误！")
End Function
回复Comments
作者:
{commentrecontent}