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
