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 #}

 

[colval]

MASTERSURVEY- FORM_MANINMENU (CODE)


Private Sub ButtonExit_Click()
On Error GoTo Failed
If ExitDB() Then
pbConfirmQuit = False
Application.Quit
End If
Failed:
End Sub

Private Sub Form_Load()
pbConfirmQuit = True
Dim db As Database
Dim obj As Object
Set db = CurrentDb
On Error GoTo Failed
db.Properties!AppTitle = FetchSetting("ApplicationTitle")
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 Form_Unload(Cancel As Integer)
If pbConfirmQuit Then Cancel = Not ExitDB()
End Sub


THANKS

 

[colval]

MASTERSURVEY-FORM_FORMDISTRIB (CODE)

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


THANKS

 

[colval]

This Appears to Hve all the Distribution code in it (THANKS)

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 = "COLIN"
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

 

[sfm6s524]

Wow! Okay, it looks like the MDE file that gets compacted into the folder you choose when creating a new distribution package is named Survey.mde, in a folder named distrib, within your current MDB folder. For example, if your MDB app is C:\Survey\Survey.mdb, then it will use C:\Survey\distrib\Survey.mde. So, when you create your MDE folder, be sure to create it in the distrib folder.

 

[vbajock]

The most obvious reason for your problem would be that the MDE you are looking at is not the same one as is being produced by your MDB. Are you sure there is not another step where you copy the new MDE to your production folder?

Another question that comes to mind is, why are you using an MDE at all?

 

[colval]

Hi and thanks for your help

Yes I found it. What it does is keeps the old MDE and only copies in certain tables, and maitains its old code. We distribute into another folder.

Because it is an old version of access I have created the database and saved it in a new version, because my Office 2010 cannot create MDE files. I then created a new ACCDE file and place it in the Dsitrib folder. I changed the module that looked for the MDE and replaced it with Survey.accde. This works fine and dsitributes and keeps the code I have changed.

However and typically a new problem came in. When we have made our new folder with the distribution files in, we have another MDE files that updated some areas of the inital Databse (for example extra fields in the forms with table field attached etc...) Because this is an MDE file and an older version of Access (2000 or 2003 I beleive) it says it cannaot update in this directory. I beleive it is because it is an old version MDE.

I have tried to access the Upgrade.MDE but cannot access it using SHIFT or F11 in the older version of access of 2010.

I dont suppose you ahve any ideas how we can get into this upgrade as an MDB so we can then convert it to a accde file and then perhaps it will upgrade.

If I could create MDE in 2010 then we wouldnt have a problem.

Any ideas would be great

Thanks

 

[colval]

Oh the reason we do it this way is because sometimes customers want the asbestos surveys and also we use alot of pictures so it is theonly way they have found to handle it all and create the HTML pages which we then convert into a PDF report.

Someone programmed some time ago so basically we are trying to put in new legislation and try and keep the working of it at the same time. If I could get the upgrade cracked now, i would be nearly done.

Thanks again to all for helping