Question

我有一个从SQL查询字符串生成HTML表的函数。

我希望使用我的所有过滤器获取当前活动报告的查询字符串，并从中生成HTML表。然后，我可以将其包含在我的Outlook电子邮件中。

我正在尝试创建一个执行以下操作的函数：

打开MS Outlook。
打开已制作的模板。
使用从当前活动报告生成的表替换模板中的字符串。
将当前有效的报告添加为PDF附件。

这是我的代码：

Option Compare Database
Option Explicit

Private Sub emailSupplier_Click()
    ' Define the parameters
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim templateExpediter As String
    Dim msgBody As String
    Dim strFind As String
    Dim strNew As String
    Dim currentReport As Report
    Dim query As String

    ' Set the params
    Set currentReport = Screen.ActiveReport
    Set query = currentReport.RecordSource
    Set templateExpediter = "D:\Templates\expediter.oft"
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItemFromTemplate(templateExpediter)

    With objOutlookMsg
       ' Add the To recipient(s) to the message.
       Set objOutlookRecip = .Recipients.Add("firstmail")
       objOutlookRecip.Type = olTo

       ' Add the CC recipient(s) to the message.
       Set objOutlookRecip = .Recipients.Add("secondamail")
       objOutlookRecip.Type = olCC

       ' Set the Subject, Body, and Importance of the message.
       .BodyFormat = olFormatHTML
       .Subject = "Urgent Delivery Request - " & Date
       .Importance = olImportanceHigh 'High importance

       strFind = "{X}"
       ' Get HTML from the query for the record set
       strNew = GenHTMLTable(query)
       .HTMLBody = Replace(.HTMLBody, strFind, strNew)

       ' Resolve each Recipient's name.
       For Each objOutlookRecip In .Recipients
          objOutlookRecip.Resolve
       Next

       ' Should we display the message before sending?
       'If DisplayMsg Then
          '.Display
       'Else
          .Save
          .Display
       'End If

    End With
    Set objOutlook = Nothing

End Sub

我的问题是如何将当前的活动报告记录源或设置转换为活动的HTML表格？

或者至少使用过滤器获取SQL查询，以便我可以使用该函数生成 QueryToHtmlTable(Query)。

编辑2 - 好的，所以我得到了带过滤器的正确SQL。现在看来这个从sql生成HTML的函数给了我一个错误'项目在集合中找不到'

Function GenHTMLTable(sQuery As String, Optional bInclHeader As Boolean = True) As String
    On Error GoTo Error_Handler
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim prm As DAO.Parameter
    Dim rs As DAO.Recordset
    Dim fld As DAO.Field
    Dim sHTML As String

    Set db = CurrentDb
    Set qdf = db.QueryDefs(sQuery)

    For Each prm In qdf.Parameters
        prm = Eval(prm.Name)
    Next prm

    Set rs = qdf.OpenRecordset
    With rs
        sHTML = "<table>" & vbCrLf
        If bInclHeader = True Then
            'Build the header row if requested
            sHTML = sHTML & vbTab & "<tr>" & vbCrLf
            For Each fld In rs.Fields
                sHTML = sHTML & vbTab & vbTab & "<th>" & fld.Name & "</th>" & vbCrLf
            Next
            sHTML = sHTML & vbTab & "</tr>" & vbCrLf
        End If
        If .RecordCount <> 0 Then
            Do While Not .EOF
                'Build a row for each record in the recordset
                sHTML = sHTML & vbTab & "<tr>" & vbCrLf
                For Each fld In rs.Fields
                    sHTML = sHTML & vbTab & vbTab & "<td>" & fld.Value & "</td>" & vbCrLf
                Next
                sHTML = sHTML & vbTab & "</tr>" & vbCrLf
                .MoveNext
            Loop
        End If
        sHTML = sHTML & "</table>"
    End With

    GenHTMLTable = sHTML

Error_Handler_Exit:
    On Error Resume Next
    If Not fld Is Nothing Then Set fld = Nothing
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    If Not db Is Nothing Then Set db = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GenHTMLTable" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

ANSWER

    Dim currentReport As Report
    Dim strSQL As String

    ' Set the params
    Set currentReport = Screen.ActiveReport
    ' Replace double qoutes with single qoutes
    strSQL = Replace(currentReport.RecordSource, ";", "") & " AND " & currentReport.filter
    strSQL = Replace(strSQL, Chr(34), "'")
    strSQL = Replace(strSQL, ")", "")
    strSQL = Replace(strSQL, "(", "")

Answer 1

如果我理解你的需要，

打开报告进行预览后，您想要抓住用于生成报告的过滤器，然后将其与报告一起邮寄。

我建议有一个生成报告然后邮寄的功能

Function GenerateAndMailReport
    Dim strRecordSourceSample
    strRecordSourceSample = "reportQuery"
    Dim strFilterSample
    strFilterSample = "[SomeID] = 109902"
    Call DoCmd.OpenReport("reportName", acViewPreview, , strFilterSample)
    Call emailSupplier(strRecordSourceSample, strFilterSample) 'Passing the filter and record source to your mailing function
End Function

- 编辑 -

如果您已有权访问报告对象，则可以抓取

currentReport.RecordSource
currentReport.Filter

https://msdn.microsoft.com/VBA/Access-VBA/articles/report-recordsource-property-access https://msdn.microsoft.com/VBA/Access-VBA/articles/report-filter-property-access

他们都会返回你可以用来打开记录集的字符串

Dim SQL As String
Dim QRY As New ADODB.Recordset

SQL = currentReport.RecordSource & " WHERE " & currentReport.Filter
QRY.Open SQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
While Not oQRY.EOF
HtmlLogicHere()
Wend
oQRY.Close

如果你的记录集中已经有一个WHERE子句，请小心，连接会有所不同。

Answer 2

如果在OpenReport方法中设置了报告过滤器属性，或者右键单击快捷菜单：

strSQL = Replace(Reports!report.RecordSource, ";","") & " WHERE " & Reports!report.Filter

不幸的是，如果报告RecordSource是一个动态参数化查询，参数值将不会在RecordSource sql中，只有变量引用。

MS Access将Recordsource转换为SQL

2 个答案: