Rabu, 23 Juli 2014

Re: [MS_AccessPros] Re: VBA Issue with looping through recordset

 

Bill, 

Still struggling with this issue. Your code was out of my league. I tried to get it working but it was just was a mess after I botched it up. I think that my issue is that I have lines of code in the wrong place.  
 
Jim Wagner



On Friday, July 11, 2014 2:34 PM, "wrmosca@comcast.net [MS_Access_Professionals]" <MS_Access_Professionals@yahoogroups.com> wrote:


 
Jim

I had a report that I had to output as HTML. I worked around the crazy way that Access does it by using DoCmd.OutputTo . It's a big work-around but it works. You don't get all those extra files and the format looks pretty much like the report.

I end up storing the cleaned up HTML as a memo in a table and then sending out that memo field as the "report", but you could just save the memo as a text file with an HTML file extension.

Here is my entire routine. Let me know if you need help with it. 

BE SURE TO ADD MS Scripting Runtime TO YOUR CODE REFERENCES.


Public Function RptToHTML(strRptFile, datMidnight As Date, strEntityID As String)
'Purpose  : Save report as HTML for email.
'DateTime : 3/25/2013 07:52
'Author   : Bill Mosca
'Requires : MS Scripting Runtime
    Dim strHTML As String
    Dim intFile As Integer
    Dim fso As FileSystemObject
    Dim f As TextStream
    Dim fldr As Folder
    Dim strFolderPath As String
    Const ForReading = 1
    Const ForWriting = 2
    Dim strLine As String
    Dim i As Long
    Dim strFilePath As String
    Dim intpages As Integer

    If gbolErrorTrapOff = False Then On Error GoTo err_PROC
    
    'Delete record if it exists.
    CurrentDb.Execute "DELETE FROM tblStatDailyCensusHTML " _
        & "WHERE DateCensus = #" & datMidnight & "# " _
        & "AND EntityID = '" & strEntityID & "'", dbSeeChanges

    Set fso = CreateObject("Scripting.FileSystemObject")
    strFolderPath = Environ("TEMP") & "\FRS_Temp"

    'Delete folder if it exists so all files are removed.
    If fso.FolderExists(strFolderPath) Then
        fso.DeleteFolder strFolderPath, True
    End If

    fso.CreateFolder strFolderPath
    Set fldr = fso.GetFolder(strFolderPath)
    strFilePath = fldr.path & "\DailyCensus_" & Format(datMidnight, "yyyymmdd") & ".html"

    DoCmd.OutputTo acOutputReport, strRptFile, acFormatHTML, strFilePath

    Set f = fso.OpenTextFile(strFilePath, ForReading)

    strHTML = f.ReadAll
    
    'Clean up quotes and nul character at end of HTML
'    strHTML = Replace(Replace(Replace(strHTML, """", """"""), vbNewLine, ""), vbNullChar, "")
    strHTML = Replace(Replace(strHTML, vbNewLine, ""), vbNullChar, "")
    CurrentDb.Execute "INSERT INTO tblStatDailyCensusHTML(DateCensus, CensusHTML, EntityID) " _
        & "Values(#" & datMidnight & "#,'" & strHTML & "', '" & strEntityID & "')", dbSeeChanges
    

exit_PROC:
    On Error Resume Next
    Set f = Nothing
    Set fldr = Nothing
    Set fso = Nothing
    Exit Function

err_PROC:
    Dim strErrMsg As String
    Dim lngIcon As Long

    Select Case Err.Number
        Case 2501
            'Open cancelled.
            strErrMsg = "No information for selected filter."
            lngIcon = vbOKOnly + vbInformation
        Case Else
            gProcName = "RptToHTML"
            glngErrNum = Err.Number
            gstrErrDescr = Err.Description
            glngLineNum = Erl
            Call ErrorLog("basDailyCensusEmail")
    End Select

    If strErrMsg <> "" Then MsgBox strErrMsg, lngIcon, _
       GetSummaryInfo("Title", False)

    Resume exit_PROC

End Function

Bill Mosca


---In MS_Access_Professionals@yahoogroups.com, <luvmymelody@yahoo.com> wrote :

Hello all,

I have a procedure that I would like to work correctly. I would like the code to loop through the recordset and store the report in a folder as an html document. For the least part, the code does loop through the recordset and outputs the report as an html by the name of the contact person. The issue is that the output is crazy. The output folder contains the 143 reports  but the output folder stores them as below.

John Brown.html
John BrownPage1.html
John BrownPage2.html
John BrownPage3.html
continues to page 143 then starts at the next persons name and continues the pattern with the first name. 
The html report shows the report and then has navigational buttons such as below

First  Previous  Next  Last
which does navigate between each of the contact names even though the name of the html document is the first persons name.

I think that there is a line out or in the loop incorrectly. There are some commented lines because I have been trying all kinds of things in the developing version. 

Thank You for any help.


Private Sub cmdEmissionsVPOCValidation_Click()

' This process generates the reports for the vehicle's which have their emissions due on the date given by the user on the main form and sends
' report for the vpoc validation email.

Dim RS_1 As DAO.Recordset
Dim db As DAO.Database
Dim strSQL As String
Dim sSQL As String
Dim NoReports As Integer

