求导出按钮代码

Henry D. Sy

http://www.office-cn.net/forum.p ... mp;page=2#pid389904

Henry D. Sy

Private Sub Command13_Click()
    Dim Qdf As DAO.QueryDef
    Dim rs As New ADODB.Recordset
    Dim strSQL As String, strCriteria As String
    Dim ctl As Control

    If IsNull(Me.Text14) Then
        MsgBox "Enter the Path frist"
        Me.Text14.SetFocus
        Exit Sub
    End If
    Set Qdf = CurrentDb.QueryDefs("Q")
    For Each ctl In Me.Controls
        If TypeOf ctl Is OptionButton Then
            If ctl Then
                strCriteria = strCriteria & "'" & ctl.Name & "',"
            End If
        End If
    Next
    If strCriteria = "" Then
        strSQL = "select * from 表1 order by 籍贯"
    Else
        strSQL = "select * from 表1 where 籍贯  in (" & strCriteria & ") order by 籍贯"
    End If
    Qdf.SQL = strSQL
    strSQL = "select distinct 籍贯 from Q"
    With rs
        .Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        Do While Not .EOF
            Set Qdf = CurrentDb.QueryDefs("Out")
            strSQL = "select * from 表1 where 籍贯='" & .Fields(0) & "'"
            Qdf.SQL = strSQL
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Out", Me.Text14, , .Fields(0)
            .MoveNext
        Loop
        .Close
    End With
    Set rs = Nothing
    Set Qdf = Nothing
End Sub

[ 本帖最后由 Henry D. Sy 于 2008-12-23 20:31 编辑 ]

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 编辑 ]

Henry D. Sy

需要引用 Microsoft Office 11