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