[求助]怎样将子窗体查询到的内容作为附件发送电邮？以前牧人做了个OUTPUT Recordse

secowu

[求助]怎样将子窗体查询到的内容作为附件发送电邮？

以前牧人做了个OUTPUT Recordset导出很好用

能不能改下，加个参数X

X=1,则导出当前子窗体内容数据

X=2,则电邮当前子窗体内容数据（以附件方式，XLS格式）

secowu

举手之劳，功德无量

secowu

呵呵，修改大师牧人的作品，调试成功，大师看看，还有什么可改进的。

Option Compare Database

Option Explicit

Public Sub DealSubForm(frmMainForm As Form, frmSubFormName As String, a As String)

'*****************************************************

'使用示例：DealSubForm Me, Me.订单子窗体.Name,1

'2005-11-03 修改来自牧人(LucasLynn)的大作

'最后面的参数a，如果为1,则将当前查询到的数据以附件XLS格式进行发送电子邮件

'最后面的参数a，如果为2,则将当前查询到的数据以XLS格式导出并自动启动以便下一步处理

'******************************************************

Dim strSQL As String

Dim strRecordSource As String

Dim strLinkChildfields As String

Dim strLinkMasterFields As String

Dim strFilter As String

Dim blnFilterOn As Boolean

Dim strLinkSQL As String

Dim Rs As Recordset

Dim Qd As QueryDef

On Error GoTo Outputerr:

Set Rs = frmMainForm.Controls(frmSubFormName).Form.RecordsetClone

Set Qd = CurrentDb.CreateQueryDef("订单明细查询")

strRecordSource = frmMainForm.Controls(frmSubFormName).Form.RecordSource

strLinkChildfields = frmMainForm.Controls(frmSubFormName).LinkChildFields

strLinkMasterFields = frmMainForm.Controls(frmSubFormName).LinkMasterFields

strFilter = frmMainForm.Controls(frmSubFormName).Form.Filter

blnFilterOn = frmMainForm.Controls(frmSubFormName).Form.FilterOn

If strLinkChildfields <> "" Then

    Select Case Rs.Fields(strLinkChildfields)

    Case dbChar

        strLinkSQL = strLinkChildfields & "='" & frmMainForm.Controls(strLinkMasterFields) & "'"

    Case Else

        strLinkSQL = strLinkChildfields & "=" & frmMainForm.Controls(strLinkMasterFields)

    End Select

End If

If blnFilterOn = True Then

    If strLinkSQL <> "" Then

        strLinkSQL = strLinkSQL & " and " & strFilter

    Else

        strLinkSQL = strFilter

    End If

End If

If InStr(strRecordSource, "Select ") > 0 Then

    strSQL = Left(strRecordSource, Len(strRecordSource) - 2)

Else

    strSQL = "Select * From " & strRecordSource

End If

If InStr(strRecordSource, " where ") > 0 Then

    If strLinkSQL <> "" Then

        strSQL = strSQL & " and " & strLinkSQL

    End If

Else

    If strLinkSQL <> "" Then

        strSQL = strSQL & " where " & strLinkSQL

    End If

End If

Qd.SQL = strSQL

If a = 1 Then

DoCmd.SendObject acSendQuery, "订单明细查询", acFormatXLS, , "", "", Date & "查询订单明细", "附件是" & Date & "查询订单明细情况，请查收", True, ""

DoCmd.DeleteObject acQuery, "订单明细查询"



Else: a = 2

DoCmd.OutputTo acOutputQuery, "订单明细查询", acFormatXLS, Date & "止订单明细查询.XLS", True

DoCmd.DeleteObject acQuery, "订单明细查询"



End If

DoCmd.DeleteObject acQuery, "订单明细查询"

Rs.Close

Set Rs = Nothing

Exit Sub

Outputerr:

    Rs.Close

    Set Rs = Nothing

    If IsNull(DLookup("[Name]", "MSysObjects", "[Name] = '订单明细查询'")) = False Then

         DoCmd.DeleteObject acQuery, "订单明细查询"

    End If

    MsgBox Err.Description

End Sub

特别感谢牧人大师的源码才有这个功能的增加

[此贴子已经被作者于2005-11-4 19:17:34编辑过]