求导出按钮代码

Henry D. Sy

1. Dim ctl As Control
   
2. Private Sub Command13_Click()
   
3.     Dim Qdf As DAO.QueryDef
   
4.     Dim rs As New ADODB.Recordset
   
5.     Dim strSQL As String, strCriteria As String
   
6.     Dim strPath As String
   
7.     Dim diaFs As FileDialog
   
8.     Set diaFs = Application.FileDialog(msoFileDialogSaveAs)
   
9.     With diaFs
   
10.         .Title = "导出为........"
    
11.         .Show
    
12.     End With
    
13.     If diaFs.SelectedItems.Count > 0 Then
    
14.         strPath = diaFs.SelectedItems(1)
    
15.     End If
    
16.     If strPath = "" Then
    
17.         strPath = CurrentProject.Path & "\out.xls"
    
18.     ElseIf Right(strPath, 4) <> ".xls" Then
    
19.         strPath = strPath & ".xls"
    
20.     End If
    
21.     Set Qdf = CurrentDb.QueryDefs("Q")
    
22.     For Each ctl In Me.Controls
    
23.         If TypeOf ctl Is OptionButton Then
    
24.             If ctl Then
    
25.                 strCriteria = strCriteria & "'" & ctl.Name & "',"
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     If strCriteria = "" Then
    
30.         strSQL = "select * from 表1 order by 籍贯"
    
31.     Else
    
32.         strSQL = "select * from 表1 where 籍贯 in (" & strCriteria & ") order by 籍贯"
    
33.     End If
    
34.     Qdf.SQL = strSQL
    
35.     strSQL = "select distinct 籍贯 from Q"
    
36.     With rs
    
37.         Set Qdf = CurrentDb.QueryDefs("Out")
    
38.         .Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    
39.         Do While Not .EOF
    
40. 
    
41.             strSQL = "select * from 表1 where 籍贯='" & .Fields(0) & "'"
    
42.             Qdf.SQL = strSQL
    
43.             DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Out", strPath, , .Fields(0)
    
44.             .MoveNext
    
45.         Loop
    
46.         .Close
    
47.     End With
    
48.     Set rs = Nothing
    
49.     Set Qdf = Nothing
    
50.     Set diaFs = Nothing
    
51. End Sub
    
52. 
    
53. Private Sub Form_Load()
    
54.     For Each ctl In Me.Controls
    
55.         If TypeOf ctl Is OptionButton Then
    
56.             ctl = False
    
57.         End If
    
58.     Next
    
59. End Sub

复制代码

[ 本帖最后由 Henry D. Sy 于 2008-12-24 08:11 编辑 ]

qp370982

Dim diaFs As FileDialog提示用户定义类型未定义

Henry D. Sy

需要引用 Microsoft Office 11