Access VBA creating a HTML report from a HTML template

[colval]

Hi

I am working in a company who have a database that uses report html templates that use code to withdraw data from the database. In the HTML template the code below is used.

What I cannot work out is the area below which creates part of the report SampleMaterialRiskBand and SamplePrisorityRiskBand. I cannot find these fileds in the table TableSamples at all.

It displays for example 3 for SampleMaterialRisk and gives a SampleMaterialRiskBand as 'Very Low', I need to change the RiskBands but cannot find them in the table. As anyone any idea of what it is doing and where I can find the SampleMaterialRiskBand. Thanks


TableSamples.SampleMaterialRisk, MaterialRiskString(TableSamples.SampleMaterialRisk) As SampleMaterialRiskBand, TableSamples.SamplePriorityRisk, PriorityRiskString(TableSamples.SamplePriorityRisk) As SamplePriorityRiskBand





{# UseFile report.css #} {# LoadQuery SELECT TableSamples.SampleID, GetSampleRefFromID(TableSamples.SampleID) As SampleRef, TableSamples.SampleDate, VListAreas.ItemValue As SampleArea, VListFloors.ItemValue As SampleFloor, TableSamples.SampleRoom, VListComponents.ItemValue As SampleComponent, TableSamples.SampleSurveyType, ListAsbestosType.Description As SampleAsbestosType, nz(ListAnalysis.Description,"NADIS") As SampleAnalysis, nz(ListCondition.Description,"NADIS") As SampleCondition, nz(ListFriability.Description,"NADIS") As SampleFriability, nz(ListPosition.Description,"NADIS") As SamplePosition, nz(ListTreatment.Description,"NADIS") As SampleTreatment, TableSamples.SampleMaterialRisk, MaterialRiskString(TableSamples.SampleMaterialRisk) As SampleMaterialRiskBand, TableSamples.SamplePriorityRisk, PriorityRiskString(TableSamples.SamplePriorityRisk) As SamplePriorityRiskBand, TableSamples.SampleRecommendations, VListLabs.ItemValue As SampleLab, VListRemovalCosts.ItemValue As SampleRemovalCost, VListNextInspectionDates.ItemValue As SampleNextInspectionDate, VListActions.ItemValue As SampleAction, TableSamples.SamplePhotoID, TableSites.SiteSurveyorsName As SampleSurveyorsName FROM (((((((((((((TableSamples LEFT JOIN VListAreas ON TableSamples.SampleAreaID=VListAreas.ID) LEFT JOIN VListFloors ON TableSamples.SampleFloorID=VListFloors.ID) LEFT JOIN VListComponents ON TableSamples.SampleComponentID=VListComponents.ID) LEFT JOIN ListAsbestosType ON TableSamples.SampleAsbestosTypeID=ListAsbestosType.ID) LEFT JOIN ListAnalysis ON TableSamples.SampleAnalysisID=ListAnalysis.ID) LEFT JOIN ListCondition ON TableSamples.SampleConditionID=ListCondition.ID) LEFT JOIN ListFriability ON TableSamples.SampleFriabilityID=ListFriability.ID) LEFT JOIN ListPosition ON TableSamples.SamplePositionID=ListPosition.ID) LEFT JOIN ListTreatment ON TableSamples.SampleTreatmentID=ListTreatment.ID) LEFT JOIN VListLabs ON TableSamples.SampleLabID=VListLabs.ID) LEFT JOIN VListRemovalCosts ON TableSamples.SampleRemovalCostID=VListRemovalCosts.ID) LEFT JOIN VListNextInspectionDates ON TableSamples.SampleNextInspectionDateID=VListNextInspectionDates.ID) LEFT JOIN VListActions ON TableSamples.SampleActionID=VListActions.ID) LEFT JOIN TableSites ON TableSamples.SampleSiteID=TableSites.SiteID WHERE TableSamples.SampleSiteID={!SiteID!} ORDER BY TableSamples.SampleID #} {# ForEachRecord #} {# IfNotFirstRecord #}

 

[sfm6s524]

It looks like MaterialRiskString is a function in one of your modules. Open any of your code modules and do a search (CTRL F) for 'function MaterialRiskString' in 'Current Project.'

Ken

 

[colval]

Thanks for the reply.

I did a search for anything with Risk in it but dont recall anything like 'Function MaterialRiskString' I can take a look tomorrow, by current project I assume you mean the Database we are using?

Thanks again

 

[vbajock]

I would take a look at the C# source code "report.css". I think those are C# classes.

 

[colval]

Hi sfm6s524

Thanks I found the code in the function 'function MaterialRiskString' in 'Current Project' in a module and we can chane the ratings there.

Can I ask one more question, from the code I gave how did you know there was a function called 'function MaterialRiskString'

Thanks for your help

 

[vbajock]

You did not give a much on the context of this statement:

MaterialRiskString(TableSamples.SampleMaterialRisk) As SampleMaterialRiskBand

but it looks to be a declaration of a function named MaterialRiskString that takes TableSamples.SampleMaterialRisk as a parameter and returns the object SampleMaterialRiskBand after it executes. It is not in the syntax that would work in Access VBA, which made me think it was referencing some C# object code, but if you found it in a module and it solved your problem, that's great.

 

[colval]

Sorry if I do not explain it to good, as far as I am aware it is purely using VBA code. I thought it had solved the problem, I found the code

Public Function MaterialRiskString(risk As Variant) As String
MaterialRiskString = ""
If IsNull(risk) Or risk = -1 Then Exit Function
If risk = 0 Then MaterialRiskString = "NADIS"
If risk >= 1 Then MaterialRiskString = "Very Low"
If risk >= 10 Then MaterialRiskString = "Low"
If risk >= 14 Then MaterialRiskString = "Medium"
If risk >= 19 Then MaterialRiskString = "High"
End Function

I then changed the code to read

Public Function MaterialRiskString(risk As Variant) As String
MaterialRiskString = ""
If IsNull(risk) Or risk = -1 Then Exit Function
If risk = 0 Then MaterialRiskString = "NADIS"
If risk <= 4 Then MaterialRiskString = "Very Low"
If risk <= 6 Then MaterialRiskString = "Low"
If risk <= 9 Then MaterialRiskString = "Medium"
If risk >= 10 Then MaterialRiskString = "High"
End Function

The databse as a function which creates a MDE file which we work from therafter. However I can see when filling in data it as reverted back to the higher numbers. We need it to goby the second codes.

If I go into the MDB I worked from it is still the lower levels (shown in my changes). So any ideas why it is keeping its intial figures.

Thanks

 

[vbajock]

Public Function MaterialRiskString(risk As Variant) As String
MaterialRiskString = ""
If IsNull(risk) Or risk = -1 Then Exit Function
If risk = 0 Then MaterialRiskString = "NADIS"
If risk <= 4 Then MaterialRiskString = "Very Low"
If risk <= 6 Then MaterialRiskString = "Low"
If risk <= 9 Then MaterialRiskString = "Medium"
If risk >= 10 Then MaterialRiskString = "High"



End Function

I would re-write the code to use Select Case instead of "If" for easier maintenance and better clarity

Public Function MaterialRiskString(risk As Variant) As String

on error goto err_h

MaterialRiskString = ""


If IsNull(risk) Or risk = -1 Then
Goto Exit_h
Endif

Select Case Risk >=0


Case risk = 0
MaterialRiskString = "NADIS"

Case risk >0 and risk <= 4
MaterialRiskString = "Very Low"

Case case risk>4 and risk <= 6
MaterialRiskString = "Low"

Case risk>6 and risk <= 9
MaterialRiskString = "Medium"

Case risk >= 10 MaterialRiskString = "High"

End Select

'******
Exit_h:
'******
Exit Function

'****
Err_h:
'*****
msgbox Error$

Exit Function

End Function

 

[colval]

Thanks for the suggestion. I am not an heavy programmer so could you advise;

Can you use this code in Access 2010 modules? I assume I replace the existing Functon with IF in with your code. Is this correct. When it creates the MDE will it still keep you code.

Thanks for your help

 

[vbajock]

Should work in 2010. Don't know the details of your MDE setup, but it should not affect anything, make a backup and then test it first.

 

[colval]

Thanks for the code

Do I just over write the existing function in the module with the code you suggest and test. I assusme this will not effect the other function code in the modules.

Also do you think it will keep the code when I make the MDE from the master MDB.

Thanks

 

[colval]

sorry vbajock I seemed to have posted the question twice - I will try the code in test mode on Monday and let you know the results.

Thanks again

 

[colval]

VBAjock I tried the new code and still got the same result ubnfortunately. No matter what I put in programming, when I create the MDE it reverts back to the old one

Public Function MaterialRiskString(risk As Variant) As String MaterialRiskString = "" If IsNull(risk) Or risk = -1 Then Exit Function If risk = 0 Then MaterialRiskString = "NADIS" If risk >= 1 Then MaterialRiskString = "Very Low" If risk >= 10 Then MaterialRiskString = "Low" If risk >= 14 Then MaterialRiskString = "Medium" If risk >= 19 Then MaterialRiskString = "High"End Function


Any ides where else it could hold this when I distribute. The distribute button uses and Event procedure when clicked opnds a form called dsitrib

Then on here you click a button called Lock and Export and this uses an event procedure and this as

Private Sub ButtonDistribute_Click()
Me.Refresh
DistributePackage Me!CheckCopyData.Value
End Sub

Whne you press the button the folder options appear where you want to save the files to. A message appears to say it is exported and then within your folder the MDE is there.

Do you have any ideas how we can get it to keep the code we need instead of reverting back to the old.

Thanks

 

[sfm6s524]

colval, I'm confused about what you mean by "create the MDE." Typically in the Access world it refers to a specific file created from your original MDB file within Access (menu Tools, Database Utilities, Make MDE File). Basically it takes your MDB file and removes the source code and compiles it into a MDE Access file to prevent viewing and/or changing the code. Then you mention the DistributePackage process and "within your folder the MDE is there" as if the MDE file was just created by this process. Doesn't it create HTML files? Are you saying the HTML files don't have the revised MaterialRiskString? Confused...

 

[colval]

hi sfm6s524

I will try and explain better.

The master database as a form with a button called distribute. When this is clicked you are asked where you would like to distribute the MDE to on your computer/network.

This then populates the directory with the MDE database and report HTML template files.

The big problem we have is on the Master.mdb we change some module code in the Public functionmaterialrisk module. The fields for this are populated within a form using drop down lists etc..... If we do the change in the Master and test in the master it works ok. After we create the MDE and then go into the MDE for some reason it keeps the old code and not the new changes. I have compiled the code after the changes and saved the modules, but somehow it keeps the old code when we make the MDE.

I have searched the database throughout but cannot find anywhere it can keep the old code. It must do somewhere but where!!!!!!!

Amy ideas would be appreciated.

Thanks

 

[sfm6s524]

I suggest taking a look at code in the the DistributePackage sub and see exactly which MDE file it is copying to your destination folder. Perhaps immediately after running the Distribute routine, check the file data/time on the MDE in that destination folder, and compare to the source MDE. Or maybe somewhere in the code it is using an undocumented method of creating MDE files (SysCmd 603 ?), which could use any source to create the MDE. Or, post your DistributePackage code and lets take a look.

 

[colval]

Hi SFM6s524

I will try and take a look in the morning and I will also post the source code in the morning, hopefully you can shed some light as to why we are losing the module changes. Thanks

 

[colval]

Ok when I click the Distribution button the event procedure is this

Private Sub ButtonDistribute_Click()
DoCmd.OpenForm "FormDistrib"
End Sub

The there is a Button in the FormDistrib button that is called Lock and Export and this as this code attached as an event procedure;

Option Compare Database

Private Sub ApplicationTitle_Change()
Dim db As Database
Dim obj As Object
Set db = CurrentDb
On Error GoTo Failed
db.Properties!AppTitle = Me!ApplicationTitle.Text
Application.RefreshTitleBar
Exit Sub
Failed:
If Err.Number = 3270 Then
Set obj = db.CreateProperty("AppTitle", dbText, strTitle)
db.Properties.Append obj
Resume Next
End If
End Sub

Private Sub ButtonClose_Click()
DoCmd.Close
End Sub

Private Sub ButtonDistribute_Click()
Me.Refresh
DistributePackage Me!CheckCopyData.Value
End Sub

Private Sub ButtonGoEmail_Click()
On Error GoTo URLFailed
FollowHyperlink "mailto:" & AboutEmail
URLFailed:
End Sub

Private Sub ButtonGoURL_Click()
DoCmd.Hourglass True
If IsNull(AboutURL) Then Exit Sub
If Not AboutURL Like "*://*" Then
AboutURL = "

http://"

& AboutURL
End If
On Error GoTo URLFailed
FollowHyperlink AboutURL, , True
DoCmd.Hourglass False
Exit Sub
URLFailed:
MsgBox "Could not open website: " & AboutURL, , "Website Error"
DoCmd.Hourglass False
End Sub


I am not sure where it goes after that, we usualy select where to place it in a directory and then gert a messsage saying it is exported.

Thanks

 

[colval]

SORRY found all this other code below, I will post them one by one

MASTER SURVEY MOd-Custome Code

Option Compare Database

Public Function setByPassProperty()
Const DB_Boolean As Long = 1
ChangePropertyDdl "AllowByPassKey", DB_Boolean, False
End Function

Public Function ChangePropertyDdl(strPropName As String, PropType As Variant, VpropVal As Variant) As Boolean
On Error GoTo ChangePropertyDdl_Err
Dim db As DAO.Database
Dim prp As DAO.Property
Const conPropNotFoundError = 3270
Set db = CurrentDb
db.Properties.Delete strPropName
Set prp = db.CreateProperty(strPropName, PropType, VpropVal, True)
db.Properties.Append prp
ChangePropertyDdl = True
ChangePropertyDdl_Exit:
Set prp = Nothing
Set db = Nothing
Exit Function
ChangePropertyDdl_Err:
If Err.Number = conPropNotFoundError Or Err.Number = 3265 Then
Resume Next
End If
Resume ChangePropertyDdl_Exit
End Function

Public Function ImportTableData(SourceDbFile As String, TableName As String)
On Error GoTo Failed
CurrentDb.Execute "DELETE * FROM " & TableName
CurrentDb.Execute "INSERT INTO " & TableName & " SELECT * FROM [" & SourceDbFile & "]." & TableName
Exit Function
Failed:
MsgBox "There was an error importing data from " & SourceDbFile & ": " & Err.Description, vbExclamation + vbOKOnly, "Error Importing Data"
Error Err.Number
End Function

Public Function ImportData()
On Error GoTo Failed

Dim SourceDbFile As String
Dim bCancelled As Boolean
SourceDbFile = BrowseForFile("Source Database", GetBaseDirectory(), "Survey Database" & vbNullChar & "*.mdb" & vbNullChar, bCancelled)
If bCancelled Then GoTo Failed

ImportTableData SourceDbFile, "Settings"
ImportTableData SourceDbFile, "TableClients"
ImportTableData SourceDbFile, "TableSites"
ImportTableData SourceDbFile, "TableSamples"
ImportTableData SourceDbFile, "TableImages"
ImportTableData SourceDbFile, "TableSiteDrawings"
ImportTableData SourceDbFile, "TableSampleDrawings"

MsgBox "Import successful." & Err.Description, vbInformation + vbOKOnly, "Import Success"
Exit Function
Failed:
MsgBox "An error occurred during data import: " & Err.Description, vbExclamation + vbOKOnly, "Import Error"
End Function

Public Function ExportTableData(TargetDbFile As String, TableName As String)
On Error GoTo Failed
CurrentDb.Execute "DELETE * FROM [" & TargetDbFile & "]." & TableName
CurrentDb.Execute "INSERT INTO " & TableName & " IN """ & TargetDbFile & """ SELECT * FROM " & TableName
Exit Function
Failed:
MsgBox "There was an error exporting data to " & TargetDbFile & ": " & Err.Description, vbExclamation + vbOKOnly, "Error Exporting Data"
Error Err.Number
End Function

Public Function DistributePackage(CopyData As Boolean)
On Error GoTo Failed
Dim rs As DAO.Recordset
Dim db As Database
Set db = CurrentDb

Dim distribPath As String
Dim bCancelled As Boolean
distribPath = BrowseForPath("Distribution Path", GetBaseDirectory(), bCancelled)
If bCancelled Then Exit Function
If distribPath = GetBaseDirectory() Then
MsgBox "Cannot distribute to same directory as master database.", vbExclamation + vbOKOnly, "Distribution Error"
Exit Function
End If

DoCmd.Hourglass True

CopyPath GetBaseDirectory() & "distrib\", distribPath
If Dir(distribPath & "templates", vbDirectory) = "" Then MkDir distribPath & "templates"
CopyPath GetTemplateDirectory(), distribPath & "templates\"

Dim distribDbFilename, distribDbFile As String
distribDbFilename = "survey.mde"
distribDbFile = GetBaseDirectory() & "distrib\" & distribDbFilename
Set rs = db.OpenRecordset("SELECT ListName FROM TableLists", dbOpenSnapshot)
ExportTableData distribDbFile, "TableLists"
Do While Not rs.EOF
ExportTableData distribDbFile, rs(0)
rs.MoveNext
Loop
Set rs = db.OpenRecordset("SELECT TableName FROM TableVLists", dbOpenSnapshot)
ExportTableData distribDbFile, "TableVLists"
Do While Not rs.EOF
ExportTableData distribDbFile, rs(0)
rs.MoveNext
Loop
ExportTableData distribDbFile, "TableReports"
ExportTableData distribDbFile, "TableDefaultSiteFields"
DeleteUnusedImages
ExportTableData distribDbFile, "TableImages"
ExportTableData distribDbFile, "Settings"
Kill distribPath & distribDbFilename
DBEngine.CompactDatabase distribDbFile, distribPath & distribDbFilename
If CopyData Then
ExportTableData distribPath & distribDbFilename, "TableClients"
ExportTableData distribPath & distribDbFilename, "TableSites"
ExportTableData distribPath & distribDbFilename, "TableSamples"
ExportTableData distribPath & distribDbFilename, "TableSiteDrawings"
ExportTableData distribPath & distribDbFilename, "TableSampleDrawings"
End If

DoCmd.Hourglass False
MsgBox "Package has been successfully distributed to " & distribPath, vbInformation + vbOKOnly, "Distribution"
Exit Function
Failed:
DoCmd.Hourglass False
MsgBox "An error occurred during distribution: " & Err.Description, vbExclamation + vbOKOnly, "Distribution Error"
End Function

Public Function CopyPath(srcPath As String, destPath As String) As Boolean
Dim subfoldersList As New Collection
Dim filename As String
filename = Dir(srcPath & "*", vbDirectory + vbNormal + vbHidden + vbReadOnly)
Do While filename <> ""
If (GetAttr(srcPath & "\" & filename) And vbDirectory) Then
If filename <> "." And filename <> ".." Then subfoldersList.Add filename
Else
FileCopy srcPath & filename, destPath & filename
End If
filename = Dir
Loop

On Error Resume Next

Dim subfolder As Variant
For Each subfolder In subfoldersList
MkDir destPath & subfolder
CopyPath srcPath & subfolder & "\", destPath & subfolder & "\"
Next subfolder

Exit Function
Failed:
MsgBox "An error occurred while copying distribution files: " & Err.Description, vbExclamation + vbOKOnly, "Distribution Error"
End Function

Public Function GetBaseDirectory() As String
Dim strDBpath As String
Dim strDBfile As String
strDBpath = CurrentDb.Name
strDBfile = Dir(strDBpath)
GetBaseDirectory = Left$(strDBpath, Len(strDBpath) - Len(strDBfile))
End Function

Public Function GetTempDirectory() As String
Dim tempdir As String
tempdir = GetBaseDirectory() & "tmp"
If Dir(tempdir, vbDirectory) = "" Then MkDir tempdir
GetTempDirectory = tempdir & "\"
End Function

Public Function GetTemplateDirectory() As String
GetTemplateDirectory = GetBaseDirectory() & "templates\"
End Function

Public Function GetFileType(FilePath As String) As String
GetFileType = Mid(FilePath, InStrRev(FilePath, ".", -1, vbTextCompare) + 1)
End Function

Public Function GetParentForm(controlObj As control) As Form
On Error GoTo Failed
Dim frm As Object
Dim x As Integer
x = 0
Set frm = controlObj
Do Until Mid(frm.Name, 1, 4) = "Form"
Set frm = frm.Parent
x = x + 1
If x > 10 Then GoTo Failed
Loop
Set GetParentForm = frm
Exit Function
Failed:
Set GetParentForm = Null
End Function

Public Function Cleanup()
On Error Resume Next
Set printerInterface = New PrinterControl
printerInterface.ReSetOrientation
If GetTempDirectory() <> GetBaseDirectory() Then Kill GetTempDirectory() & "*"
End Function

Public Function GetClientAddress(ClientID As Integer) As String
On Error GoTo Failed
Dim rs As DAO.Recordset
Dim address As String
Set rs = CurrentDb.OpenRecordset("SELECT * FROM TableClients WHERE ClientID=" & ClientID, dbOpenSnapshot)
address = rs!ClientCompanyName
If Not IsNull(rs!ClientAddr1) Then address = address & "," & vbCrLf & rs!ClientAddr1
If Not IsNull(rs!ClientAddr2) Then address = address & "," & vbCrLf & rs!ClientAddr2
If Not IsNull(rs!ClientAddr3) Then address = address & "," & vbCrLf & rs!ClientAddr3
If Not IsNull(rs!ClientCounty) Then address = address & "," & vbCrLf & rs!ClientCounty
If Not IsNull(rs!ClientPostCode) Then address = address & "." & vbCrLf & rs!ClientPostCode
GetClientAddress = address
Exit Function
Failed:
GetClientAddress = ""
End Function

Public Function GetSiteAddress(SiteID As Integer) As String
On Error GoTo Failed
Dim rs As DAO.Recordset
Dim address As String
Set rs = CurrentDb.OpenRecordset("SELECT * FROM TableSites WHERE SiteID=" & SiteID, dbOpenSnapshot)
address = rs!SiteName
If Not IsNull(rs!SiteAddr1) Then address = address & "," & vbCrLf & rs!SiteAddr1
If Not IsNull(rs!SiteAddr2) Then address = address & "," & vbCrLf & rs!SiteAddr2
If Not IsNull(rs!SiteAddr3) Then address = address & "," & vbCrLf & rs!SiteAddr3
If Not IsNull(rs!SiteCounty) Then address = address & "," & vbCrLf & rs!SiteCounty
If Not IsNull(rs!SitePostCode) Then address = address & "." & vbCrLf & rs!SitePostCode
GetSiteAddress = address
Exit Function
Failed:
GetSiteAddress = ""
End Function

Public Function FetchSetting(SettingName As String) As Variant
On Error GoTo Failed
Dim rs As DAO.Recordset
Dim db As Database
Set db = CurrentDb
Set rs = db.OpenRecordset("Settings", dbOpenTable)
FetchSetting = rs(SettingName)
db.Close
Exit Function
Failed:
FetchSetting = ""
End Function

Public Function GetSampleRefFromID(SampleID As Long) As Variant
On Error GoTo Failed
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT SampleID FROM TableSamples ORDER BY SampleID", dbOpenSnapshot)
rs.FindFirst "SampleID=" & SampleID
If rs.NoMatch Then GoTo Failed
GetSampleRefFromID = rs.AbsolutePosition + 1
Exit Function
Failed:
GetSampleRefFromID = Null
End Function

Public Function GetActivityFactor(activityID As Long) As Variant
On Error GoTo Failed
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT Factor FROM ListActivity WHERE ID=" & activityID, dbOpenSnapshot)
GetActivityFactor = rs(0)
Exit Function
Failed:
GetActivityFactor = Null
End Function

Public Function GetActivityDescription(activityID As Long) As Variant
On Error GoTo Failed
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT Description FROM ListActivity WHERE ID=" & activityID, dbOpenSnapshot)
GetActivityDescription = rs(0)
Exit Function
Failed:
GetActivityDescription = Null
End Function

Public Function AddComboItem(fieldDesc As String, TableName As String, newValue As String) As Integer
If MsgBox("Add new " & fieldDesc & " (" & newValue & ") to list?", vbQuestion + vbYesNo, "New " & fieldDesc) = vbYes Then
Dim db As Database
Set db = CurrentDb
db.Execute "INSERT INTO " & TableName & " (ItemValue) VALUES (""" & newValue & """)"
AddComboItem = acDataErrAdded
db.Close
Else
AddComboItem = acDataErrContinue
End If
End Function

Public Function DeleteCurrentRecord(ByRef frmSomeForm As Form) As Boolean
On Error GoTo Failed
If frmSomeForm.NewRecord Then
frmSomeForm.Undo
frmSomeForm.Requery
DeleteCurrentRecord = True
Else
frmSomeForm.Recordset.Delete
frmSomeForm.Requery
End If
DeleteCurrentRecord = True
Exit Function
Failed:
DeleteCurrentRecord = False
End Function

Public Function BrowseForFile(DialogTitle As String, DefaultPath As String, fileFilter As String, Optional bCancelled As Boolean) As String
Dim lngFlags As Long
Dim varFileName As Variant

lngFlags = ahtOFN_FILEMUSTEXIST Or ahtOFN_HIDEREADONLY

varFileName = ahtCommonFileOpenSave( _
OpenFile:=True, _
InitialDir:=DefaultPath, _
Filter:=fileFilter, _
Flags:=lngFlags, _
DialogTitle:=DialogTitle)

If IsNull(varFileName) Or varFileName = "" Then
bCancelled = True
BrowseForFile = ""
Else
bCancelled = False
BrowseForFile = TrimNull(varFileName)
End If
End Function

Public Function BrowseForPath(DialogTitle As String, DefaultPath As String, Optional bCancelled As Boolean) As String
Dim selectedPath As String
selectedPath = Mod_FolderDialogs.BrowseFolder(DefaultPath, DialogTitle & ":")
If selectedPath = "" Then bCancelled = True
If Not selectedPath Like "*\" Then selectedPath = selectedPath & "\"
BrowseForPath = selectedPath
End Function

Public Function GetFactor(listname As String, ID As Integer) As Byte
If ID = 0 Then
GetFactor = 0
Exit Function
End If
Dim db As Database
Set db = CurrentDb
fctr = db.OpenRecordset("SELECT Factor FROM " & listname & " WHERE ID = " & ID, dbOpenSnapshot)
GetFactor = fctr(0)
db.Close
End Function

Public Function GetMaterialRisk(SampleID As Integer) As Byte
Dim lists(6) As String
lists(0) = "ListAnalysis"
lists(1) = "ListAsbestosType"
lists(2) = "ListCondition"
lists(3) = "ListFriability"
lists(4) = "ListPosition"
lists(5) = "ListTreatment"
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT SampleAnalysisID, SampleAsbestosTypeID, SampleConditionID, SampleFriabilityID, SamplePositionID, SampleTreatmentID FROM TableSamples WHERE SampleID=" & SampleID, dbOpenSnapshot)
Dim risk As Byte
risk = 0
For n = 0 To 5
risk = risk + GetFactor(lists, rs)
Next n
GetMaterialRisk = risk
End Function

Public Function GetPriorityRisk(SampleID As Integer) As Byte
Dim lists(10) As String
lists(0) = "ListLocation"
lists(1) = "ListAccessibility"
lists(2) = "ListExtent"
lists(3) = "ListNumOccupants"
lists(4) = "ListUseFreq"
lists(5) = "ListUseAvgTime"
lists(6) = "ListActivity"
lists(7) = "ListActivity"
lists(8) = "ListMaintenanceActivity"
lists(9) = "ListMaintenanceFreq"
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT SampleLocationID, SampleAccessibilityID, SampleExtentID, SampleNumOccupantsID, SampleUseFreqID, SampleUseAvgTimeID, SampleActivityMainID, SampleActivitySecondaryID, SampleMaintenanceActivityID, SampleMaintenanceFreqID FROM TableSamples WHERE SampleID=" & SampleID, dbOpenSnapshot)
Dim risk As Byte
risk = 0
For n = 0 To 5
risk = risk + GetFactor(lists, rs)
Next n
risk = -VBA.Int(-risk / 3)
For n = 6 To 9
risk = risk + GetFactor(lists, rs)
Next n
GetPriorityRisk = risk
End Function

Public Function MaterialRiskString(risk As Variant) As String
MaterialRiskString = ""
If IsNull(risk) Or risk = -1 Then Exit Function
If risk = 0 Then MaterialRiskString = "NADIS"
If risk <= 4 Then MaterialRiskString = "Very Low"
If risk <= 6 Then MaterialRiskString = "Low"
If risk <= 9 Then MaterialRiskString = "Medium"
If risk >= 10 Then MaterialRiskString = "High"
End Function



Public Function PriorityRiskString(risk As Variant) As String
PriorityRiskString = ""
If IsNull(risk) Or risk = -1 Then Exit Function
If risk = 0 Then PriorityRiskString = "NFA"
If risk <= 4 Then PriorityRiskString = "Very Low"
If risk <= 6 Then PriorityRiskString = "Low"
If risk <= 9 Then PriorityRiskString = "Medium"
If risk >= 10 Then PriorityRiskString = "High"
End Function


THANKS

 

[colval]

MASTER-MOD_SURVEY (CODE)

Option Compare Database

Private Const REPORT_PAGE_WIDTH = 17

Private SurveySiteID As Integer
Private SurveySiteName As String
Private SurveySiteAddress As String
Private SurveyClientID As Integer
Private SurveyClientName As String
Private SurveyClientAddress As String

Dim ReportsRS As DAO.Recordset

Private PrintQueueSiteID As Integer
Private PrintQueueRS As DAO.Recordset

Public AutoPrinting As Boolean
Dim printerInterface As PageSet.PrinterControl

Function OpenSiteReport(SiteID As Integer, ReportID As Integer)
On Error Resume Next
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT ReportIsLandscape FROM TableReports WHERE ReportID=" & ReportID, dbOpenSnapshot)
Set printerInterface = New PrinterControl
If rs(0) = True Then
printerInterface.ChngOrientationLandscape
Else
printerInterface.ChngOrientationPortrait
End If
AutoPrinting = False
DoCmd.OpenForm "FormReport", , , , , , "PREVIEW:" & SiteID & ":" & ReportID
End Function

Function PrintSiteReport(SiteID As Integer, ReportID As Integer)
On Error Resume Next
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT ReportIsLandscape FROM TableReports WHERE ReportID=" & ReportID, dbOpenSnapshot)
Set printerInterface = New PrinterControl
If rs(0) = True Then
printerInterface.ChngOrientationLandscape
Else
printerInterface.ChngOrientationPortrait
End If
AutoPrinting = True
DoCmd.OpenForm "FormReport", , , , , acHidden, "PRINT:" & SiteID & ":" & ReportID
End Function

Function TestReportQueue()
If CurrentProject.AllForms!FormReport.IsLoaded Then Exit Function
If PrintQueueRS Is Nothing Then Exit Function
If PrintQueueRS.EOF Then
Application.Forms!FormSite.TimerInterval = 0
Set PrintQueueRS = Nothing
Set ReportsRS = Nothing
Set printerInterface = New PrinterControl
printerInterface.ReSetOrientation
DoCmd.Hourglass False
MsgBox "Full survey report has been sent to printer.", vbInformation + vbOKOnly, "Printing Complete"
Exit Function
End If
PrintSiteReport PrintQueueSiteID, PrintQueueRS(0)
PrintQueueRS.MoveNext
End Function

Function IncludeReport(ReportID As Long, reportName As String) As Boolean
IncludeReport = (MsgBox("Include " & reportName & " as part of survey report?", vbYesNo, "Optional Report") = vbYes)
End Function

Function PrintAllSiteReports(SiteID As Integer)
Cleanup
DoCmd.Hourglass True
Application.Forms!FormSite.OnTimer = "=TestReportQueue()"
Application.Forms!FormSite.TimerInterval = 8000
Set PrintQueueRS = CurrentDb.OpenRecordset("SELECT ReportID FROM TableReports WHERE ReportOptional = False OR IncludeReport(ReportID, ReportName) = True ORDER BY ReportID", dbOpenSnapshot)
Set ReportsRS = PrintQueueRS.Clone
PrintQueueSiteID = SiteID
End Function

Function ExportSiteReport(SiteID As Integer, ReportID As Integer)
Dim exportPath As String
Dim bCancelled As Boolean
exportPath = Mod_Custom.BrowseForPath("Export Path", FetchSetting("DefaultExportPath"), bCancelled)
If bCancelled Then Exit Function

If CreateSiteReport(SiteID, ReportID, exportPath) <> "" Then
MsgBox "Survey report has been successfully exported to '" & exportPath & "'.", vbInformation + vbOKOnly, "Export report"
Else
MsgBox "There were errors while exporting the survey report to '" & exportPath & "'.", vbInformation + vbOKOnly, "Export report"
End If
End Function

Function CreateSiteReport(SiteID As Integer, ReportID As Integer, FilePath As String, Optional bLandscape As Boolean) As String
On Error Resume Next

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT ReportID, ReportTemplateFile, ReportOutputFile, ReportIsLandscape FROM TableReports WHERE ReportID = " & ReportID, dbOpenSnapshot)
bLandscape = rs(3)
MkDir FilePath

InitSurvey SiteID
If WriteReport(rs(1), FilePath, rs(2)) Then
CreateSiteReport = FilePath & rs(2)
Else
CreateSiteReport = ""
End If
End Function

Function ExportAllSiteReports(SiteID As Integer)
On Error Resume Next

Dim exportPath As String
Dim bCancelled As Boolean
exportPath = BrowseForPath("Export Path", FetchSetting("DefaultExportPath"), bCancelled)
If bCancelled Then Exit Function

If CreateAllSiteReports(SiteID, exportPath) Then
MsgBox "Full survey report has been successfully exported to '" & exportPath & "'.", vbInformation + vbOKOnly, "Export survey"
Else
MsgBox "There were errors while exporting the full survey report to '" & exportPath & "'.", vbInformation + vbOKOnly, "Export survey"
End If
End Function

Function CreateAllSiteReports(SiteID As Integer, FilePath As String) As Boolean
On Error Resume Next
DoCmd.Hourglass True

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT ReportID, ReportTemplateFile, ReportOutputFile FROM TableReports WHERE ReportOptional = False OR IncludeReport(ReportID,ReportName) = True", dbOpenSnapshot)
Set ReportsRS = rs.Clone
MkDir FilePath

Dim FullSuccess As Boolean
FullSuccess = True

InitSurvey SiteID
Do While Not rs.EOF
If Not WriteReport(rs(1), FilePath, rs(2)) Then FullSuccess = False
rs.MoveNext
Loop

Set ReportsRS = Nothing

DoCmd.Hourglass False
CreateAllSiteReports = FullSuccess
End Function

Function InitSurvey(SiteID As Integer)
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT TableSites.SiteName, TableClients.ClientID, TableClients.ClientCompanyName FROM TableSites INNER JOIN TableClients ON TableSites.SiteClientID=TableClients.ClientID WHERE TableSites.SiteID = " & SiteID, dbOpenSnapshot)

SurveySiteID = SiteID
SurveySiteName = rs(0)
SurveySiteAddress = FormatForHTML(GetSiteAddress(SurveySiteID))
SurveyClientID = rs(1)
SurveyClientName = rs(2)
SurveyClientAddress = FormatForHTML(GetClientAddress(SurveyClientID))
End Function

Function FormatForHTML(PlainText As Variant) As String
If IsNull(PlainText) Or PlainText = "" Then FormatForHTML = "&nbsp;" _
Else FormatForHTML = Replace(PlainText, vbCrLf, "<br>" & vbCrLf, , , vbTextCompare)
End Function

Function WriteReport(TemplateFile As String, TargetPath As String, TargetFile As String) As Boolean
Dim TemplateData As String
Dim ReportData As String
ReportData = ""

On Error GoTo HandleOpenTemplateError

Close #3
Open GetTemplateDirectory() & TemplateFile For Input Access Read As #3
TemplateData = Input$(LOF(3), 3)
Close #3

On Error GoTo HandleError

Dim cmd As Variant
cmd = Array("", "Initial parsing", "")

TemplateData = Replace(TemplateData, "{!SurveyTitle!}", FetchSetting("SurveyTitle"), , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!CompanyName!}", FetchSetting("CompanyName"), , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!CompanyAddress!}", FormatForHTML(FetchSetting("CompanyAddress")), , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!CompanyLogoID!}", FetchSetting("CompanyLogoID"), , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!FontFace!}", FetchSetting("SurveyFontFace"), , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!FontSize!}", FetchSetting("SurveyFontSize"), , , vbTextCompare)

TemplateData = Replace(TemplateData, "{!Date!}", Date, , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!PageFooter!}", FormatForHTML(FetchSetting("PageFooter")), , , vbTextCompare)

TemplateData = Replace(TemplateData, "{!SiteID!}", Str$(SurveySiteID), , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!SiteName!}", SurveySiteName, , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!SiteAddress!}", SurveySiteAddress, , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!ClientID!}", Str$(SurveyClientID), , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!ClientName!}", SurveyClientName, , , vbTextCompare)
TemplateData = Replace(TemplateData, "{!ClientAddress!}", SurveyClientAddress, , , vbTextCompare)

Dim forIndex As Long
forIndex = 0
Dim rs As DAO.Recordset
Dim drawings As DAO.Recordset
Dim imgfile As String
Dim imgsize As Collection
Dim imgscale As Single
Dim c, t As Integer
Dim cmdIndex, cmdIndexEnd As Long
Dim lastValue As Variant
Dim skipFor, skipIf As Boolean
lastValue = ""
skipFor = False
skipIf = False
cmdIndexEnd = 1
cmdIndex = InStr(1, TemplateData, "{#", vbTextCompare)
Do While cmdIndex > 0
If Not skipFor And Not skipIf Then ReportData = ReportData & Mid(TemplateData, cmdIndexEnd, cmdIndex - cmdIndexEnd)
cmdIndex = cmdIndex + 2
cmdIndexEnd = InStr(cmdIndex, TemplateData, "#}", vbTextCompare)
If cmdIndexEnd > 0 Then
cmd = Split(Trim(Mid(TemplateData, cmdIndex, cmdIndexEnd - cmdIndex)), " ", 2, vbTextCompare)
If skipFor And cmd(0) <> "EndFor" Then GoTo SkipCmd
If skipIf And cmd(0) <> "EndIf" Then GoTo SkipCmd
Select Case cmd(0)
Case "UseFile"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No filename found after UseFile"
Dim srcloc As String
Dim targetloc As String
srcloc = GetTemplateDirectory() & cmd(1)
targetloc = TargetPath & cmd(1)
If srcloc <> targetloc Then
FileCopy srcloc, targetloc
End If
Case "LoadQuery"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No SQL statement found after LoadQuery"
Set rs = CurrentDb.OpenRecordset(cmd(1), dbOpenSnapshot)
Case "InsertValue"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No field name found for InsertValue"
If rs Is Nothing Then Err.Raise vbObjectError + 104, , "Tried to insert field value without first loading query"
ReportData = ReportData & FormatForHTML(rs(cmd(1)))
Case "InsertImage"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No field name found for InsertImage"
If rs Is Nothing Then Err.Raise vbObjectError + 104, , "Tried to insert field image without first loading query"
subcmd = Split(cmd(1), " ", 3, vbTextCompare)
If UBound(subcmd) < 2 Then Err.Raise vbObjectError + 103, , "No width and/or height given for InsertImage"
imgfile = Mod_Images.LoadImage(Nz(rs(subcmd(0)), 0), TargetPath)
If imgfile <> "" And getPictureSize(imgfile, imgsize) Then
ReportData = ReportData & "<img src=""" & Dir(imgfile) & """"
imgscale = 1
If (imgscale * imgsize("width")) > Val(subcmd(1)) Then imgscale = Val(subcmd(1)) / imgsize("width")
If (imgscale * imgsize("height")) > Val(subcmd(2)) Then imgscale = Val(subcmd(2)) / imgsize("height")
ReportData = ReportData & " style=""width:" & Int(imgscale * imgsize("width")) & "cm;"""
ReportData = ReportData & ">"
End If
Case "InsertImageByID"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No Image ID found for InsertImageByID"
subcmd = Split(cmd(1), " ", 3, vbTextCompare)
If UBound(subcmd) < 2 Then Err.Raise vbObjectError + 103, , "No width and/or height given for InsertImageByID"
imgfile = Mod_Images.LoadImage(Val(subcmd(0)), TargetPath)
If imgfile <> "" And getPictureSize(imgfile, imgsize) Then
ReportData = ReportData & "<img src=""" & Dir(imgfile) & """"
imgscale = 1
If (imgscale * imgsize("width")) > Val(subcmd(1)) Then imgscale = Val(subcmd(1)) / imgsize("width")
If (imgscale * imgsize("height")) > Val(subcmd(2)) Then imgscale = Val(subcmd(2)) / imgsize("height")
ReportData = ReportData & " style=""width:" & Int(imgscale * imgsize("width")) & "cm;"""
ReportData = ReportData & ">"
End If
Case "InsertSampleDrawings"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No Sample ID found for InsertSampleDrawings"
Dim SampleID As Long
SampleID = Nz(rs(cmd(1)), 0)
Set drawings = CurrentDb.OpenRecordset("SELECT DrawingImageID FROM TableSampleDrawings WHERE DrawingSampleID = " & SampleID, dbOpenSnapshot)
c = 0
If drawings.BOF Then
t = 0
Else
drawings.MoveLast
drawings.MoveFirst
t = drawings.RecordCount
End If
Do While Not drawings.EOF
c = c + 1
imgfile = Mod_Images.LoadImage(drawings(0), TargetPath)
If imgfile <> "" And getPictureSize(imgfile, imgsize) Then
ReportData = ReportData & "<center><p style=""page-break-before: always""><b>Sample Ref.: " & SampleID & " (drawing " & c & " of " & t & ")</b></p><img src=""" & Dir(imgfile) & """"
If imgsize("width") > REPORT_PAGE_WIDTH Then ReportData = ReportData & " style=""width:" & REPORT_PAGE_WIDTH & "cm"""
ReportData = ReportData & "></center>" & vbCrLf
End If
drawings.MoveNext
Loop
drawings.Close
Case "InsertSiteDrawings"
Set drawings = CurrentDb.OpenRecordset("SELECT DrawingImageID, DrawingDescription FROM TableSiteDrawings WHERE DrawingSiteID = " & SurveySiteID, dbOpenSnapshot)
c = 0
If drawings.BOF Then
t = 0
Else
drawings.MoveLast
drawings.MoveFirst
t = drawings.RecordCount
End If
Do While Not drawings.EOF
c = c + 1
imgfile = Mod_Images.LoadImage(drawings(0), TargetPath)
If imgfile <> "" And getPictureSize(imgfile, imgsize) Then
ReportData = ReportData & "<center><p style=""page-break-before: always""><b>Site Drawing " & c & " of " & t & ":<br>" & drawings(1) & "</b></p><img src=""" & Dir(imgfile) & """"
If imgsize("width") > REPORT_PAGE_WIDTH Then ReportData = ReportData & " style=""width:" & REPORT_PAGE_WIDTH & "cm"""
ReportData = ReportData & "></center>" & vbCrLf
End If
drawings.MoveNext
Loop
ReportData = ReportData & "<p style=""page-break-after: always""></p>"
drawings.Close
Case "IfDifferentValue"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No field name found for IfDifferentValue"
If rs Is Nothing Then Err.Raise vbObjectError + 104, , "Tries to test field value without first loading query"
If rs(cmd(1)) = lastValue Then
skipIf = True
Else
lastValue = rs(cmd(1))
End If
Case "IfNotFirstRecord"
If rs Is Nothing Then Err.Raise vbObjectError + 104, , "Tries to test record number without first loading query"
If rs.AbsolutePosition = 0 Then
skipIf = True
End If
Case "IfReportIncluded"
If UBound(cmd) < 1 Then Err.Raise vbObjectError + 103, , "No report number specified for IfReportIncluded"
If ReportsRS Is Nothing Then
Dim reportName As DAO.Recordset
Set reportName = CurrentDb.OpenRecordset("SELECT ReportName FROM TableReports WHERE ReportID=" & cmd(1), dbOpenSnapshot)
skipIf = (MsgBox("Assume inclusion of " & reportName(0) & " in survey report?", vbYesNo, "Report Format Assumption") = vbNo)
Else
ReportsRS.FindFirst "ReportID = " & cmd(1)
If ReportsRS.NoMatch Then
skipIf = True
End If
End If
Case "EndIf"
skipIf = False
Case "ForEachRecord"
forIndex = cmdIndexEnd
rs.MoveFirst
If rs.EOF Then skipFor = True
Case "EndFor"
If skipFor Then
skipFor = False
Else
If forIndex < 1 Then Err.Raise vbObjectError + 105, , "EndFor without ForEachRecord"
rs.MoveNext
If rs.EOF Then
forIndex = 0
Else
cmdIndexEnd = forIndex
cmdIndex = cmdIndexEnd
End If
End If
Case Else
Err.Raise vbObjectError + 102, , "Command '" & cmd(0) & "' is unrecognised"
End Select
Else
Err.Raise vbObjectError + 101, , "{# found without matching #}"
End If
SkipCmd:
cmdIndexEnd = cmdIndexEnd + 2
cmdIndex = InStr(cmdIndex, TemplateData, "{#", vbTextCompare)
Loop
ReportData = ReportData & Mid(TemplateData, cmdIndexEnd)

On Error GoTo HandleWriteFileError

Close #4
Open TargetPath & TargetFile For Output Access Write As #4
Print #4, ReportData
Close #4

WriteReport = True
Exit Function
HandleOpenTemplateError:
MsgBox "Error reading from template file '" & TemplateFile & "':" & vbCrLf & Err.Description, vbExclamation + vbOKOnly, "Template File Error"
WriteReport = False
Exit Function
HandleWriteFileError:
MsgBox "Error writing to output file '" & TargetPath & TargetFile & "':" & vbCrLf & Err.Description, vbExclamation + vbOKOnly, "Output File Error"
WriteReport = False
Exit Function
HandleError:
MsgBox "Error while parsing " & TemplateFile & ":" & vbCrLf & Err.Description & vbCrLf & vbCrLf & "Current Command: """ & Join(cmd, " ") & """", vbExclamation + vbOKOnly, "Template Parsing Error"
WriteReport = False
End Function



THANKS