彰化一整天的論壇

 找回密碼
 立即註冊
查看: 661|回復: 4

如何將TrueDBgrid中的資料匯出到Excel

[複製鏈接]
發表於 2014-6-11 10:19:17 | 顯示全部樓層 |閱讀模式
之前都是用SQL語法,將結果輸出到文字檔,副檔案存成.xls,這樣Excel 2003就會自動開啟檔案,但是到了Excel2007以後,就是開啟此類型檔案都會出現對話框,於是想說可不可以直接就將TrueDBgrid中顯示的資料直接輸出到Excel,可以用CreateObject("Excel.Application")的方式來解決,但是執行程式的這台電腦要有安裝Excel才不會出問題。
excel_2007_txt_01.jpg
1.會出現"您正在嘗試開啟....."的對話框
excel_2007_txt_02.jpg
2.程式碼
excel_2007_txt_03.jpg
3.呼叫方式
  1. Sub TrueDBgridToExcel(ByVal tdb As TDBGrid, ByVal Title As String)
  2.     On Error GoTo Err_WriteFile
  3.    
  4.     Dim oExcel As Object
  5.     Dim oBook As Object
  6.     Dim oSheet As Object
  7.     Dim i, j As Integer
  8.    
  9.     Set oExcel = CreateObject("Excel.Application")
  10.     Set oBook = oExcel.Workbooks.Add
  11.    
  12.     Set oSheet = oBook.Worksheets(1)
  13.    
  14.     tdb.MoveFirst
  15.    
  16.    
  17.     n = 1
  18.     For i = 0 To tdb.Columns.Count - 1
  19.         oSheet.cells(n, i + 1) = tdb.Columns(i).Caption
  20.     Next
  21.    
  22.     Do While Not tdb.EOF
  23.         n = n + 1
  24.         For i = 0 To tdb.Columns.Count - 1
  25.             oSheet.cells(n, i + 1) = tdb.Columns(i)
  26.         Next
  27.         tdb.MoveNext
  28.     Loop
  29.    
  30.     saveDlg.DialogTitle = "產生資料EXCEL檔案..."
  31.     saveDlg.FilterIndex = 1
  32.     saveDlg.FileName = Title + "_" + CStr(Year(Now())) + CStr(Month(Now())) + CStr(Day(Now())) + ".xls"
  33.     saveDlg.CancelError = True
  34.     saveDlg.flags = cdlOFNOverwritePrompt
  35.     saveDlg.ShowSave
  36.    
  37.     If Len(saveDlg.FileName) > 0 Then
  38.       sDFileName = saveDlg.FileName
  39.       If Dir(sDFileName) <> vbNullString Then
  40.         Kill sDFileName
  41.       End If
  42.     Else
  43.       Exit Sub
  44.     End If
  45.    
  46.     oBook.saveas saveDlg.FileName
  47.    
  48.     oExcel.quit
  49.    
  50.     Set oSheet = Nothing
  51.     Set oBook = Nothing
  52.     Set oExcel = Nothing
  53.    
  54.    
  55.     MsgBox "檔案產生完畢!"
  56.     Screen.MousePointer = 0
  57.     Exit Sub
  58.    
  59. Err_WriteFile:
  60.     If Err.Number = 32755 Then
  61.         Screen.MousePointer = 0
  62.         Exit Sub
  63.     Else
  64.         sErrDesc = item_Of_Str(1, Err.Description, ":")
  65.         MsgBox "檔案產生失敗!" + Error(Err), 64, "錯誤訊息"
  66.         Screen.MousePointer = 0
  67.     End If
  68. End Sub
複製代碼



回復

使用道具 舉報

 樓主| 發表於 2019-8-8 09:49:16 | 顯示全部樓層
因為要將副程式放到Module,所以修改在副程式中產生對話框元件.
  1. Sub TrueDBgridToExcel(ByVal tdb As TDBGrid, ByVal Title As String)
  2.     'by tsaimh 20190807新增 使用者電腦要安裝excel才可以使用
  3.     '將TrueDBgrid中的資料匯出到Excel
  4.     On Error GoTo Err_WriteFile
  5.    
  6.     Dim oExcel As Object
  7.     Dim oBook As Object
  8.     Dim oSheet As Object
  9.     Dim i, j As Integer
  10.    
  11.     Dim saveDlg As Object
  12.    
  13.     Set oExcel = CreateObject("Excel.Application")
  14.     Set oBook = oExcel.Workbooks.Add
  15.    
  16.     Set saveDlg = CreateObject("MSComDlg.CommonDialog")
  17.    
  18.     Set oSheet = oBook.Worksheets(1)
  19.    
  20.     tdb.MoveFirst
  21.    
  22.    
  23.     n = 1
  24.     For i = 0 To tdb.Columns.Count - 1
  25.         oSheet.cells(n, i + 1) = tdb.Columns(i).Caption
  26.     Next
  27.    
  28.     Do While Not tdb.EOF
  29.         n = n + 1
  30.         For i = 0 To tdb.Columns.Count - 1
  31.             oSheet.cells(n, i + 1) = tdb.Columns(i)
  32.         Next
  33.         tdb.MoveNext
  34.     Loop
  35.    
  36.     saveDlg.DialogTitle = "產生資料EXCEL檔案..."
  37.     saveDlg.FilterIndex = 1
  38.     saveDlg.FileName = Title + "_" + CStr(Year(now())) + CStr(Month(now())) + CStr(Day(now())) + ".xls"
  39.     saveDlg.CancelError = True
  40.     saveDlg.Flags = cdlOFNOverwritePrompt
  41.     saveDlg.ShowSave
  42.    
  43.     If Len(saveDlg.FileName) > 0 Then
  44.       sDFileName = saveDlg.FileName
  45.       If Dir(sDFileName) <> vbNullString Then
  46.         Kill sDFileName
  47.       End If
  48.     Else
  49.       Exit Sub
  50.     End If
  51.    
  52.     oBook.SaveAs saveDlg.FileName
  53.    
  54.     oExcel.quit
  55.    
  56.     Set oSheet = Nothing
  57.     Set oBook = Nothing
  58.     Set oExcel = Nothing
  59.    
  60.    
  61.     MsgBox "檔案產生完畢!"
  62.     Screen.MousePointer = 0
  63.     Exit Sub
  64.    
  65. Err_WriteFile:
  66.     If Err.Number = 32755 Then
  67.         Screen.MousePointer = 0
  68.         Exit Sub
  69.     Else
  70.         sErrDesc = item_Of_Str(1, Err.Description, ":")
  71.         MsgBox "檔案產生失敗!" + Error(Err), 64, "錯誤訊息"
  72.         Screen.MousePointer = 0
  73.     End If
  74. End Sub
複製代碼


回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  |网站地图

GMT+8, 2019-8-18 10:36 , Processed in 0.114400 second(s), 21 queries .

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表