'數據導出到EXCEL
 Public Sub ExporToExcel(strOpen As String)
 On Error GoTo inter_err
          Dim xlApp     As New Excel.Application
          Dim xlBook     As Excel.Workbook
          Dim xlsheet     As Excel.Worksheet
          Dim xlQuery     As Excel.QueryTable
          Dim rs_date As New ADODB.Recordset
          rs_date.CursorLocation = adUseClient
          rs_date.Open strOpen, CONN, 3, 3
          '如果沒有記錄,則不能導出
          If rs_date.RecordCount < 1 Then
                  MsgBox ("沒有記錄!")
                  Exit Sub
          End If

          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_date, xlsheet.Range("a1"))
          xlQuery.refresh
          '列名用數據窗體列頭中文顯示
            For j = 0 To grid_export.Cols - 1
                xlsheet.Cells(1, j + 1) = grid_export.TextMatrix(0, j)
            Next
            '***********************************
          xlApp.Application.Visible = True
          rs_date.Close
          Set xlApp = Nothing           '"交還控制給Excel
          Set xlBook = Nothing
          Set xlsheet = Nothing
   Exit Sub
inter_err:
    Call sub_error
  End Sub



Private Sub 導出_Click()
   Set grid_export = 生產電腦在庫查詢.Grid1     '設置導出哪個數據窗體的數據
   Call ExporToExcel(select_string)             '導出的數據為當前顯示的所有SQL數據
End Sub