Code:
'ALLOWS SELECTED TEST DATA TO BE VIEWED IN XL
Option Compare Database
Option Explicit
Dim OpXl As String
Dim Rst1 As Recordset
Dim Rst2 As Recordset
Dim Rst3 As Recordset
Dim Rst4 As Recordset
Dim QdfOemData As QueryDef
Dim appExcel As Excel.Application
Dim wbook As Excel.Workbook
Dim wsheet As Excel.Worksheet
Dim LocationID As Integer
Dim LocationName As String
Dim P1 As Single
Dim Q1 As Single
Dim NoCurves As Integer
Dim cnt1 As Integer
Dim cnt2 As Integer
Dim cnt3 As Integer
Sub TestIndex_DblClick(Cancel As Integer)
SelectViewData
End Sub
Static Sub SelectViewData() ' Puts query data into recordset for manipulation
NoCurves = NoCurves + 1
Dim TestInd As Integer
TestInd = Forms!TestsTbl1!TestIndex
Set Rst1 = CurrentDb.OpenRecordset("SELECT TestsTbl.TestIndex, TestsTbl.LocationID, TestsTbl.TestDate, TestsTbl.DriveEndTemp, TestsTbl.NonDriveEndTemp, TestsTbl.Vibration, TestsTbl.Current, TestsTbl.SurfaceBarometricPressue, TestsTbl.AirwayWetBulbTemp, TestsTbl.AirwayDryBulbTemp, ReadingsTbl.ReadingIndex, ReadingsTbl.TotalPressure, ReadingsTbl.VelocityPressure FROM TestsTbl INNER JOIN ReadingsTbl ON TestsTbl.TestIndex = ReadingsTbl.TestIndex WHERE (((TestsTbl.TestIndex)=" & TestInd & "));", dbOpenSnapshot)
ViewDatainXL Rst1
ViewFanAndLocationData
ViewOemData
End Sub
Sub ViewDatainXL(Rst1 As Recordset)
'Enumerate the specified Recordset Object
Dim appExcel As Excel.Application
Dim wbook As Excel.Workbook
Dim wsheet As Excel.Worksheet
If OpXl <> "yes" Then 'Ensures XL only opens once
Set appExcel = New Excel.Application
appExcel.Visible = True
Set wbook = appExcel.Workbooks.Open("G:\Underground\Engineering\VENT\Jundee Fans db\Jundee Pressure surveys Template.xls")
OpXl = "yes"
ElseIf OpXl = "yes" Then 'Ensures XL only opens once
Set appExcel = Excel.Application
appExcel.Visible = True
Set wbook = appExcel.Workbooks("Jundee Pressure surveys Template.xls") 'Open("G:\Underground\Engineering\VENT\Jundee Fans db\Jundee Pressure surveys Template.xls")
OpXl = "yes"
End If
With Rst1
LocationID = .Fields(1)
Set Rst3 = CurrentDb.OpenRecordset("SELECT PrimaryLocationsTbl.LocationID, PrimaryLocationsTbl.Location FROM PrimaryLocationsTbl WHERE (((PrimaryLocationsTbl.LocationID)=" & LocationID & "));", dbOpenSnapshot)
With Rst3
LocationName = .Fields(1)
End With
Sheets("TemplateA").Select
Sheets("TemplateA").Copy Before:=Sheets("Fan Curves")
Sheets("TemplateA (2)").Name = LocationName
Set wsheet = appExcel.Worksheets(LocationName)
wsheet.Cells(5, 2) = .Fields(1)
wsheet.Cells(22, 2) = .Fields(3)
wsheet.Cells(23, 2) = .Fields(4)
wsheet.Cells(24, 2) = .Fields(6)
wsheet.Cells(33, 2) = .Fields(5)
wsheet.Cells(18, 20) = .Fields(8)
wsheet.Cells(19, 20) = .Fields(9)
wsheet.Cells(15, 20) = .Fields(7) / 10
Do While Not .EOF
For cnt1 = 7 To 35 Step 4
For cnt2 = 7 To 9 Step 1
If .EOF = True Then
Exit For
End If
wsheet.Cells(cnt2, cnt1) = .Fields(11)
If .EOF = True Then
Exit For
End If
wsheet.Cells(cnt2, cnt1 + 2) = .Fields(12)
.MoveNext
Next
If .EOF = True Then
Exit For
End If
Next
Loop
End With
End Sub
Sub ViewFanAndLocationData()
Set appExcel = Excel.Application
appExcel.Visible = True
Set wbook = appExcel.Workbooks("Jundee Pressure surveys Template.xls")
Set wsheet = appExcel.Worksheets(LocationName)
Set Rst2 = CurrentDb.OpenRecordset("SELECT FanIDTbl.FanIndexID, FanIDTbl.FanName, FanIDTbl.Type, PrimaryFanLocationsTbl.LocationID, PrimaryLocationsTbl.DuctDiameter, PrimaryLocationsTbl.TestPointElevation, PrimaryLocationsTbl.Location, PrimaryLocationsQry.MaxOfDateOfMove, CurrentConfigurationQry.MaxOfConfigurationDate, CurrentConfigurationQry.Solidity, CurrentConfigurationQry.NumberOfBlades, CurrentConfigurationQry.BladePitch, CurrentConfigurationQry.EvaseDiameter " & _
" FROM (((FanIDTbl LEFT JOIN PrimaryLocationsQry ON FanIDTbl.FanIndexID = PrimaryLocationsQry.FanIndexID) " & _
" LEFT JOIN PrimaryFanLocationsTbl ON (PrimaryLocationsQry.MaxOfDateOfMove = PrimaryFanLocationsTbl.DateOfMove) AND (PrimaryLocationsQry.FanIndexID = PrimaryFanLocationsTbl.FanIndexID)) " & _
" LEFT JOIN PrimaryLocationsTbl ON PrimaryFanLocationsTbl.LocationID = PrimaryLocationsTbl.LocationID) " & _
" LEFT JOIN CurrentConfigurationQry ON PrimaryLocationsQry.FanIndexID = CurrentConfigurationQry.FanIndexID " & _
" WHERE PrimaryLocationsTbl.Location='" & LocationName & "' AND FanIDTbl.Current=Yes AND FanIDTbl.PrimaryFan=Yes;", dbOpenSnapshot)
With Rst2
Do While Not .EOF
wsheet.Cells(6, 2) = .Fields(2)
wsheet.Cells(8, 2) = .Fields(10)
wsheet.Cells(9, 2) = .Fields(9)
wsheet.Cells(2, 1) = .Fields(1)
wsheet.Cells(10, 2) = .Fields(4)
wsheet.Cells(14, 20) = .Fields(5)
.MoveNext
Loop
.MoveFirst
Set wsheet = appExcel.Worksheets("Fan Data")
wsheet.Cells(6, NoCurves * 3 - 1) = .Fields(1)
wsheet.Cells(12, NoCurves * 3 - 1) = LocationName
wsheet.Cells(41, NoCurves * 3 - 1) = .Fields(1)
End With
End Sub
Sub ViewOemData()
Set appExcel = Excel.Application
appExcel.Visible = True
Set wbook = appExcel.Workbooks("Jundee Pressure surveys Template.xls")
Set wsheet = appExcel.Worksheets(LocationName)
cnt3 = 0
P1 = wsheet.Cells(25, 20) * 1000
Q1 = wsheet.Cells(15, 2)
Set wsheet = appExcel.Worksheets("Fan Data")
wsheet.Cells(8, 3 * NoCurves) = Q1
wsheet.Cells(9, 3 * NoCurves) = P1
With CurrentDb
Set QdfOemData = .CreateQueryDef("", "SELECT CurrentPrimaryQry.Location, CurrentPrimaryQry.FanName, FanConfigurationTbl.ConfigurationDate, FanPerformanceTbl.Q, FanPerformanceTbl.StaticPressure " & _
" FROM (CurrentPrimaryQry " & _
" INNER JOIN FanConfigurationTbl ON (CurrentPrimaryQry.MaxOfConfigurationDate = FanConfigurationTbl.ConfigurationDate) " & _
" AND (CurrentPrimaryQry.FanIndexID = FanConfigurationTbl.FanIndexID)) " & _
" INNER JOIN FanPerformanceTbl ON FanConfigurationTbl.ConfigurationID = FanPerformanceTbl.ConfigurationID " & _
" WHERE CurrentPrimaryQry.Location='" & LocationName & "' " & _
" ORDER BY FanPerformanceTbl.Q;")
End With
With QdfOemData
Set Rst4 = .OpenRecordset(dbOpenSnapshot)
With Rst4
wsheet.Cells(6, 3 * NoCurves - 1) = .Fields(1)
wsheet.Cells(41, 3 * NoCurves - 1) = .Fields(1)
wsheet.Cells(12, 3 * NoCurves - 1) = .Fields(0)
Do While Not .EOF
wsheet.Cells(44 + cnt1, 3 * NoCurves - 1) = .Fields(3)
wsheet.Cells(44 + cnt1, 3 * NoCurves) = .Fields(4)
.MoveNext
Loop
End With
End With
End Sub