|
Dim ctl As Control
Private Sub Command13_Click()
Dim Qdf As DAO.QueryDef
Dim rs As New ADODB.Recordset
Dim strSQL As String, strCriteria As String
Dim strPath As String
Dim diaFs As FileDialog
Set diaFs = Application.FileDialog(msoFileDialogSaveAs)
With diaFs
.Title = "导出为........"
.Show
End With
If diaFs.SelectedItems.Count > 0 Then
strPath = diaFs.SelectedItems(1)
End If
If strPath = "" Then
strPath = CurrentProject.Path & "\out.xls"
ElseIf Right(strPath, 4) <> ".xls" Then
strPath = strPath & ".xls"
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
Set Qdf = CurrentDb.QueryDefs("Out")
.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
Do While Not .EOF
strSQL = "SELECT 姓名, 性别, 籍贯, 政治面貌, 名族 from 表1 where 籍贯='" & .Fields(0) & "'"
Qdf.SQL = strSQL
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Out", strPath, , .Fields(0)
.MoveNext
Loop
.Close
End With
Set rs = Nothing
Set Qdf = Nothing
Set diaFs = Nothing
End Sub |
|