' It may happen that for a given time period, there may be no verhicles with emissions due.  In that case, no emails will be sent out.
' This may lead to a blank screen.  To help the user understand, we use the flag NoReports.  It is set to 1 initially, and cleared to 0 when a vehicle is due emission.
' At the end of the email process, this flag is checked.  If this flag is set to 1, it means that there was not a single report that was emailed out and therefore the user is
' suitably informed.
NoReports = 1

Set db = CurrentDb

' Select distinct [Contact Name] from the VehicleEmissions table
' The file name of the report is the name of Point of Contact.html

' Disable all warnings
DoCmd.SetWarnings False

' When the data is imported from the CMMS webpage, there may be some records that have [Next Emissions Test Date] field empty in the VehicleEmissions table.
' These records must be deleted as the emissions date cannot be tested for these records.
' The following query deletes all records from VehicleEmissions that have the [Next Emissions Test Date] set to 'Null'
'DoCmd.OpenQuery "qry_Del Null Next Emissions Dt"

strSQL = "SELECT DISTINCT [Contact Name] FROM VehiclesWithEmission"

Set RS_1 = db.OpenRecordset(strSQL, dbOpenDynaset)
RS_1.MoveFirst

' Delete existing reports before generating new ones
' a is just a dummy variable
a = DeleteReports()
'gg
' myPath stores the path of the directory which stores the outputted reports
myPath = "S:\Fleet Services Reporting\Outputted Reports\VPOC Validation\"


' For all the distinct [Contact Name] in table VehicleEmissions
Do While Not RS_1.EOF
    ' Extract the Contact name
    Contact = RS_1![Contact Name]

    ' Obtain all records from qryVehicleEmissionsDueReport, for the given Contact Name and records that have next emissions due on or before the date entered on the Main Switchboard
    'sSQL = "SELECT * FROM qryVehicleEmissionsDueReport Where (((qryVehicleEmissionsDueReport.[Contact Name])))= """ & "" & [Contact]
    
    'sSQL = "SELECT * FROM VehiclesWithEmission Where ((VehiclesWithEmission.[Contact Name]))= """ & "" & [Contact] Is Not Null
    sSQL = "SELECT  * FROM VehiclesWithEmission Where VehiclesWithEmission.[Contact Name]= """ & "" & [Contact] & "" & """"
    ' Obtain the number of records resulting from the above SQL Query
    Set RS_2 = db.OpenRecordset(sSQL)

    ' If records exist, i.e, if there are any vehicles belonging to the [Contact Name], that have their emissions due,
    If RS_2.RecordCount <> 0 Then
        ' Clear the flag, since we have at least one vehicle due its emissions
        NoReports = 0

        ' Open the report to be emailed
        DoCmd.OpenReport "rptVehiicleEmissionsDataRequestVPOCValidationForHTML", acViewReport

        ' The above report is the entire report - for all contacts and vehicles
        ' We would like to select only the records belonging to the [Contact Name] that have their emissions due
        ' Therefore, we change the source of the report by the query - sSQL - as defined below
        ' Select the "Email Body" (editable by user) and all other required fields from the VehicleEmissionDueReport for the given [Contact Name] and Emissions due date

        ' This statement sets the criteria as mentioned above

        sSQL = "SELECT tblVehicleSurveyAnnouncementEmailBody.[Vehicle Survey Email Body], * FROM VehiclesWithEmission, tblVehicleSurveyAnnouncementEmailBody Where (((VehiclesWithEmission.[Contact Name])=""" & "" & [Contact] & """" & ")"

        ' This statement sets the record source to the criteria
        Reports.Item("rptVehiicleEmissionsDataRequestVPOCValidationForHTML").RecordSource = sSQL ' which is a report

        ' Save the Report as .html at myPath with a file name of the [Contact Name]
        ' We also append the '.html' file extension at the end of the file name
        DoCmd.OutputTo acOutputReport, "rptVehiicleEmissionsDataRequestVPOCValidationForHTML", acFormatHTML, myPath & Contact & ".html", False
    '
        ' Close the Report
        DoCmd.Close acReport, "rptVehiicleEmissionsDataRequestVPOCValidationForHTML" 'which is a report
    End If

    ' Process the next record
    RS_1.MoveNext
Loop

DoCmd.SetWarnings True

' Inform the user
If NoReports = 1 Then
    MsgBox "     No vehicles are due for emissions in this period"
Else
    MsgBox "                                        All reports have been stored" & vbCrLf & " " & vbCrLf & "Do not forget to review emails before working online and sending reports"
    ' Enable the Emissions Email button on Main Switchboard
    ' The button was disabled because the user has to re-generate the reports before they can be emailed out
    Me.cmd_EmissionsEmail.Enabled = True
End If
End Sub





Jim Wagner

 


__._,_.___

Posted by: Jim Wagner <luvmymelody@yahoo.com>
Reply via web post Reply to sender Reply to group Start a New Topic Messages in this topic (3)

Yahoo Groups
Improved Group Homepage!
The About page of your Group now gives you a heads up display of recent activity, including the latest photos and files

Yahoo Groups
Control your view and sort preferences per Yahoo Group
You can now control your default Sort & View Preferences for Conversations, Photos and Files in the membership settings page.


.

__,_._,___

Tidak ada komentar:

Posting Komentar