1 Private Sub GridToExl_Click()
2 On Error Resume Next
3 If DataGrid1.Columns.Count = 0 Then
4
5 MsgBox "抱歉，没有数据可供打印！", vbOKOnly, "提示"
6 Exit Sub
7 End If
8
9 Set cnn = New ADODB.Connection
10 cnn.Open Adodc1.ConnectionString
11
12 '获取DataGrid数据源
13 Dim rss As New ADODB.Recordset
14 rss.CursorLocation = adUseClient
15 rss.Open Adodc1.RecordSource, cnn, adOpenKeyset, adLockReadOnly
16
17 Dim R As Integer, c As Integer
18 Dim newxls As Excel.Application
19 Dim newbook As Excel.Workbook
20 Dim newsheet As Excel.Worksheet
21 Set newxls = CreateObject("Excel.Application") '创建excel应用程序,打开excel2000
22 Set newbook = newxls.Workbooks.Add '创建工作簿
23 Set newsheet = newbook.Worksheets(1) '创建工作表
24 newxls.Visible = True
25
26 '指定数据标题
27 For i = 0 To DataGrid1.Columns.Count - 1
28 newsheet.Cells(1, i + 1) = DataGrid1.Columns(i).Caption
29 Next i
30
31 '将 游标 移至顶行
32 If Not rss.EOF Then
33 rss.MoveFirst
34 End If
35
36 If rss.RecordCount > 0 Then
37 '复制字段名
38 For i = 1 To rss.Fields.Count
39 newsheet.Cells(1, i) = rss.Fields(i - 1).Name
40 Next i
41
42 '复制全部数据
43 newsheet.Range("A2").CopyFromRecordset rss
44
45
46 '设置工作表格式
47 newsheet.Cells.Font.Size = 10
48 newsheet.Columns.AutoFit
49 End If
50
51 ' 首行标题 格式设置
52 With newxls.Range("A1:H1")
53 With .Font
54 .Size = 10
55 .Bold = True
56
57 End With
58 End With
59 With newxls
60 .Range("A1:H1").Select
61 With .Selection
62 .HorizontalAlignment = xlCenter
63 .VerticalAlignment = xlCenter
64 End With
65 End With
66
67 newxls.ActiveSheet.Columns(9).Delete
68 newxls.ActiveSheet.Columns(2).Delete
69
70 With newsheet
71 ' .Columns("I:I").Select
72 ' Selection.Delete
73 ' .Columns("B:B").Select
74 ' Selection.Delete
75 .Columns("A:A").ColumnWidth = 15
76 End With
77
78
79 Set newxls = Nothing
80 Set newbook = Nothing
81 Set newsheet = Nothing
82
83 '关闭记录集及数据库连接，并释放变量
84 rss.Close
85 Set rss = Nothing
86 End Sub
