VB Code

This is the VB code for the home automation system. It is not complete in that it does not have 4 other forms, though these are only doing minor things like displaying 24 hour log graphs. Copying and pasting has lost the formatting and the graphical interface is not there.

So why post it? Well, there are lots of subroutines that are useful. Things like interfacing with the serial and parallel port, how to play sounds, how to store and retrieve data, how to capture video pictures from multiple cameras, how to do jpg compression automatically, how to upload data and pictures to a webpage automatically, and how to interface with picaxes.

Anyone who wants the full code - just email me.

(This screen capture was done just after a reboot and no actual data had been uploaded)

Option Explicit
' once finished program check the following cant be local variables
' app.path gives the location of the program - will be useful sometime
' Warning dim a,b,c as integer only makes c an integer!!!!
Public Oscillator As Boolean
Public TimerCounter As Byte
Public Output15Count As Integer
Public RunningSolenoid As Integer
Public RunningSolenoidElapsed As Integer
Public MinuteTick As Boolean
Public HourTick As Boolean
Public TankStatus As Boolean
'Public Interference As Boolean
Public RunTankLevel As Integer
Public OldRunTankLevel As Integer
Public SunriseLoaded As Boolean
Public Sunrise As String
Public Sunset As String
Public Gray
Public MontyCount As Integer
Public SprinklerRunTime As Integer
Public DayCycle As Integer
Public Catastrophic As Boolean
Public StartCount As Integer
Public SuperSoakRunning As Boolean
Public AirCount As Integer
Public AirArrayCount As Integer
Public AirTest As Boolean
Public RedPump As Boolean
Public YellowPump As Boolean
Public LastUploadTime As Integer
Public InternetSlowPumpDisable As Boolean


Sub OutputLightsStrobe()
' check for PIR sensors
Static DoneRecently As Boolean
If Val(Label37.Caption) > 3 Then
Picture12.BackColor = vbYellow
Else
Picture12.BackColor = Gray
End If
If Picture12.BackColor <> Gray Then
Call BeepOn
Call StrobeOn
DoneRecently = True
Else
If DoneRecently = True Then
Call BeepOff
Call StrobeOff
DoneRecently = False
End If
End If
'Call UpdateRelays
End Sub
Sub BeepOn()
Call SendDataToBus(4, 30, 0, 0, 0)
End Sub
Sub BeepOff()
Call SendDataToBus(4, 31, 0, 0, 0)
End Sub
Sub StrobeOn()
Call SendDataToBus(4, 10, 0, 0, 0)
End Sub
Sub StrobeOff()
Call SendDataToBus(4, 11, 0, 0, 0)
End Sub
Private Sub BlackTank_Click()
frmBlackTank.Show vbModal, Me
End Sub


Private Sub Command1_Click()
' change the solenoids name
Dim SolenoidNumber As Integer
Dim NewSolenoidName As String
Dim Default As Integer
Default = List1.ListIndex + 1
If Default < 1 Then
MsgBox ("Select a solenoid")
Exit Sub
End If
SolenoidNumber = Default
NewSolenoidName = InputBox("Enter new solenoid name", "New Solenoid Name", SolenoidName(Val(SolenoidNumber)))
SolenoidName(Val(SolenoidNumber)) = NewSolenoidName
Call SaveSolenoidData
End Sub

Private Sub Command10_Click()
Call StartDam
End Sub
Sub StartDam()
DamSolenoid = True
DamRuntime = 0
Label55.Caption = "Pumping"
Call DamOn
End Sub
Sub DamOn()
Call SendDataToBus(4, 20, 0, 0, 0)
End Sub
Sub DamOff()
Call SendDataToBus(4, 21, 0, 0, 0)
End Sub

'Private Sub Command10_Click()
' DayCycle = DayCycle + 1
' If DayCycle = 4 Then DayCycle = 1
' Call DisplayCycle
'End Sub

Private Sub Command11_Click()
If Command11.Caption = "Sprinklers enabled" Then
Command11.Caption = "Sprinklers disabled"
Picture13.BackColor = Gray
Else
Command11.Caption = "Sprinklers enabled"
Picture13.BackColor = vbYellow
End If

End Sub



Private Sub Command12_Click()
LightsAlwaysOn = False
End Sub

Private Sub Command13_Click()
Call TurnLightsOn(180)
End Sub

'Private Sub Command14_Click()
' Dim i As Integer
' Label65.Caption = "Error=Ok"
' Label65.ForeColor = vbBlack
' For i = 1 To 1440
' TankRecord(i) = ""
' Next
' Open "24Tank.txt" For Output As #1
' Close #1
'End Sub

Private Sub Command15_Click()
Call DamStop
End Sub
Sub DamStop()
DamSolenoid = False
Label55.Caption = "Off"
Call DamOff
End Sub

Private Sub Command16_Click()
InternetSlowPumpDisable = False: ' manual reset
Call ExternalUpload(False)
End Sub


Private Sub ReadPostbox()
Dim ReturnFlag As String
Call ReadDataFromPostbox(1200, 2, 4, ReturnFlag)
If ReturnFlag = "Checksum Valid" Then
'Label53.Caption = Str(PostboxValues(0, 0) - 4) + "C " + Str(Now)
End If
Label52.Caption = ReturnFlag
If ReturnFlag = "Timeout" Then
Label52.Caption = "No reply from postbox"
Label52.ForeColor = vbRed
Else
Label52.ForeColor = vbBlack
End If
End Sub
Sub PumpsOff()
Call SendDataToBus(2, 0, 0, 0, 0)
End Sub
Sub RedPumpOn()
' need to call at least every 3 minutes to keep alive
Call SendDataToBus(2, 1, 0, 0, 0)
End Sub
Sub YellowPumpOn()
Call SendDataToBus(2, 2, 0, 0, 0)
End Sub
Sub RefreshPumps()
Dim status As String
' other subs set redpump and yellowpump status then call this
If RedPump = True Then Call RedPumpOn
If YellowPump = True Then Call YellowPumpOn
If RedPump = False And YellowPump = False Then Call PumpsOff
End Sub



Private Sub Command18_Click()
' change the solenoids group
Dim SolenoidNumber As Integer
Dim NewSolenoidgroup As String
Dim Default As Integer
Default = List1.ListIndex + 1
If Default < 1 Then
MsgBox ("Select a solenoid")
Exit Sub
End If
SolenoidNumber = Default
NewSolenoidgroup = InputBox("Enter new solenoid group", "New Solenoid Group (1-4)", SolenoidGroup(Val(SolenoidNumber)))
SolenoidGroup(Val(SolenoidNumber)) = NewSolenoidgroup
Call SaveSolenoidData
Call GroupTotals
End Sub

Private Sub command2_click()
' change solenoid time
Dim SolenoidNumber As Integer
Dim NewTime As Integer
Dim CurrentTime As Integer
Dim Default As Integer
On Error GoTo ChangeSolError
Default = List1.ListIndex + 1
If Default < 1 Then
MsgBox ("Select a solenoid")
Exit Sub
End If
SolenoidNumber = Default
CurrentTime = SolenoidTime(SolenoidNumber)
NewTime = InputBox("Enter new watering time in minutes", "Watering time", CurrentTime)
SolenoidTime(SolenoidNumber) = NewTime
Call SaveSolenoidData
Call GroupTotals
Exit Sub
ChangeSolError: Close
End Sub

Private Sub Command3_Click()
Call StartRiverCalpeda
End Sub
Sub StartRiverCalpeda()
RedPump = False: ' reset
YellowPump = False
RiverCalpeda = True
RiverRunTime = 0
If Check3.Value = 0 Then
StartRiverPercent = Val(Label82.Caption)
Else
StartRiverPercent = Val(Label68.Caption)
End If
Label10.Caption = "Pumping"
If Picture14.BackColor = vbRed Then
RedPump = True
Call RefreshPumps
Else
YellowPump = True
Call RefreshPumps
End If
End Sub
Private Sub Command4_Click()
Call StopCode(8)
Call RiverStop
End Sub
Sub RiverStop()
Label10.Caption = "Off"
RedPump = False
YellowPump = False
Call RefreshPumps
TankStatus = False
Call PumpRate
End Sub
Sub SetRiverPump()
If Weekday(Date) = 7 Then
'yellow on saturday night (into sunday)
Picture14.BackColor = vbYellow: ' run yellow on weekends
Else
Picture14.BackColor = vbRed: ' run red on weeknights as faster
End If
End Sub

Sub PumpRate()
' uses public riverminute and startriverpercent
Dim TankVolume As Single
Dim FinishRiverPercent As Single
Dim PercentChange As Single
Dim KilolitresPumped As Single
Dim VolumePerMinute As Single
On Error GoTo PumpRateError
If RiverMinute = 0 Then Exit Sub: ' not a real value
TankVolume = 44: ' Kilolitres
If Check3.Value = 0 Then
FinishRiverPercent = Val(Label82.Caption)
Else
FinishRiverPercent = Val(Label68.Caption)
End If
PercentChange = FinishRiverPercent - StartRiverPercent
KilolitresPumped = (PercentChange / 100) * TankVolume
VolumePerMinute = KilolitresPumped / RiverMinute
VolumePerHour = VolumePerMinute * 60
VolumePerHour = Int(VolumePerHour * 100): ' 2 dec places
VolumePerHour = VolumePerHour / 100
Label69.Caption = "Pump Q = " + Trim(Str(VolumePerHour)) + " KL/h"
RiverMinute = 0: ' reset
PumpRateError: Exit Sub
End Sub
Sub StopCode(CodeNo As Integer)
Dim StopCode As String
StopCode = "@" + Left(Time, 5) + " (" + Trim(Str(CodeNo)) + ")"
Label57.Caption = StopCode
End Sub


Private Sub Command5_Click()
Call TurnLightsOn(100)
LightsAlwaysOn = True
End Sub

Private Sub Command6_Click()
Dim i As Integer
For i = 1 To 63
SolenoidTime(i) = 0
Next
Call SaveSolenoidData
End Sub
Sub TurnLightsOn(TimeOn As Integer)
Call SendDataToBus(5, TimeOn, 0, 0, 0)
End Sub

Sub TemperatureExact()
Call PlaySound("the temperature is.wav")
Call Delay(1.2)
Select Case Val(Label2.Caption)
Case 1: Call PlaySound("one.wav")
Case 2: Call PlaySound("two.wav")
Case 3: Call PlaySound("three.wav")
Case 4: Call PlaySound("four.wav")
Case 5: Call PlaySound("five.wav")
Case 6: Call PlaySound("six.wav")
Case 7: Call PlaySound("seven.wav")
Case 8: Call PlaySound("eight.wav")
Case 9: Call PlaySound("nine.wav")
Case 10: Call PlaySound("ten.wav")
Case 11: Call PlaySound("eleven.wav")
Case 12: Call PlaySound("twelve.wav")
Case 13: Call PlaySound("thirteen.wav")
Case 14: Call PlaySound("fourteen.wav")
Case 15: Call PlaySound("fifteen.wav")
Case 16: Call PlaySound("sixteen.wav")
Case 17: Call PlaySound("seventeen.wav")
Case 18: Call PlaySound("eighteen.wav")
Case 19: Call PlaySound("nineteen.wav")
Case 20: Call PlaySound("twenty.wav")
Case 21: Call PlaySound("twenty one.wav")
Case 22: Call PlaySound("twenty two.wav")
Case 23: Call PlaySound("twenty three.wav")
Case 24: Call PlaySound("twenty four.wav")
Case 25: Call PlaySound("twenty five.wav")
Case 26: Call PlaySound("twenty six.wav")
Case 27: Call PlaySound("twenty seven.wav")
Case 28: Call PlaySound("twenty eight.wav")
Case 29: Call PlaySound("twenty nine.wav")
Case 30: Call PlaySound("thirty.wav")
Case 31: Call PlaySound("thirty one.wav")
Case 32: Call PlaySound("thirty two.wav")
Case 33: Call PlaySound("thirty three.wav")
Case 34: Call PlaySound("thirty four.wav")
Case 35: Call PlaySound("thirty five.wav")
Case 36: Call PlaySound("thirty six.wav")
Case 37: Call PlaySound("thirty seven.wav")
Case 38: Call PlaySound("thirty eight.wav")
Case 39: Call PlaySound("thirty nine.wav")
Case 40: Call PlaySound("forty.wav")
Case 41: Call PlaySound("forty one.wav")
Case 42: Call PlaySound("forty two.wav")
End Select
Select Case Val(Label2.Caption)
Case 0 To 10: Call Delay(0.6)
Case Else: Call Delay(0.9)
End Select
Call PlaySound("degrees.wav")
End Sub


Private Sub Command7_Click()
Dim i As Integer
Dim MultiplyFactor As Single
Dim NewValue As Single
MultiplyFactor = Val(InputBox("Enter multiply factor eg 0.5 or 2.5"))
For i = 1 To 63
If SolenoidTime(i) <> 0 Then
NewValue = SolenoidTime(i) * MultiplyFactor
NewValue = Int(NewValue)
SolenoidTime(i) = NewValue
End If
Next
Call SaveSolenoidData
End Sub

Private Sub Command8_Click()
Call SaveSolenoidData
FileCopy "SolenoidData.txt", "SolenoidData.tmp": ' save old values
Dim i As Integer
For i = 1 To 63
If SolenoidTime(i) <> 0 Then SolenoidTime(i) = 1
Next
SolenoidTime(1) = 1
Call UpdateSolenoidDisplay
End Sub
Private Sub Command9_Click()
Kill "SolenoidData.txt"
Name "SolenoidData.tmp" As "SolenoidData.txt"
Call ReadSolenoidData
Call UpdateSolenoidDisplay
End Sub

Private Sub EchoRS232_Click()
' use baudrate 1200 commport=2 and timeout=5
Dim InputData As String
Dim ErrorFlag
Dim StartTime
Dim RequestString As String
Dim i As Single
Dim ReturnFlag As String
Timer1.Enabled = False
If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
MSComm1.CommPort = "2"
MSComm1.Settings = "1200,n,8,1"
MSComm1.RThreshold = 1
MSComm1.InputLen = 1
MSComm1.PortOpen = True
StartTime = Now
RequestString = "H"
MSComm1.Output = RequestString
ReturnFlag = ""
Do
If MSComm1.InBufferCount >= 1 Then Exit Do: ' got enough bytes
i = DateDiff("s", StartTime, Now)
If i > 5 Then ReturnFlag = "Timeout": Exit Do
Loop
' sends back the data
InputData = MSComm1.Input
If InputData = "H" Then ErrorFlag = "Working"
If InputData = "" And ReturnFlag = "Timeout" Then ErrorFlag = "Timeout"
MsgBox (ErrorFlag)
Timer1.Enabled = True
End Sub

Sub Form_Load()
Dim i As Integer
Dim IsOn As Boolean
ComputerName = MachineName
'If ComputerName = "Garage" Then
' Call LoadGarage
' Else
' Call LoadOthers
'End If
' if computer name not Garage then disable all Out commands as XP crashes with these!
Call LoadGarage
End Sub
Sub LoadOthers()
frmBlackTank.Show vbModal, Me
End

End Sub
Sub LoadGarage()
StartCount = 3: ' seconds
Port = &H378
'SprinklerResting = False
MontyCount = 1
LightsAlwaysOn = False
TankRecordCount = 1
RiverCalpeda = False
'Interference = False
TankStatus = False: ' pump off
Catastrophic = False
Gray = &HC0C0C0
BoardAddress = 0
BoardData = 0
SunriseLoaded = False
RedPump = False
YellowPump = False
Label4.Caption = Date
DamSolenoid = False
InternetSlowPumpDisable = False
Call SetPrinterPort: ' sets all to zero
PrinterPortDelay = 1000
OverflowCount = 0
AirArrayCount = 95: ' signals done
SuperSoakRunning = False
' Call TestPrinterPortSpeed(PrinterPortDelay)
Call OutBoardData(BoardData)
Call OutBoardAddress(BoardAddress)
Call AllZero
Call ReadSolenoidData
Call LoadSunrise
Call DayOrNight
Call PIRExists
'Call PlaySound("ETSA off.wav")
'Call RandomStart: ' similar to randomise but errors sometimes and don't know why
Call DayCycleStart
'Call DisplayCycle
Call IsItWinter
'Call ExternalUpload(True): ' test internet connection
Label82.Caption = "85": 'plausible number
Label2.Caption = "24"
Call LoadAllSettings
Call DamOff
Call BeepOff
Call StrobeOff
Call SetRiverPump
Call GroupTotals
Call ReadOldTankRecord
'Shell "Serial.exe"
PostboxValues(2, 0) = 80
End Sub
Sub IsItWinter()
' if month is June to October then default calpeda enable for summer to off
Dim m As Integer
m = Month(Date)
Select Case m
Case 6 To 10: Check1.Value = 0: Call Command11_Click: ' rain off as well
End Select
End Sub


Sub RandomStart()
' run a random number of times. Same as randomize
Dim i As Integer
Dim m As Integer
Dim n As Single
m = Minute(Time)
For i = 0 To m
n = Rnd()
Next
End Sub
Sub DayCycleStart()
DayCycle = 1 + Rnd * 3
If DayCycle > 3 Or DayCycle < 1 Then DayCycle = 1
End Sub

Sub AllZero()
Dim i As Integer
For i = 0 To 15
DigitalOutputs(i) = False
Next
For i = 0 To 63
Solenoid(i) = False
Next
End Sub



Private Sub mnuFileExit_Click()
Call SaveTankRecord
Call SaveSolenoidData
Call SaveAllSettings
End
End Sub

Private Sub mnuTemperature_Click()
frmTemperature.Show vbModal, Me
End Sub

Private Sub mnuTestInOut_Click()
Timer1.Enabled = False
frmTest.Show vbModal, Me
Timer1.Enabled = True
End Sub
'Sub ClearSerialSprinklers()
' Dim i As Integer
' For i = 1 To 63
' SerialSprinklers(i) = False
' Next
' Call SendDataToBus(3, 0, 0, 0, 0): ' Byte 1 = 0 = off spr 10,11,12
'End Sub
'Sub RefreshSerialSprinklers()
' Dim i As Integer
' Dim AnyOn As Boolean
' AnyOn = False
' For i = 1 To 63
' ' copy the solenoid array to serialsprinkler array
' SerialSprinklers(i) = Solenoid(i)
' Next
' For i = 1 To 63
' If SerialSprinklers(i) = True Then AnyOn = True: Exit For
' Next
' If AnyOn = False Then
' Call ClearSerialSprinklers
' End If
' For i = 1 To 63
' If SerialSprinklers(i) = True Then
' Select Case i
' 'if add things here, also add to ClearSerialSprinklers
' Case 10: Call SendDataToBus(3, 1, 0, 0, 0)
' Case 11: Call SendDataToBus(3, 2, 0, 0, 0)
' Case 12: Call SendDataToBus(3, 3, 0, 0, 0)
' End Select
' End If
' Next
'End Sub
Sub RefreshSprinklers(): ' do once a minute. sends to device no 6
Dim i As Integer
Dim AnyOn As Boolean
AnyOn = False
For i = 1 To 63
' copy the solenoid array to serialsprinkler array
SerialSprinklers(i) = Solenoid(i)
Next
For i = 1 To 63
If SerialSprinklers(i) = True Then
Call SendDataToBus(6, i, 0, 0, 0)
AnyOn = True
End If
Next
If AnyOn = False Then Call SendDataToBus(6, 0, 0, 0, 0): ' sends zeros
End Sub

Private Sub mnuVegie_Click()
Dim i As Integer
Dim S As Integer
Dim Loopnumber As Integer
Dim x As Integer
i = 13
For Loopnumber = 1 To 3
For i = 13 To 20
Label38.Caption = Str(i)
Solenoid(i) = True
Call RefreshSprinklers
For x = 1 To 10
Call Delay(1)
DoEvents
Next x
Call ClearSolenoids
Call RefreshSprinklers
Call Delay(3)
Next
Next
End Sub

'Private Sub Option1_Click()
' Dim i As Integer
' Do
' For i = 12 To 19
' Call SendDataToBus(6, i, 0, 0, 0)
' Call Delay(10)
' DoEvents
' Call SendDataToBus(6, 0, 0, 0, 0)
' Call Delay(5)
' DoEvents
' Next i
' Loop: ' never ends
'End Sub

Private Sub Picture1_Click()
Dim i As Integer
Dim SolenoidNumber As Integer
Dim status As Boolean
' if click and was on and was running cycle then stop cycle
If Label8.Caption = "Running" Then
Call SprinklersOff
Exit Sub
End If
' turn on or off solenoid
If Picture1.BackColor = Gray Then status = False Else status = True
If List1.ListIndex < 0 Then
MsgBox ("Select a solenoid")
Exit Sub
End If
Call ClearSolenoids
If status = False Then
status = True
Label7.Caption = "On"
Else
status = False
Label7.Caption = "Off"
Call ClearSolenoids
End If
If status = True Then
SolenoidNumber = Left(List1.List(List1.ListIndex), 2)
Solenoid(Val(SolenoidNumber)) = True
End If
Call RefreshSprinklers
If status = True Then Picture1.BackColor = vbGreen Else Picture1.BackColor = Gray
End Sub
Sub SprinklersOff()
Picture1.BackColor = Gray
Label7.Caption = "Off"
Label8.Caption = "Idle"
Call ClearSolenoids
Call RefreshSprinklers
RunningSolenoid = 0
RunningSolenoidElapsed = 0
End Sub


Private Sub Picture14_Click()
If Picture14.BackColor = vbRed Then
Picture14.BackColor = vbYellow
Else
Picture14.BackColor = vbRed
End If
End Sub

Private Sub Sequence_Click()
frmSequence.Show vbModal, Me
End Sub

Private Sub Timer1_Timer()
Dim H As String
Dim m As String
Dim S As String
Dim Clock As String
Call Toggle12
Call Output15
If TimerCounter >= 16 Then
' read analoginputs and send digital outputs
' every 4 seconds
Call RefreshPumps: ' need to do more often than once a minute
Call ReadPostbox: ' check postbox and display temp
Call ReadTopTankViaPostbox
Call ReadInputs
'Call UpdateRelays ' disabled 2007
Call DisplayTemperature
'Call DisplayBlackTankLevel
'Call DisplayFrontDoorLDR
Call SerialShedLDR
Call SerialFrontLDR
Call SerialGate
Call DisplayGatePIR
'Call DisplayGateLDR
'Call DisplayKeypadPress
'Call DisplayGateOpen
'Call ProcessSecurityInputs
Call StrobesCountdown
Call OutputLightsStrobe
Call StartDecrement
Call DisplayCamera
Call DisplayChairliftVolts
TimerCounter = 0
End If
TimerCounter = TimerCounter + 1
H = Trim(Str(Hour(Now))): m = Trim(Str(Minute(Now))): S = Trim(Str(Second(Now)))
If Len(H) = 1 Then H = "0" + H
If Len(m) = 1 Then m = "0" + m
If Len(S) = 1 Then S = "0" + S
Label3.Caption = H + ":" + m + ":" + S
' do jobs once a minute
If Second(Now) >= 0 And Second(Now) < 20 And MinuteTick = False Then
MinuteTick = True
Call TickMinute
End If
If Second(Now) > 30 And Second(Now) < 50 Then MinuteTick = False
' do jobs once an hour
If Minute(Now) = 0 And HourTick = False Then
HourTick = True
Call TickHour
End If
If Minute(Now) = 10 Then HourTick = False: ' reset
End Sub
Sub AreLightsOn()
If LightsAlwaysOn = True Then
Call TurnLightsOn(100)
End If
End Sub
Sub TickHour()
' do jobs once per hour and once every 3 hours
Label4.Caption = Date
Call LogTemperature
'Call SaveTankRecord
'Call LogTankLevel
Call ExtraPumpTime
Call SaveAllSettings
'Call SaveSolenoidData
'Call MeasureAir
End Sub
Sub TickMinute()
' do jobs once a minute
Static TenMinuteCount As Integer
Static ThirtyMinuteCount As Integer
Dim ReturnFlag As String
Dim m As Integer
If Mid(Label3.Caption, 2, 1) = ":" Then Label3.Caption = "0" + Label3.Caption
Call SolenoidCycle
Call RiverPump
Call DamSolenoidCount
Call BlackTankStatus
Call BlackTankMessages
'If Interference = True Then
' Call InterferenceReset
' Interference = False
'End If
Call Lawnseed
Call AreLightsOn
Call DayOrNight
Call TakeSunsetPicture
Call RecordBlackTank
Call RefreshSprinklers
Call ReadChairliftVolts
Call ChairLiftCharge
Call DisableUploads: ' if just one upload is too slow all day then disable till midnight
'Call TestSerialFlash
'Call DisplayCycle
' Call LastReadTanks
'Call IsItRaining:' no - still want to run if raining coz might only be light rain
'Call CatastrophicFailure
Call OverflowTest
Call OverflowTestBackup
'Call ReadDataFromPostbox(1200, 2, 5, returnflag)
'Call ReadSerialDataTopTanks
Call BlackTankErrors: ' shuts down calpeda pump if detects errors
'If SprinklerResting = True Then label53.Caption = "Resting=True" Else label53.Caption = "Resting=False"
'If Label45.Caption = "Closed" Then Call TransmittingSound
TenMinuteCount = TenMinuteCount + 1
If TenMinuteCount >= 10 Then
Call TenMinute
TenMinuteCount = 0
End If
ThirtyMinuteCount = ThirtyMinuteCount + 1
If ThirtyMinuteCount >= 30 Then
Call ThirtyMinute
ThirtyMinuteCount = 0
End If
Call MinuteSinceMidnight(m)
If m = 720 Then Call SetRiverPump: 'midday
End Sub
Sub ThirtyMinute()
Call ExternalUpload(False)
End Sub
Sub TenMinute()
End Sub
Sub ExternalUpload(Test As Boolean)
Dim Worked As String
Dim NowHour As Integer
Dim Skip As Boolean
NowHour = Hour(Time)
Select Case NowHour
Case 0 To 6: Skip = True
Case 23 To 24: Skip = True
Case Else: Skip = False
End Select
If Skip = True Then Exit Sub: ' don't do late at night
Open "Success.dat" For Input As #1
Line Input #1, Worked
Close #1
If Worked = "Success" Then Label14.Caption = "Connected" Else Label14.Caption = "Not connected"
Call SaveTankRecord: ' creates 24Tank.txt
Call UpdateWebpageText: ' rebuilds index.htm
Call CreateBitmap: ' makes 24Tank.jpg
Call UploadAllFiles
End Sub
Sub CreateBitmap()
Dim Success As Boolean
' do once an hour
' compress to a jpg using external program (see subdirectory, need to include dll)
On Error GoTo CreateBitMapError
' shell could take any amount of time so upload first (ie the previous one) then shell
WindowString = "SaveExit"
frmBlackTank.Show vbModal, Me
Call KillAFile("24Tank.jpg"): ' in case errors
Call RenameFile("24Tank060.jpg", "24Tank.jpg"): ' in case errors
' make new one
Shell "BMPtoJPG.exe 60 24Tank.bmp"
Exit Sub
CreateBitMapError: Close: Exit Sub
End Sub
Sub RenameFile(File1 As String, File2 As String)
On Error GoTo RenameFileError
Name File1 As File2
Exit Sub
RenameFileError: Exit Sub
End Sub

Sub KillAFile(Filename As String)
On Error GoTo KillError
Kill Filename
Exit Sub
KillError: Exit Sub
End Sub
'Sub ReadSerialDataTopTanks()
' Dim LineOfText As String
' Dim j As Integer
' Dim OutputString As String
' On Error GoTo ReadSerialError
' Open "SerialData.txt" For Input As #1
' Line Input #1, LineOfText
' Label77.Caption = LineOfText
' For j = 1 To 7
' Line Input #1, LineOfText
' ' add to main screen
' Select Case j
' Case 1: Call Convert140mm(LineOfText, 51, 168, OutputString)
' Label75.Caption = OutputString
' Case 2: Call Convert140mm(LineOfText, 43, 158, OutputString)
' Label80.Caption = OutputString
' Case 3: Call Convert140mm(LineOfText, 31, 142, OutputString)
' Label81.Caption = OutputString
' Case 4: Label63.Caption = LineOfText
' End Select
' Next
' Line Input #1, LineOfText
' Label77.Caption = Label77.Caption + " " + LineOfText
' Close #1
' Exit Sub
'ReadSerialError: Close #1: Exit Sub
'End Sub
Sub Convert140mm(inputvalue As Byte, loweroffset As Single, upperoffset As Single, outputvalue As String)
' pre determined values for 140mmHg
Dim difference As Single
Dim Ratio As Single
Dim Intermediate As Single
Dim InputSingle As Single
InputSingle = inputvalue
difference = upperoffset - loweroffset
Ratio = 140 / difference
Intermediate = (inputvalue - loweroffset) * Ratio
If Intermediate < 0 Then Intermediate = 0
outputvalue = Trim(Str(Int(Intermediate))): ' convert to integer then string
End Sub
Sub ConvertBackupSensormm(inputvalue As Byte, loweroffset As Single, upperoffset As Single, outputvalue As String)
Dim difference As Single
difference = upperoffset - loweroffset

End Sub

Sub OverflowTestBackup()
' one below could fail if went wet at the wrong time
Dim OverFlowValue As Integer
If Check3.Value = 0 Then
OverFlowValue = Val(Label82.Caption)
Else
OverFlowValue = Val(Label68.Caption)
End If
If OverFlowValue >= 92 Then
Call StopCode(1)
Call RiverStop
Call DamStop
End If
End Sub


Sub OverflowTest()
' ' if has overfilled the black tank with rain eg >96% then run a sprinkler for 10 minutes
Dim OverFlowValue As Integer
Dim AirOverFlowValue As Integer
If Check7.Value = 0 Then Exit Sub
If Check3.Value = 0 Then
OverFlowValue = Val(Label82.Caption)
Else
OverFlowValue = Val(Label68.Caption)
End If
If OverFlowValue >= 95 And OverFlowValue < 120 And OverflowCount = 0 Then
OverflowCount = 6: ' number of minutes to run
List1.ListIndex = 2
Picture1.BackColor = Gray: 'forces to off
Call Picture1_Click
Call StopCode(2)
Call RiverStop
Call DamStop
End If
If OverflowCount > 0 Then
Select Case OverflowCount
Case 1
OverflowCount = 0
Picture1.BackColor = vbGreen: ' forces on
Call Picture1_Click: ' turn off
Case Else
OverflowCount = OverflowCount - 1
End Select
End If
End Sub
Sub CatastrophicFailure()
Static OldValue As Integer
Dim NewValue As Integer
NewValue = Val(Label82.Caption)
If OldValue < 30 Then OldValue = NewValue
'catastrophic failue is a sudden drop eg 15% in one minute. Probably a wire being cut or a pipe bursting
' also doesn't count if sprinklers on
' eg oldvalue=80% and newvalue=60%
If OldValue - NewValue > 15 Then
If Picture1.BackColor <> vbGreen Then
Catastrophic = True
End If
End If
If NewValue - OldValue > 10 Then
Catastrophic = False: ' reset if is just a noisy input
End If
OldValue = NewValue
If Catastrophic = True And Hour(Now) = 7 Then Call PlaySound("Catastrophic.wav")
End Sub
Sub TransmittingSound()
Dim a As Single
a = Rnd
If a < 0.6 Then
PlaySound ("warning this security system is recording and transmitting.wav")
End If
End Sub
Sub RiverPump()
If RedPump = False And YellowPump = False Then Exit Sub
RiverRunTime = RiverRunTime + 1
RiverMinute = RiverMinute + 1
If Label7.Caption = "On" Then
' reset if sprinklers are on
If Check3.Value = 0 Then
StartRiverPercent = Val(Label82.Caption)
Else
StartRiverPercent = Val(Label68.Caption)
End If
RiverMinute = 0
End If
If RiverRunTime > Val(Text2.Text) Then
Call RiverStop
Call StopCode(3)
End If
Label50.Caption = Trim(Str(RiverRunTime))
End Sub
Sub DamSolenoidCount()
If DamSolenoid = False Then Exit Sub
DamRuntime = DamRuntime + 1
If DamRuntime > Val(Text8.Text) Then Call Command15_Click: ' stop
End Sub
Sub Toggle12()
If Oscillator = True Then Oscillator = False Else Oscillator = True
Call ChangeDigitalOutput(12, Oscillator)
End Sub
Sub Output15()
Output15Count = Output15Count + 1
Select Case Output15Count
Case 0 To 1: Call ChangeDigitalOutput(15, False)
Case 2 To 3: Call ChangeDigitalOutput(15, True)
End Select
If Output15Count > 4 Then Output15Count = 0
End Sub
Sub ReadInputs()
' Read all analog inputs
Dim i As Byte
Dim v As Byte
For i = 0 To 15
Call ReadPort(i, v)
AnalogInputs(i) = v
Next
End Sub
Sub UpdateRelays()
Dim i As Integer
' send all digital outputs
' except output12 which has already been done
For i = 1 To 6
Call ChangeDigitalOutput(i - 1, Relay(i))
Next
End Sub
'Sub UpdateSolenoids()
' ' there are 63 solenoids
' ' each controler accepts a binary value eg 101010
' Dim i As Integer
' Dim SolenoidValue As Byte
' Dim SolenoidBinary As String
' Dim v As Byte
' Dim AnyOn As Boolean
' AnyOn = False
' For i = 63 To 0 Step -1
' If Solenoid(i) = True Then
' AnyOn = True
' SolenoidValue = i
' Call DecimalToBinary(SolenoidValue, SolenoidBinary)
' Call ChangeDigOut(6, Right(SolenoidBinary, 1))
' Call ChangeDigOut(7, Mid(SolenoidBinary, 7, 1))
' Call ChangeDigOut(8, Mid(SolenoidBinary, 6, 1))
' Call ChangeDigOut(9, Mid(SolenoidBinary, 5, 1))
' Call ChangeDigOut(10, Mid(SolenoidBinary, 4, 1))
' Call ChangeDigOut(11, Mid(SolenoidBinary, 3, 1))
' 'Call Delay(0.5): ' need time to charge capacitor at remote solenoid
' ' would not be a great delay as would never have more than 1-2 on at the same time (fire)
' End If
' Next
' ' if anyon=false then reset back to 000000
' If AnyOn = False Then
' Call DecimalToBinary(0, SolenoidBinary)
' Call ChangeDigOut(6, Right(SolenoidBinary, 1))
' Call ChangeDigOut(7, Mid(SolenoidBinary, 7, 1))
' Call ChangeDigOut(8, Mid(SolenoidBinary, 6, 1))
' Call ChangeDigOut(9, Mid(SolenoidBinary, 5, 1))
' Call ChangeDigOut(10, Mid(SolenoidBinary, 4, 1))
' Call ChangeDigOut(11, Mid(SolenoidBinary, 3, 1))
' End If
'End Sub
Sub ReadSolenoidData()
On Error GoTo ReadSolenoidError
Dim i As Integer
Dim j As Integer
Dim LineOfText As String
Open "SolenoidData.txt" For Input As #1
Line Input #1, LineOfText: Text1.Text = LineOfText: ' time
Line Input #1, LineOfText: 'Text8.Text = LineOfText: ' second time
For i = 1 To 63
Line Input #1, LineOfText: ' discard = number
Line Input #1, LineOfText
SolenoidName(i) = LineOfText
Line Input #1, LineOfText
SolenoidTime(i) = LineOfText
Line Input #1, LineOfText
SolenoidGroup(i) = LineOfText
Next
Close #1
Call UpdateSolenoidDisplay
List1.ListIndex = 0
Exit Sub
ReadSolenoidError: ' fill with blank data
Close #1
MsgBox ("Can't find SolenoidData.txt - creating blank data")
Open "SolenoidData.txt" For Output As #1
Print #1, "19:00": ' time
Print #1, "03:00": ' second time
For i = 1 To 63
Print #1, "Solenoid #" + Str(i)
Print #1, "Not named yet"
Print #1, "0": ' minutes
Print #1, "1": ' group
Next
Close #1
End Sub
Sub SaveSolenoidData()
Dim i As Integer
Open "SolenoidData.txt" For Output As #1
If Mid(Text1.Text, 2, 1) = ":" Then Text1.Text = "0" + Text1.Text
'If Mid(Text8.Text, 2, 1) = ":" Then Text8.Text = "0" + Text8.Text
Print #1, Text1.Text
Print #1, "03:00": ' not used
For i = 1 To 63
Print #1, "Solenoid #" + Str(i)
Print #1, SolenoidName(i)
Print #1, SolenoidTime(i)
Print #1, SolenoidGroup(i)
Next
Close #1
Call UpdateSolenoidDisplay
End Sub
Sub UpdateSolenoidDisplay()
Dim i As Integer
Dim j As Integer
Dim TotalTime As Integer
Dim Number As String
Dim RunTime As String
Dim Group As String
List1.Clear
For i = 1 To 63
Number = Trim(Str(i)): If i <= 9 Then Number = "0" + Number
RunTime = "000" + Trim(Str(SolenoidTime(i)))
RunTime = Right(RunTime, 3)
TotalTime = TotalTime + Val(RunTime)
Group = Trim(Str(SolenoidGroup(i)))
List1.AddItem (Number + " " + RunTime + " " + Group + " " + SolenoidName(i))
Next
TotalTime = TotalTime / 4
Label6.Caption = "Total:" + Str(TotalTime) + " mins"
If TotalTime > 300 Then
Label6.ForeColor = vbRed
Else
Label6.ForeColor = vbBlack
End If
SprinklerRunTime = TotalTime
End Sub
Sub DisplayTemperature()
' analog input 8 = temperature
' subtract (working on this) to get correct figure
' might need a bit of calibrating
' complete coincidence but 1 degree = 1 step
' 171=12.5 degrees
Dim Degree As Single
'Degree = AnalogInputs(8)
'Degree = Degree - 156
Degree = PostboxValues(0, 0)
Degree = Degree - 4
Label2.Caption = Str(Degree)
End Sub

Sub StrobesCountdown()
Dim StrobeCount As Integer
StrobeCount = Val(Label37.Caption)
StrobeCount = StrobeCount - 1
If StrobeCount < 0 Then StrobeCount = 0
Label37.Caption = Str(StrobeCount)
End Sub
'Sub DisplayFrontDoorLDR()
' 'dark=255, light=0
' 'if light goes on then label28 falls quickly
' ' but tends to go up and down a lot so do on average
' Static OldValue1 As Integer
' Static OldValue2 As Integer
' Static OldValue3 As Integer
' Dim LightDifference As Integer
' Dim i As Integer
' Dim OldAverage As Single
' Dim NewAverage As Single
' Static LDRCount As Integer
' Static OldValue As Integer
' Dim NewValue As Integer
' NewValue = AnalogInputs(0)
' OldValue = OldValue1 + OldValue2 + OldValue3
' OldValue = OldValue / 3: ' average
' If OldValue > 25 And NewValue < 5 Then LDRCount = 10
' 'OldValue = NewValue
' Label28.Caption = Trim(Str(NewValue))
' LDRCount = LDRCount - 1: If LDRCount < 0 Then LDRCount = 0
' Select Case LDRCount
' Case Is > 0: Picture3.BackColor = vbGreen
' Case Else: Picture3.BackColor = Gray
' End Select
' OldValue1 = OldValue2
' OldValue2 = OldValue3
' OldValue3 = NewValue
'End Sub
'Sub DisplayGateLDR()
' 'dark=255, light=0
' 'if light goes on then label28 falls quickly
' Dim LightDifference As Integer
' Static OldValue As Integer
' Static LDRCount As Integer
' Static NewValue As Integer
' Static Old0 As Integer
' Static Old1 As Integer
' Static Old2 As Integer
' Static Old3 As Integer
' Dim Average As Single
' Static OldCount As Integer
' Dim i As Integer
' OldCount = OldCount + 1: If OldCount > 3 Then OldCount = 0
' NewValue = AnalogInputs(4)
' Average = (Old0 + Old1 + Old2 + Old3) / 4
' OldValue = Average
' Label39.Caption = Str(NewValue)
' If OldValue > 220 And NewValue < 200 Then LDRCount = 5
' LDRCount = LDRCount - 1: If LDRCount < 0 Then LDRCount = 0
' Select Case LDRCount
' Case Is > 0: Picture6.BackColor = vbGreen
' Case Else: Picture6.BackColor = Gray
' End Select
' Select Case OldCount
' Case 0: Old0 = NewValue
' Case 1: Old1 = NewValue
' Case 2: Old2 = NewValue
' Case 3: Old3 = NewValue
' End Select
'End Sub

Sub DisplayCamera()
Dim Value As Integer
Dim CameraNumber As Integer
Static LastCamera As Integer
Static SecondsSinceChanged As Integer
SecondsSinceChanged = SecondsSinceChanged + 1: ' called every 2 secs
Value = AnalogInputs(13)
Label15.Caption = Str(Value)
Select Case Value
Case 0 To 8: CameraNumber = 1
Case 9 To 25: CameraNumber = 2
Case 26 To 70: CameraNumber = 3
Case 71 To 100: CameraNumber = 4
Case 101 To 140: CameraNumber = 5
Case 141 To 180: CameraNumber = 6
Case 181 To 220: CameraNumber = 7
Case 221 To 255: CameraNumber = 8
End Select
Label21.Caption = Str(CameraNumber)
If LastCamera <> CameraNumber Then
' camera has changed
' give it a few seconds to adjust light levels and save file
SecondsSinceChanged = 0
LastCamera = CameraNumber
End If
If SecondsSinceChanged = 1 Then
Call CopyImageFile(CameraNumber)
End If
End Sub
Sub CopyImageFile(CameraNumber As Integer)
Dim SourceFile As String
Dim DestinationFile As String
Dim UploadName As String
Dim Success As Boolean
On Error GoTo CopyError
SourceFile = "c:\snapshots\capture.jpg"
DestinationFile = "c:\water\Camera" + Trim(Str(CameraNumber)) + ".jpg"
FileCopy SourceFile, DestinationFile
Call ArchiveCamera(CameraNumber)
Exit Sub
CopyError: Exit Sub
End Sub
Sub ArchiveCamera(CameraNo As Integer)
Static Camera1Count As Integer
Static Camera2Count As Integer
Static Camera3Count As Integer
Static Camera4Count As Integer
Static Camera5Count As Integer
Static Camera6Count As Integer
Static Camera7Count As Integer
Static Camera8Count As Integer
Dim MaxCount As Integer
Dim ArchiveFile As String
Dim SourceFile As String
On Error GoTo ArchiveError
If Camera1Count < 100 Then Camera1Count = 100: ' files list better otherwise 12 is next to 120
If Camera2Count < 100 Then Camera2Count = 100
If Camera3Count < 100 Then Camera3Count = 100
If Camera4Count < 100 Then Camera4Count = 100
If Camera5Count < 100 Then Camera5Count = 100
If Camera6Count < 100 Then Camera6Count = 100
If Camera7Count < 100 Then Camera7Count = 100
If Camera8Count < 100 Then Camera8Count = 100
MaxCount = 250
Select Case CameraNo
Case 1: ArchiveFile = "Archive1~" + Trim(Str(Camera1Count)) + ".jpg"
Camera1Count = Camera1Count + 1
If Camera1Count > MaxCount Then Camera1Count = 100
Case 2: ArchiveFile = "Archive2~" + Trim(Str(Camera2Count)) + ".jpg"
Camera2Count = Camera2Count + 1
If Camera2Count > MaxCount Then Camera2Count = 100
Case 3: ArchiveFile = "Archive3~" + Trim(Str(Camera3Count)) + ".jpg"
Camera3Count = Camera3Count + 1
If Camera3Count > MaxCount Then Camera3Count = 100
Case 4: ArchiveFile = "Archive4~" + Trim(Str(Camera4Count)) + ".jpg"
Camera4Count = Camera4Count + 1
If Camera4Count > MaxCount Then Camera4Count = 100
Case 5: ArchiveFile = "Archive5~" + Trim(Str(Camera5Count)) + ".jpg"
Camera5Count = Camera5Count + 1
If Camera5Count > MaxCount Then Camera5Count = 100
Case 6: ArchiveFile = "Archive6~" + Trim(Str(Camera6Count)) + ".jpg"
Camera6Count = Camera6Count + 1
If Camera6Count > MaxCount Then Camera6Count = 100
Case 7: ArchiveFile = "Archive7~" + Trim(Str(Camera7Count)) + ".jpg"
Camera7Count = Camera7Count + 1
If Camera7Count > MaxCount Then Camera7Count = 100
Case 8: ArchiveFile = "Archive8~" + Trim(Str(Camera8Count)) + ".jpg"
Camera8Count = Camera8Count + 1
If Camera8Count > MaxCount Then Camera8Count = 100
End Select
SourceFile = "Camera" + Trim(Str(CameraNo)) + ".jpg"
ArchiveFile = "c:\snapshots\" + ArchiveFile
FileCopy SourceFile, ArchiveFile
Exit Sub
ArchiveError: Close: Exit Sub
End Sub
Sub SerialShedLDR()
Static OldValue As Integer
Static NewValue As Integer
Static ShedLDRCount As Integer
NewValue = PostboxValues(3, 0)
Label30.Caption = Str(NewValue)
ShedLDRCount = ShedLDRCount - 1
If ShedLDRCount < 0 Then ShedLDRCount = 0
' trip if changes
If NewValue < 215 And OldValue >= 215 Then
ShedLDRCount = 10
Call TurnLightsOn(180)
End If
Select Case ShedLDRCount
Case Is > 0: Picture4.BackColor = vbGreen
Case Else: Picture4.BackColor = Gray
End Select
OldValue = NewValue
End Sub
Sub SerialFrontLDR()
Static OldValue As Integer
Static NewValue As Integer
Static FrontLdrCount As Integer
NewValue = PostboxValues(3, 1)
Label36.Caption = Str(NewValue)
FrontLdrCount = FrontLdrCount - 1
If FrontLdrCount < 0 Then FrontLdrCount = 0
' trip if changes
If NewValue < 215 And OldValue >= 215 Then
FrontLdrCount = 10
Call TurnLightsOn(180)
End If
Select Case FrontLdrCount
Case Is > 0: Picture5.BackColor = vbGreen
Case Else: Picture5.BackColor = Gray
End Select
OldValue = NewValue
End Sub
Sub SerialGate()
Static OldGateStatus As Integer
If PostboxValues(3, 2) = 1 Then
Label47.Caption = "Open"
Picture9.BackColor = Gray
If OldGateStatus = 0 And Label34.Caption = "Night" Then
'dark and gate just opened
Call TurnLightsOn(180)
End If
Else
Label47.Caption = "Closed"
Picture9.BackColor = vbGreen
End If
OldGateStatus = PostboxValues(3, 2)
End Sub
Sub DisplayGatePIR()
Static OldValue As Integer
Static NewValue As Integer
Static GatePIRCount As Integer
NewValue = AnalogInputs(3)
Label41.Caption = Str(NewValue)
GatePIRCount = GatePIRCount - 1: If GatePIRCount < 0 Then GatePIRCount = 0
If NewValue > 128 And OldValue <= 128 Then GatePIRCount = 5
Select Case GatePIRCount
Case Is > 0: Picture7.BackColor = vbGreen
Case Else: Picture7.BackColor = Gray
End Select
OldValue = NewValue
End Sub
'Sub DisplayKeypadPress()
' Static OldValue As Integer
' Static NewValue As Integer
' Static KeypadCount As Integer
' NewValue = AnalogInputs(5)
' Label43.Caption = Str(NewValue)
' KeypadCount = KeypadCount - 1: If KeypadCount < 0 Then KeypadCount = 0
' If NewValue < 128 And OldValue >= 128 Then KeypadCount = 10
' Select Case KeypadCount
' Case Is > 0: Picture8.BackColor = vbGreen
' Case Else: Picture8.BackColor = Gray
' End Select
' OldValue = NewValue
'End Sub
'Sub DisplayGateOpen()
' Select Case AnalogInputs(1)
' Case Is < 128: Label45.Caption = "Open"
' Case Else: Label45.Caption = "Closed"
' End Select
' If Label45.Caption = "Open" Then Picture10.BackColor = Gray Else Picture10.BackColor = vbGreen
'
'End Sub

Sub SolenoidCycle()
' use label 8 to detect status
' if time=start time and label8=idle then start
Dim IsOn As Boolean
Dim MoveNext As Boolean
Dim SprinklerRunTime
Dim TankLevel As Integer
Dim CurrentTime As String
Dim RunSunday As Boolean
Dim i As Integer
RunSunday = False
If OverflowCount <> 0 Then
Exit Sub
End If
On Error GoTo SolenoidExit
If Mid(Text1.Text, 2, 1) = ":" Then Text1.Text = "0" + Text1.Text
'If Mid(Text8.Text, 2, 1) = ":" Then Text8.Text = "0" + Text8.Text
If Command11.Caption <> "Sprinklers enabled" Then Exit Sub
CurrentTime = Left(Label3.Caption, 5)
If CurrentTime = Left(Text1.Text, 5) Then
' start process
' stop uploads if last uploadtimewas slow
'If TankLevel > 60 Then
If Label8.Caption = "Idle" Then
Label8.Caption = "Running"
SprinklerRunningCount = 0
Call PlaySound("sprinklers on.wav")
LawnseedCount = 0
Picture2.BackColor = Gray
Call ClearSolenoids: ' clear all off
RunningSolenoid = 1
' find first solenoid to run
Do
If (Val(Text9.Text) = SolenoidGroup(RunningSolenoid)) Then Exit Do
If SolenoidGroup(RunningSolenoid) = 9 Then Exit Do: ' found next match
RunningSolenoid = RunningSolenoid + 1
If RunningSolenoid > 10 Then MsgBox ("Need to put at least one sprinkler in first 10"): Exit Do
Loop
RunningSolenoidElapsed = 1
Solenoid(RunningSolenoid) = True
List1.Selected(RunningSolenoid - 1) = True
Picture1.BackColor = vbGreen
Label7.Caption = "On"
Call RefreshSprinklers
Exit Sub
End If
'End If
End If
If Label8.Caption = "Idle" Then Exit Sub
' is running so run until finished
MoveNext = False
SprinklerRunTime = Val(SolenoidTime(RunningSolenoid))
'If Check3.Value = 1 Then SprinklerRunTime = SprinklerRunTime * 4
If RunningSolenoidElapsed >= SprinklerRunTime Then MoveNext = True
' movenext=true
If MoveNext = True Then
' move to next solenoid
Call ClearSolenoids: ' clear all off
Call RefreshSprinklers
Call Delay(15): ' to allow solenoids to definitely turn off
RunningSolenoidElapsed = 1
Do
RunningSolenoid = RunningSolenoid + 1
'If Check3.Value = 1 Then
' find next group that matches
Do
' match if numbers match or if next one is zero (0 = every day)
If (Val(Text9.Text) = SolenoidGroup(RunningSolenoid)) Then Exit Do
If SolenoidGroup(RunningSolenoid) = 9 Then Exit Do: ' found next match
If RunningSolenoid > 60 Then Exit Do
RunningSolenoid = RunningSolenoid + 1
Loop
'end If
If RunningSolenoid >= 63 Then
' finished cycle
Call ClearSolenoids: ' all off
Call PlaySound("sprinklers off.wav")
DayCycle = DayCycle + 1: If DayCycle = 4 Then DayCycle = 1
Label8.Caption = "Idle"
Picture1.BackColor = Gray
Label7.Caption = "Off"
RunningSolenoid = 0
List1.Selected(0) = True: ' highlight first
i = Val(Text9.Text) + 1: If i > 4 Then i = 1 ' next long soak
Text9.Text = Trim(Str(i))
Exit Do
End If
' do we skip this one
If Val(SolenoidTime(RunningSolenoid)) <> 0 Then Exit Do
Loop
Else
RunningSolenoidElapsed = RunningSolenoidElapsed + 1
SprinklerRunningCount = SprinklerRunningCount + 1
End If
List1.Selected(RunningSolenoid - 1) = True: ' highlight working solenoid
' update the last run list
If RunningSolenoid <> 1 Then
Solenoid(RunningSolenoid) = True: ' solenoid on
End If
Call RefreshSprinklers
Exit Sub
SolenoidExit: Exit Sub
End Sub
Sub ClearSolenoids()
Dim i As Integer
For i = 0 To 63
Solenoid(i) = False
Next
End Sub
'Sub InterferenceReset()
' Dim i As Integer
' Dim Active As Integer
' Active = 0
' For i = 0 To 63
' If Solenoid(i) = True Then Active = i
' Next
' Call ClearSolenoids
' Call UpdateSolenoids: ' to send zero
' Call Delay(5): ' to recharge capacators
' Solenoid(Active) = True
' Call UpdateSolenoids
'End Sub
Sub LogTemperature()
Dim MyTime As String
Dim Mydate As String
Mydate = Date
MyTime = Time
Open "Temperature.txt" For Append As #2
Print #2, Mydate + "," + MyTime + "," + Label2.Caption
Close #2
End Sub
Sub BlackTankStatus()
'TankStatus As Boolean = true=running pump and waiting till fills
Dim Level As Single
Dim TopLevel As Single
Dim BottomLevel As Single
Dim NowHour As Integer
Dim OnDrop As Integer
Dim MinuteCount As Integer
Dim ETSACheap As Boolean
OnDrop = 0: ' pressure drop in percent when sprinklers are on
TopLevel = 90: ' percent
BottomLevel = 80: ' percent
If Check1.Value = 0 Then
Label16.Caption = "Status = Disabled (Winter)"
If TankStatus = True Then Call RiverStop
Exit Sub
End If
Call MinuteSinceMidnight(MinuteCount)
Select Case MinuteCount
' 8am to 22:00pm=off, on after 10:00pm
Case 480 To 1320: ETSACheap = False
Case Else: ETSACheap = True
End Select
' daylight saving in Nov to March can run at 9pm instead of 10pm
Select Case Month(Date)
Case 11, 12, 1, 2, 3: If MinuteCount > 1260 And MinuteCount < 1320 Then ETSACheap = True
End Select
Select Case MinuteCount
Case 2 To 5: Call ResetUpload
End Select
If Weekday(Date) = 1 Or Weekday(Date) = 7 Then ETSACheap = True: ' saturday and sunday
If Check3.Value = 0 Then
Level = Val(Label82.Caption)
Else
Level = Val(Label68.Caption)
End If
Label17.Caption = "Level =" + Str(Level) + "%"
' can't turn on after midnight - has to be 9pm to midnight and cheap
'If OldTankLevel > BottomLevel And Level <= BottomLevel And ETSACheap = True And TankStatus = False And (Hour(Time) <= 8 Or Hour(Time) >= 21 Or Weekday(Date) = 7 Or Weekday(Date) = 1 Or Check6.Value = 1) Then
'too many conditions, new rule - if <bottom level and etsacheap = true then turn on
If Level <= BottomLevel And ETSACheap = True And TankStatus = False Then
TankStatus = True
' max is set by sprinkler times
Text2.Text = "900": ' max time to pump
Text8.Text = "900": ' dam pumps slower
If OptionRiver = True Then Call StartRiverCalpeda: ' turn on
If OptionDam = True Then Call StartDam
End If
If Level >= TopLevel And TankStatus = True Then
TankStatus = False
Call StopCode(4)
Call RiverStop
Call DamStop
End If
' and if above fails (shouldn't)
If Level > TopLevel + 1 Then
TankStatus = False
Call StopCode(5)
Call RiverStop
Call DamStop
End If
' turn off after 8am unless override cheap power is enabled
' won't always fill but should fill the next night
' only happens 8:02am to 8:03 am
If Check6.Value = 0 And MinuteCount > 482 And MinuteCount <= 484 Then
Call RiverStop: ' turn off pumps
Call DamStop
TankStatus = False
End If
If TankStatus = True Then
Label16.Caption = "Status = Waiting till rises above" + Str(TopLevel) + "%"
Else
Label16.Caption = "Status = Waiting till falls below" + Str(BottomLevel) + "%"
End If
If ETSACheap = False And Check6.Value = 0 Then
Label16.Caption = "Status = Disabled (high ETSA rate)"
End If
End Sub
Sub Lawnseed()
'run every minute
Static ABC As Integer
Dim SolNo As Integer
Dim NewLawnTime As Integer
NewLawnTime = Val(Text5.Text)
Label24.Caption = "Counter=" + Trim(Str(LawnseedCount))
If ABC = 0 Then ABC = 1
If Check2.Value = 0 Then Exit Sub: ' not checked
If Picture1.BackColor = vbGreen Then Exit Sub: ' running main solenoid sequence
If Label34.Caption = "Night" Then Exit Sub
LawnseedCount = LawnseedCount + 1
If Picture2.BackColor = Gray Then
' off and waiting to turn on
If LawnseedCount >= NewLawnTime Then
Call ClearSolenoids
LawnseedCount = 0
' call turnon this solenoid
Select Case ABC
Case 1: SolNo = Val(Text3.Text)
Case 2: SolNo = Val(Text6.Text)
Case 3: SolNo = Val(Text7.Text)
End Select
Solenoid(SolNo) = True: ' solenoid on
Picture2.BackColor = vbGreen
ABC = ABC + 1: If ABC > 3 Then ABC = 1
End If
End If
If Picture2.BackColor = vbGreen Then
' on and waiting to turn off
If LawnseedCount >= Val(Text4.Text) Then
LawnseedCount = 0
' clear all solenoids
Call ClearSolenoids
Picture2.BackColor = Gray
End If
End If
Call RefreshSprinklers
End Sub
Sub LoadSunrise()
Dim LineOfText As String
Dim MyMonth As Integer
Dim MyDay As Integer
Dim TodayMonth As Integer
Dim TodayDay As Integer
TodayMonth = Month(Date)
TodayDay = Day(Date)
Open "Sun.txt" For Input As #1
Do
If EOF(1) Then Exit Do
Line Input #1, LineOfText
Call CutUpString(LineOfText)
If Val(Cutup(1)) = TodayMonth And Val(Cutup(2)) = TodayDay Then
Sunrise = Cutup(3): Sunset = Cutup(4)
Exit Do
End If
Loop
Close #1
Label32.Caption = "Sunrise: " + Sunrise
Label33.Caption = "Sunset: " + Sunset
End Sub
Sub DayOrNight()
' returns label34 as Day or Night
Dim TotalMinutes As Integer
Dim NowHour As Integer
Dim NowMinute As Integer
Dim SunriseMinutes As Integer
Dim SunsetMinutes As Integer
NowHour = Hour(Time)
NowMinute = Minute(Time)
TotalMinutes = NowHour * 60 + NowMinute
Select Case TotalMinutes
Case 0 To 10: If SunriseLoaded = False Then Call LoadSunrise: SunriseLoaded = True
Case 20 To 30: SunriseLoaded = False: ' reset
End Select
SunriseMinutes = Val(Left(Sunrise, 2) * 60) + Val(Right(Sunrise, 2))
SunsetMinutes = Val(Left(Sunset, 2) * 60) + Val(Right(Sunset, 2))
Select Case TotalMinutes
Case Is < SunriseMinutes: Label34.Caption = "Night"
Case SunriseMinutes To SunsetMinutes: Label34.Caption = "Day"
Case Is > SunsetMinutes: Label34.Caption = "Night"
End Select
End Sub
Sub TakeSunsetPicture()
Dim TotalMinutes As Integer
Dim NowHour As Integer
Dim NowMinute As Integer
Dim SunriseMinutes As Integer
Dim SunsetMinutes As Integer
Dim SunsetName As String
On Error GoTo SunsetError
SunsetName = Date
SunsetName = SunsetName + ".jpg"
NowHour = Hour(Time)
NowMinute = Minute(Time)
TotalMinutes = NowHour * 60 + NowMinute
SunriseMinutes = Val(Left(Sunrise, 2) * 60) + Val(Right(Sunrise, 2))
SunsetMinutes = Val(Left(Sunset, 2) * 60) + Val(Right(Sunset, 2))
If TotalMinutes = SunsetMinutes + 10 Then
FileCopy "camera5.jpg", "c:\sunsets\" + SunsetName
End If
Exit Sub
SunsetError: Exit Sub
End Sub


Sub PlaySound(Filename As String)
Dim rc As Long
rc = sndPlaySound(Filename, 1)
End Sub
'Sub ProcessSecurityInputs()
' Exit Sub
' ' needs a complete rewrite now with new serial inputs
' ' and most pir's not connected 2007
' ' passes picture 3 to 8 which are LDR and PIR inputs
' Dim FrontDoorLDR As Boolean
' Dim ShedTreePIR As Boolean
' Dim GateTreePIR As Boolean
' Dim GatePIR As Boolean
' Dim GateLDR As Boolean
' Dim LeaningTreePIR As Boolean
' Dim Keypad As Boolean
' Dim GateStatus As Boolean: 'true=open
' Dim ShedLDR As Boolean
' Static OldFrontDoorLDR As Boolean
' Static OldShedTreePIR As Boolean
' Static OldGateTreePIR As Boolean
' Static OldGatePIR As Boolean
' Static OldGateLDR As Boolean
' Static OldLeaningTreePIR As Boolean
' Static OldKeypad As Boolean
' Static OldGateStatus As Boolean: 'true=open
' Dim AnyOn As Boolean
' Dim StatusString As String
' AnyOn = False: ShedTreePIR = False: FrontDoorLDR = False: GateStatus = False: GateTreePIR = False
' GateLDR = False: LeaningTreePIR = False: Keypad = False
' If Picture5.BackColor = vbGreen Then FrontDoorLDR = True: AnyOn = True
' 'If Picture4.BackColor = vbGreen Then ShedTreePIR = True: AnyOn = True
' 'If Picture5.BackColor = vbGreen Then GateTreePIR = True: AnyOn = True
' 'If Picture7.BackColor = vbGreen Then GatePIR = True: AnyOn = True
' 'If Picture6.BackColor = vbGreen Then GateLDR = True: AnyOn = True
' 'If Picture9.BackColor = vbGreen Then LeaningTreePIR = True: AnyOn = True
' 'If Picture8.BackColor = vbGreen Then Keypad = True: AnyOn = True
' 'If Picture10.BackColor = Gray Then GateStatus = True
' ' turn lights on
' If FrontDoorLDR = True Or GateLDR = True Then
' ' lights on
' 'If Label34.Caption = "Night" Then
' ' Call TurnLightsOn(180)
' 'End If
' If GateStatus = False Then
' ' strobes on
' ' set off alarm if gate closed
' If Val(Label37.Caption) = 0 Then
' Label37.Caption = "5"
' End If
' End If
' End If
' ' flash gate strobe
' If GatePIR = True Then
' Relay(5) = True
' Else
' Relay(5) = False
' End If
' If AnyOn = True Then
' ' record status
' StatusString = Label4.Caption + "," + Label3.Caption + "," + Str(FrontDoorLDR) + "," + Str(ShedTreePIR) + "," + Str(GateTreePIR) + ","
' StatusString = StatusString + Str(GatePIR) + "," + Str(GateLDR) + "," + Str(LeaningTreePIR) + "," + Str(Keypad) + "," + Str(GateStatus) + "," + Label28.Caption + "," + Label39.Caption
' If Check4.Value = 1 Then
' Open "PIR.txt" For Append As #1
' Print #1, StatusString
' Close #1
' End If
' End If
' ' speech events
' If OldFrontDoorLDR = False And FrontDoorLDR = True Then
' Call FrontDoorSpeech
' End If
' If OldGateStatus = True And GateStatus = False Then Call PlaySound("Gate has been closed.wav")
' ' gate has been opened
' If OldGateStatus = False And GateStatus = True Then
' If Label34.Caption = "Night" Then
' Call TurnLightsOn(180)
' Call MontyRandom
' End If
' End If
' If GateStatus = False Then
' If OldShedTreePIR = False And ShedTreePIR = True Then Call PlaySound("Hello welcome to our house.wav")
' If OldGatePIR = False And GatePIR = True Then Call RandomGateTalk
' If OldLeaningTreePIR = False And LeaningTreePIR = True Then Call PlaySound("west driveway sensor triggered.wav")
' End If
' 'If OldGateLDR = False And GateLDR = True Then Call PlaySound("front gate light sensor triggered.wav")
' If OldKeypad = False And Keypad = True And GateStatus = False Then Call PlaySound("Incorrect number.wav")
' ' save previous settings so can trigger new events
' OldFrontDoorLDR = FrontDoorLDR
' OldShedTreePIR = ShedTreePIR
' OldGateTreePIR = GateTreePIR
' OldGatePIR = GatePIR
' OldGateLDR = GateLDR
' OldLeaningTreePIR = LeaningTreePIR
' OldKeypad = Keypad
' OldGateStatus = GateStatus
'End Sub
Sub FrontDoorSpeech()
Select Case Rnd
Case Is <= 0.5
If Label34.Caption = "Night" Then
Call PlaySound("Good evening.wav")
Else
Call TemperatureExact
End If
Case Is > 0.5: Call TemperatureExact
End Select
End Sub
Sub RandomGateTalk()
Dim a As Single
Dim b As Single
b = 6: ' number of sounds
a = Rnd
Select Case a
Case 0 To 1 / b: Call PlaySound("warning this security system is recording and transmitting.wav")
Case 1 / b To 2 / b: Call MontyRandom
Case 2 / b To 3 / b: Call PlaySound("you are under video surveilance.wav")
Case 3 / b To 4 / b: Call PlaySound("you are under video surveilance.wav")
Case 4 / b To 5 / b: Call PlaySound("warning this security system is recording and transmitting.wav")
Case 5 / b To 6 / b: Call TemperatureGeneral
End Select
End Sub
Sub TemperatureGeneral()
Select Case Val(Label2.Caption)
Case 0 To 14: Call PlaySound("hello isnt it cold today.wav")
Case 15 To 19: Call PlaySound("hello it is cool today.wav")
Case 20 To 24: Call PlaySound("hello isnt it a pleasant day today.wav")
Case 25 To 30: Call PlaySound("hello it is warm today.wav")
Case 31 To 35: Call PlaySound("hello it is getting very hot today.wav")
Case Is >= 36: Call PlaySound("hello it is getting extremely hot today.wav")
End Select
End Sub

Sub PIRExists()
On Error GoTo PIRError
Open "PIR.txt" For Input As #1
Close #1
Exit Sub
PIRError: Open "PIR.txt" For Output As #1
Print #1, "Date,Time,FrontDoorPIR,ShedTreePIR,GateTreePIR,GatePIR,GateLDR,LeaningTreePIR,Keypad,Gate"
Close #1
End Sub
Sub MontyRandom()
Dim Monty(1 To 200) As String
Dim ThisFileFound As String
Dim FileCounter As Integer
Dim Playfile As String
On Error GoTo montyerror
If StartCount > 0 Then Exit Sub: ' at startup
ThisFileFound = Dir(App.Path + "\monty\*.wav")
Monty(1) = ThisFileFound
FileCounter = 1
Do
ThisFileFound = Dir
If ThisFileFound = "" Then Exit Do
Monty(FileCounter) = ThisFileFound
FileCounter = FileCounter + 1
Loop
FileCounter = FileCounter - 1
Playfile = App.Path + "\monty\" + Monty(MontyCount)
Call PlaySound(Playfile)
MontyCount = MontyCount + 1
If MontyCount > FileCounter Then MontyCount = 1
Exit Sub
montyerror: Exit Sub
End Sub
'Sub DisplayBlackTankLevel()
' Dim Level As Single
' Dim SensorMin As Single: ' raw analog input
' Dim x As Single
' Dim SensorMax As Single: ' raw analog input
' Dim PercentMid As Single
' Dim ScaleFactor As Single
' Dim LowerValue As Single
' Dim LowerPercent As Single
' Dim lower82 As Single
' Dim LowerZero As Single
' ' 4 foot 2= 17 = 127cm
' ' 6 foot 2 = 143 = 188
' ' full = 7 foot 2 = 207 = just overflowing
' PercentMid = 58: ' percent full when sensor reads min value
' SensorMin = 17: ' subtract off level to get zero
' SensorMax = 200
' ScaleFactor = (100 - PercentMid) / (SensorMax - SensorMin)
' Level = AnalogInputs(9)
' Label52.Caption = Str(Level)
' ' value 20 = 5cm above the sensor
' x = ((Level - SensorMin) * ScaleFactor) + PercentMid
' x = Int(x)
' Label53.Caption = Str(x) + "%"
' ' override the value if shorted - probably the least disruptive way'
' if value is invalid
'If x < 55 Then
' Label53.ForeColor = vbBlue
' Else
' Label53.ForeColor = vbBlack
'End If
'End Sub
'Sub CalcMercury()
' Dim LowerSetPoint As Single
' Dim UpperSetPoint As Single
' Dim AirValue As Single
' Dim Metres As Single
' Dim d As Single
' Dim M As Single
' Dim mmHG As Single
' Dim TankHeight As Single
' Dim TankPercent As Single
' Dim v As Byte
' Dim Centimetres As Integer
' Dim HgInteger As Integer
' TankHeight = 2.38: ' exactly 7 foot, 10 inches
' ' Also water level was 5 foot 10 inches =135mmHg and was reading about 135
' LowerSetPoint = 71: ' analog input when 0
' Call ReadPort(11, v)
' AirValue = v
' Label54.Caption = Str(AirValue)
' UpperSetPoint = 161: ' = 130mmHg
' d = UpperSetPoint - LowerSetPoint
' M = 130 / d: ' multiply factor to get 130
' mmHG = M * (AirValue - LowerSetPoint)
' Metres = mmHG / 76
' HgInteger = mmHG
' Centimetres = Metres * 100
' TankPercent = 100 * (Metres / TankHeight)
' TankPercent = Int(TankPercent)
' Label72.Caption = Str(HgInteger) + " mmHg " + Str(Centimetres) + " cm"
' Label73.Caption = Trim(Str(TankPercent)) + "%"
'End Sub
'Sub DisplayAirValue()
' Dim i As Integer
' Dim Air As Integer
' Dim v As Byte
' Dim AirStep As Integer
' Call ReadPort(11, v)
' Label71.Caption = "Read " + Str(AirArrayCount)
' Air = v
' Label54.Caption = Str(Air)
' AirArrayCount = AirArrayCount + 1
' If AirArrayCount = 13 Then
' AirArrayCount = 99: ' signals end
' 'For i = 19 To 2 Step -1
' ' AirStep = AirArray(i - 1) - AirArray(i)
' ' ' pick point at which values start rising rapidly
' ' If AirStep > 5 Then Exit For
' 'Next
' 'Label71.Caption = Str(AirArray(i))
' Label71.Caption = Str(AirArray(11))
' Call CalcMercury
' Label59.Caption = Label73.Caption: ' fix value
' 'Open "Air.txt" For Output As #1
' 'For i = 0 To 20
' ' Print #1, Str(AirArray(i))
' 'Next
' 'Close #1
' End If
' AirArray(AirArrayCount) = Air
'End Sub

Sub MinuteSinceMidnight(m As Integer)
Dim H As Integer
Dim j As Integer
H = Hour(Time)
j = Minute(Time)
m = H * 60 + j
' 21:00= 1260
' 23:59 = 1439
' 08:00 = 480
End Sub
Sub BlackTankMessages()
Dim NowHour As Integer
Dim BlackLevel As Integer
Dim BlackLower As Integer
NowHour = Hour(Time)
BlackLevel = Val(Label82.Caption)
If NowHour <> 7 Then Exit Sub
If Check1.Value = 0 Then Exit Sub
If BlackLevel < 60 Then Call PlaySound("black tank is low.wav")
If BlackLevel >= 95 Then Call PlaySound("black tank overfull.wav")
End Sub
Sub ExtraPumpTime()
' do once an hour. If sprinkler still on and after midnight then add 120 to the pump time
Dim H As Integer
If Label8.Caption = "Idle" Then Exit Sub
If Label10.Caption = "Off" Then Exit Sub
H = Hour(Time)
If H > 6 Then Exit Sub
' is between midnight and 6am
Text2.Text = Trim(Str(120 + Val(Text2.Text)))
Text8.Text = Text2.Text
End Sub
Sub RecordBlackTank()
'TankRecord(1 To 1440) As String
'TankRecordCount As Integer
Dim TimeStamp As String
Dim BlackValue As String
Dim SprinklersOn As String
Dim PumpStatus As String
Dim Temperature As String
Dim DamSolenoidString As String
Dim ConcreteValue As String
Dim FloatBlackSensor As String
Dim TankPower As String
Dim GateStatus As String
Dim ErrorCodes As String
Dim LowerPump As String
Dim Tank1 As String
Dim Tank2 As String
Dim Tank3 As String
Dim LDR As String
Dim TankVolts As String
If Val(Label2.Caption) > 60 Then Label2.Caption = "50"
Temperature = Left(Label2.Caption + " ", 4)
TimeStamp = Time
TimeStamp = Left(TimeStamp + " ", 10)
BlackValue = Left(Label82.Caption + " ", 7)
LDR = Left(Trim(Str(Val(Label36.Caption))) + " ", 3)
FloatBlackSensor = " ": ' so string still right length (not used now)
Tank1 = Left(Label76.Caption + " ", 5)
Tank2 = Left(Label87.Caption + " ", 5)
Tank3 = Left(Label82.Caption + " ", 5)
TankVolts = Left(Label64.Caption + " ", 5)
If Label65.Caption = "Error=Ok" Then
ErrorCodes = "Err0"
Else
ErrorCodes = Left(Label65.Caption, 4)
End If
PumpStatus = "-Red": LowerPump = "-Yel"
If Label10.Caption = "Pumping" Then
If Picture14.BackColor = vbRed Then
LowerPump = "+Red"
Else
LowerPump = "+Yel"
End If
End If
'If Label7.Caption = "On" And SprinklerResting = False Then SprinklersOn = "+Spr" Else SprinklersOn = "-Spr"
If Label7.Caption = "On" Then SprinklersOn = "+Spr" Else SprinklersOn = "-Spr"
If Label55.Caption = "Off" Then DamSolenoidString = "-Dam" Else DamSolenoidString = "+Dam"
If Label47.Caption = "Open" Then GateStatus = "-Gate" Else GateStatus = "+Gate"
TankRecord(TankRecordCount) = TimeStamp + "|" + BlackValue + "|" + PumpStatus + "|" + SprinklersOn + "|" + Temperature + "|" + DamSolenoidString + "|" + LowerPump + "|" + LDR + "|" + FloatBlackSensor + "|" + GateStatus + "|" + ErrorCodes + "|" + Tank1 + "|" + Tank2 + "|" + Tank3 + "|" + TankVolts + "|" + Label67.Caption + "|" + Label66.Caption + "|" + Str(LastUploadTime) + "|" + Label68.Caption + "|" + Label72.Caption
TankRecordCount = TankRecordCount + 1
If TankRecordCount > 1440 Then TankRecordCount = 1
End Sub
Sub SaveTankRecord()
Dim i As Integer
On Error GoTo SaveTankError
Open "24Tank.txt" For Output As #7
For i = TankRecordCount - 1 To 1 Step -1
If TankRecord(i) <> "" Then Print #7, TankRecord(i)
Next
For i = 1440 To TankRecordCount Step -1
If TankRecord(i) <> "" Then Print #7, TankRecord(i)
Next
Close #7
Exit Sub
SaveTankError: Close #7
End Sub
Sub ReadOldTankRecord()
' reads back old 24tank.txt into array when restarts
Dim LineOfText As String
Dim i As Integer
i = 1440
Open "24tank.txt" For Input As #1
Do
If EOF(1) Then Exit Do
If i < 2 Then Exit Do
Line Input #1, LineOfText
TankRecord(i) = LineOfText
i = i - 1
Loop
Close #1
TankRecordCount = i
End Sub

Sub BlackTankErrors()
' main function is to shut down pump if sensors go haywire
'On Error GoTo BlackTankCodeError
Dim Last100(1 To 100, 1 To 6) As Integer
Dim Last100Text(1 To 100) As String
Dim i As Integer
Dim j As Integer
Dim AllEntries As Boolean
Dim SensorDifference As Single
Dim count As Integer
Dim LineOfText As String
Dim FirstAvg As Single
Dim LastAvg As Single
Dim Test As Boolean
Dim HourNow As Integer
Dim TopTotal As Single
Dim MaxChange As Integer
Dim Change As Integer
Dim BottomTotal As Single
Open "24Tank.txt" For Input As #5
i = 1
Do
If EOF(5) Then Exit Do
Line Input #5, LineOfText
Last100Text(i) = LineOfText
i = i + 1: If i > 100 Then Exit Do
Loop
Close #5
' now have text split it up
AllEntries = True
For i = 1 To 100
If Last100Text(i) = "" Then AllEntries = False
Last100(i, 1) = Val(Mid(Last100Text(i), 12, 2)): ' top black tank percent
Last100(i, 2) = Val(Mid(Last100Text(i), 47, 3)): ' lower black tank percent
If Mid(Last100Text(i), 18, 4) = "+Cal" Then Last100(i, 3) = "1" Else Last100(i, 3) = 0: ' calpeda on
If Mid(Last100Text(i), 23, 4) = "+Spr" Then Last100(i, 4) = "1" Else Last100(i, 4) = 0: ' sprinkler
If Mid(Last100Text(i), 33, 4) = "+Dam" Then Last100(i, 5) = "1" Else Last100(i, 5) = 0: ' Dam
'If Mid(Last100Text(i), 43, 3) = "Dry" Then Last100(i, 6) = "1" Else Last100(i, 6) = 0: ' Power
Next
If AllEntries = False Then Exit Sub
' most recent entry=1
' First type of error - sensors don't agree
count = 0
For i = 1 To 100
If Last100(i, 6) = 1 And Last100(i, 1) > 58 Then
SensorDifference = SensorDifference + Abs(Last100(i, 1) - Last100(i, 2))
count = count + 1
End If
Next
If count > 0 Then
SensorDifference = SensorDifference / count: ' average
' disabled 22/1
'If SensorDifference > 15 Then Label65.Caption = "Err1 Sensors Disagree"
End If
' second type of error - too much time wet Deleted now got rid of sensor
'Count = 0
'For i = 1 To 100
' If Last100(i, 6) = 0 Then Count = Count + 1
'Next
'If Count > 20 Then Label65.Caption = "Err2 Wet last 24h"
' third type of error - upper sensor not rising enough with either dam or river on in an hour and sprinklers off
If OptionRiver = True Then
count = 0: ' river
For i = 1 To 100
If Last100(i, 3) = 1 And Last100(i, 4) = 0 Then count = count + 1
Next
Else
' dam was on - timescales the same
count = 0: ' dam
For i = 1 To 100
If Last100(i, 5) = 1 And Last100(i, 4) = 0 Then count = count + 1
Next
End If
If count > 90 Then
' been on most of the time and sprinkler not on
FirstAvg = 0: LastAvg = 0
For j = 1 To 20
FirstAvg = FirstAvg + Last100(j, 1)
Next
FirstAvg = FirstAvg / 20
For j = 80 To 99
LastAvg = LastAvg + Last100(j, 1)
Next
LastAvg = LastAvg / 20
' exclude if <54% - fix this when get bottom sensor working again
If LastAvg > 55 Then
If FirstAvg - LastAvg < 5 Then Label65.Caption = "Err3 Not rising"
End If
End If
' fourth type of error - signals noisy lower sensor
'Count = 0
'For i = 1 To 99
' Count = Count + Abs(Last100(i, 2) - Last100(i + 1, 2))
'Next
'If Count > 200 Then Label65.Caption = "Err4 Lower Noisy"
' fifth type of error - upper signal noisy
'count = 0
'For i = 1 To 99
' count = count + Abs(Last100(i, 1) - Last100(i + 1, 1))
'Next
'If count > 200 Then Label65.Caption = "Err5 Upper Noisy"
' sixth type of error - lower signal >100=short on sensor wire probably on fence
' Count = 0
' For i = 1 To 99
' If Last100(i, 2) > 100 Then Count = Count + 1
' Next
' If Count <> 0 Then Label65.Caption = "Err6 Low Sens >100"
' 7th type of error - top value is much more than lower value
'TopTotal = 0: BottomTotal = 0
'For i = 1 To 99
' BottomTotal = BottomTotal + Last100(i, 2)
' TopTotal = TopTotal + Last100(i, 1)
'Next
'TopTotal = TopTotal / 100: BottomTotal = BottomTotal / 100
'If BottomTotal - TopTotal > 15 Then
' Label65.Caption = "Err7 Sens <>"
'End If
' eighth type of error - sudden rise of lower signal - probably due to short from rain
'MaxChange = 0
'For i = 1 To 99
' Change = Abs(Last100(i, 2) - Last100(i + 1, 2))
' If Change > MaxChange Then MaxChange = Change
'Next
'If MaxChange > 20 Then Label65.Caption = "Err8 Sudden Change"
'' got to here. If there is an error then stop the pump
If Label65.Caption <> "Error=Ok" Then
Label65.ForeColor = vbRed
Call StopCode(7)
Call RiverStop
Call DamStop
End If
' reset 3 times a day if no errors for 100 mins
' then if 5:05 and still ok ie hasn't found a new error in the last 100 minutes then reset top level to 90
' don't do this while pumping
HourNow = Hour(Now)
Select Case HourNow
Case 4, 12, 17
If Minute(Now) = 13 Then
Label65.Caption = "Error=Ok"
Label65.ForeColor = vbBlack
End If
End Select
Select Case Hour(Now)
Case 4, 12, 17
If Minute(Now) = 17 And Label65.Caption = "Error=Ok" Then
'Call Check1_Click: ' resets to 90 but won't pump till off peak later in the night
End If
End Select
Exit Sub
BlackTankCodeError: Label65.Caption = "Code Error": Close
End Sub
Sub StartDecrement()
StartCount = StartCount - 1
If StartCount < 0 Then StartCount = 0
End Sub
Sub SaveAllSettings()
Dim a As Double
Dim b As String
Dim RedYellow As String
Open "Settings.txt" For Output As #1
a = Check7.Value: Print #1, Str(a)
a = Picture13.BackColor: Print #1, Str(a)
a = Check1.Value: Print #1, Str(a)
a = Check6.Value: Print #1, Str(a)
a = Check3.Value: Print #1, Str(a)
a = Check4.Value: Print #1, Str(a)
a = Check2.Value: Print #1, Str(a)
Print #1, Text9.Text
Print #1, Text3.Text
Print #1, Text6.Text
Print #1, Text7.Text
Print #1, Text4.Text
Print #1, Text5.Text
If OptionRiver = True Then Print #1, "River" Else Print #1, "Dam"
If Picture14.BackColor = vbRed Then RedYellow = "Red" Else RedYellow = "Yellow"
Print #1, RedYellow
a = Check5.Value: Print #1, Str(a)
Close #1
End Sub
Sub LoadAllSettings()
Dim S As String
Open "Settings.txt" For Input As #1
Line Input #1, S: Check7.Value = Val(S)
Line Input #1, S: Picture13.BackColor = Val(S)
If Picture13.BackColor = vbYellow Then
Command11.Caption = "Sprinklers enabled"
Else
Command11.Caption = "Sprinklers disabled"
End If
Line Input #1, S: Check1.Value = Val(S)
Line Input #1, S: Check6.Value = Val(S)
Line Input #1, S: Check3.Value = Val(S)
Line Input #1, S: Check4.Value = Val(S)
Line Input #1, S: Check2.Value = Val(S)
Line Input #1, S: Text9.Text = S
Line Input #1, S: Text3.Text = S
Line Input #1, S: Text6.Text = S
Line Input #1, S: Text7.Text = S
Line Input #1, S: Text4.Text = S
Line Input #1, S: Text5.Text = S
Line Input #1, S: If S = "River" Then OptionRiver.Value = True Else OptionDam.Value = True
Line Input #1, S: If S = "Red" Then Picture14.BackColor = vbRed Else Picture14.BackColor = vbYellow
Line Input #1, S: Check5.Value = Val(S)
Close #1
End Sub
Sub UpdateWebpageText()
'<p align="left"><font size="4" face="Arial">Last update ddmmyyy hhmmss &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Temperature = 30C &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Metal fire tank = 78% full</font></p>
' example above = raw text
Dim OldText As String
Dim NewText As String
Dim LineOfText As String
Dim Success As Boolean
Dim TimeString As String
Dim Kilolitres As Single
Dim MinuteString As String
Dim Mydate As String
Dim ConcreteLine As String
On Error GoTo UpdateWebPageError
TimeString = Trim(Str(Hour(Time))) + ":"
Mydate = Date
If Minute(Time) < 10 Then
MinuteString = "0" + Trim(Str(Minute(Time)))
Else
MinuteString = Trim(Str(Minute(Time)))
End If
TimeString = TimeString + MinuteString + " " + Right(Time, 2)
'Call DownloadFile("index.htm")
Kilolitres = Val(Label82.Caption) * 44
Kilolitres = Int(Kilolitres / 100)
Open "index.htm" For Input As #1
Open "newindex.txt" For Output As #2
Do
If EOF(1) Then Exit Do
Line Input #1, LineOfText
If Mid(LineOfText, 45, 6) = "Moxham" Then
Print #2, LineOfText
Line Input #1, LineOfText: ' get next line+1 which is the one to change
Line Input #1, ConcreteLine
NewText = "<p align=" + Chr(34) + "left" + Chr(34) + "><font size=" + Chr(34) + "4" + Chr(34) + " face=" + Chr(34) + "Arial" + Chr(34) + ">"
NewText = NewText + "Shed temperature = " + Label2.Caption + "C"
NewText = NewText + "&nbsp;&nbsp;&nbsp;&nbsp;": ' spaces
NewText = NewText + "Uploaded @ " + TimeString + " " + Mydate + "</font></p>"
LineOfText = NewText
Call ConcreteTankLine(ConcreteLine)
Print #2, ConcreteLine
End If
Print #2, LineOfText
Loop
Close #1, #2
' copy file to index
FileCopy "newindex.txt", "index.htm"
Exit Sub
UpdateWebPageError: Close: Exit Sub
End Sub
Sub ConcreteTankLine(ConcreteLine As String)
'"<p align="left"><font size="4" face="Arial">Shed temperature = 10C&nbsp;&nbsp;&nbsp;&nbsp;Metal tanks 71% full (31KL)&nbsp;&nbsp;&nbsp;Uploaded @ 14:21 PM 15-Jul-06</font></p>
ConcreteLine = "<p align=" + Chr(34) + "left" + Chr(34) + "><font size=" + Chr(34) + "4" + Chr(34) + "face=" + Chr(34) + "Arial" + Chr(34) + ">"
ConcreteLine = ConcreteLine + "Concrete tank = " + Label76.Caption + "%" + "&nbsp;&nbsp;&nbsp;&nbsp;"
ConcreteLine = ConcreteLine + "Black tank = " + Label87.Caption + "%" + "&nbsp;&nbsp;&nbsp;"
ConcreteLine = ConcreteLine + "Metal tanks = " + Label82.Caption + "%" + "&nbsp;&nbsp;&nbsp;"
ConcreteLine = ConcreteLine + "Volts = " + Label64.Caption + "V" + "</font></p>"
ConcreteLine = ConcreteLine
End Sub


'Sub ReadTopTankSerial()
' ' format - 8 sec pulse on then 8 sec off then data changes every 8 secs
' ' receives 7 bytes = 56 bits. Last two are checksums
' ' sub above puts in the byte value every 2 secs
' Static Status As String
' Static StartTime
' Dim ElapsedSecs As Integer
' Dim InputBit As Integer
' Static InputBytes(1 To 10, 1 To 8) As Integer
' Dim DecimalValues(1 To 7) As Integer
' Dim InputString As String
' Dim i As Integer
' Dim j As Integer
' Dim ByteValue As Byte
' Dim Range As Integer
' Dim TimeDiff As Integer: ' time difference between pulses - try 8 first
' Dim BitNo As Single
' Dim MidPoint As Single
' Dim Remainder As Single
' Dim Total As Long
' Dim Checksum As Long
' Dim OutputString As String
' Dim v As Byte
' Dim BattVolts As Single
' Static ByteNumber As Integer
' Dim Percent As Single
' 'On Error GoTo ReadSerialError
' ' upload and the like can upset this subroutine as delays too long
' Label51.Caption = Status
' TimeDiff = 9
' Range = 2: '+/- this value from midpoint eg timediff=8 range = 2 = 4+/- 2 ie 2 to 6
' MidPoint = TimeDiff / 2
' Call ReadPort(9, v)
' AnalogInputs(9) = v
' If AnalogInputs(9) > 128 Then
' InputBit = 1
' Else
' InputBit = 0
' End If
' If Status = "" Then Status = "Waiting"
' If Status = "Waiting" And InputBit = 1 Then
' StartTime = Now
' InputString = ""
' For i = 1 To 7
' For j = 1 To 8
' InputBytes(i, j) = 0
' Next
' Next
' ByteNumber = 1
' Status = Str(ByteNumber)
' End If
' If StartTime = "" Then Exit Sub
' If Status = "Waiting" And InputBit = 0 Then Exit Sub
' ElapsedSecs = DateDiff("s", StartTime, Now)
' If ElapsedSecs > 2000 Then
' ' timed out so reset
' Status = "Waiting"
' Exit Sub
' End If
' BitNo = ElapsedSecs / TimeDiff
' BitNo = Int(BitNo)
' ' now check if in range
' Remainder = ElapsedSecs Mod TimeDiff
' If Remainder >= (MidPoint - Range) And Remainder <= (MidPoint + Range) Then
' If BitNo >= 1 And BitNo <= 8 Then
' InputBytes(ByteNumber, BitNo) = InputBit
' Label86.Caption = Str(ByteNumber) + " " + Str(BitNo) + " " + Str(InputBit)
' End If
' End If
' ' test if end of byte
' If BitNo > 9 Then
' If InputBit = 1 Then
' ' detected next positive edge
' BitNo = 0
' StartTime = Now: ' reset clock
' ByteNumber = ByteNumber + 1
' Status = Str(ByteNumber)
' End If
' End If
' ' display and store in array
' Label85.Caption = ""
' For i = 1 To 7
' InputString = ""
' For j = 1 To 8
' InputString = InputString + Trim(Str(InputBytes(i, j)))
' Next
' Call BinaryToDecimal(InputString, ByteValue)
' DecimalValues(i) = ByteValue
' Label85.Caption = Label85.Caption + Str(ByteValue) + " "
' Next
' ' turn into string last byte and bitno is overrun
' If BitNo > 12 Or ByteNumber > 7 Then
' ' process and store
' ByteNumber = 0
' Status = "Waiting"
' ' now check the checksum is valid
' Checksum = DecimalValues(7) * 256 + DecimalValues(6)
' Total = 0
' For i = 1 To 5
' Total = Total + DecimalValues(i)
' Next
'
' End If
' Exit Sub
'ReadSerialError: Label77.Caption = "Subroutine Error"
'End Sub
Sub ReadTopTankViaPostbox()
Dim OutputString As String
Dim Percent As Single
Dim BattVolts As Single
Dim Checksum As Integer
Dim Total As Integer
Dim BackupPercent As Single
' data is in PostboxValues(1,0 to 3)
Call Convert140mm(Str(PostboxValues(1, 0)), 51, 162, OutputString)
Label75.Caption = OutputString
Percent = Val(OutputString) * 100 / 140
Label76.Caption = Trim(Str(Int(Percent)))
Call Convert140mm(Str(PostboxValues(1, 1)), 28, 158, OutputString)
Label80.Caption = OutputString
Percent = Val(OutputString) * 100 / 140
Label87.Caption = Trim(Str(Int(Percent)))
Call Convert140mm(Str(PostboxValues(1, 2)), 60, 200, OutputString)
Label81.Caption = OutputString
Percent = Val(OutputString) * 100 / 140
Label82.Caption = Trim(Str(Int(Percent)))
Label63.Caption = Trim(Str(PostboxValues(1, 3)))
BattVolts = (Val(Label63.Caption) * 3 * 5) / 255: ' eg 134/255 multiply by 5V then by 3 as divided by 3 by resistors
Label64.Caption = Left(Trim(Str(BattVolts)), 4)
'Checksum = PostboxValues(2, 1) * 256 + PostboxValues(2, 0)
'Total = PostboxValues(1, 0) + PostboxValues(1, 1) + PostboxValues(1, 2) + PostboxValues(1, 3)
'Label59.Caption = Str(Total) + " " + Str(Checksum)
'If Total <> Checksum Then Label62.Caption = "F" + Label59.Caption
' Now read backup system
Label66.Caption = PostboxValues(2, 0): ' raw value
BackupPercent = PostboxValues(2, 0)
Call ConvertBackupValues(BackupPercent, 90, 97, 41, 58): ' sample, desired, samplelow, desiredlow
Label68.Caption = Trim(Str(BackupPercent))
' now do volts
Label59.Caption = Trim(Str(PostboxValues(2, 1)))
Percent = Val(Label59.Caption) * 100 / 196 ' calculate percentage
BattVolts = Percent * 10.5 / 100
BattVolts = Int(BattVolts * 10): ' round off to one decimal place
BattVolts = BattVolts / 10
Label67.Caption = Trim(Str(BattVolts))
End Sub
Sub SendDataToBus(DeviceNo As Integer, Byte1 As Integer, Byte2 As Integer, byte3 As Integer, Byte4 As Integer)
Dim Sum As Long
Dim LSB As Long
Dim MSB As Long
Dim BaudRate As Integer
Dim CommPort As Integer
Dim OutputString As String
On Error GoTo SendError
If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
BaudRate = 1200
CommPort = 2
MSComm1.Settings = Trim(Str(BaudRate)) + ",n,8,1"
MSComm1.CommPort = Trim(Str(CommPort))
Sum = Byte1 + Byte2 + byte3 + Byte4
MSB = Sum \ 256
LSB = Sum Mod 256
OutputString = "DataT" + Chr(Val(DeviceNo)) + Chr(Val(Byte1)) + Chr(Val(Byte2)) + Chr(Val(byte3)) + Chr(Val(Byte4)) + Chr(Val(LSB)) + Chr(Val(MSB))
MSComm1.PortOpen = True
MSComm1.Output = OutputString
MSComm1.PortOpen = False
Exit Sub
SendError: Exit Sub
End Sub
Sub ReadDataFromPostbox(BaudRate As Integer, CommPort As Integer, Timeout As Integer, ReturnFlag As String)
' use baudrate 1200 commport=2 and timeout=5
Dim i As Integer
Dim ReadString As String
Dim LineOfText As String
Dim StartTime As String
Dim RequestString As String
Dim AnyNewData As String
Dim AsciiChr As String
Dim Checksum As Long
Dim DataValue As Integer
Dim ReadChecksum As Long
Dim DeviceNo As Integer
Dim ByteNo As Integer
On Error GoTo ReadDataError
DeviceNo = 0: ByteNo = 0
MSComm1.CommPort = Str(CommPort)
MSComm1.Settings = Trim(Str(BaudRate)) + ",n,8,1"
MSComm1.RThreshold = 1
MSComm1.InputLen = 1
MSComm1.PortOpen = True
StartTime = Now
ReadString = ""
RequestString = "DataD2345678": ' Data+D plus dummy bytes
MSComm1.Output = RequestString
Do
If MSComm1.InBufferCount >= 1 Then Exit Do: ' got enough bytes
i = DateDiff("s", StartTime, Now)
If i > Timeout Then ReturnFlag = "Timeout": Exit Do
DoEvents
Loop
' sends back "Y" or "N" to indicate if any data
AnyNewData = MSComm1.Input
If AnyNewData = "Y" Then
'now read 128 bytes plus two checksum bytes
Do
If MSComm1.InBufferCount >= 130 Then Exit Do: ' got enough bytes
i = DateDiff("s", StartTime, Now)
If i > Timeout Then ReturnFlag = "Timeout": Exit Do
Loop
Checksum = 0
For i = 0 To 129
AsciiChr = MSComm1.Input
DataValue = Val(Asc(AsciiChr))
Select Case i
Case Is <= 127: Checksum = Checksum + DataValue
PostboxValues(DeviceNo, ByteNo) = DataValue
ByteNo = ByteNo + 1
If ByteNo = 4 Then ByteNo = 0: DeviceNo = DeviceNo + 1
Label54.Caption = Str(PostboxValues(1, 0)) + " " + Str(PostboxValues(1, 1)) + " " + Str(PostboxValues(1, 2)) + " " + Str(PostboxValues(1, 3))
Label25.Caption = Str(PostboxValues(3, 0)) + " " + Str(PostboxValues(3, 1)) + " " + Str(PostboxValues(3, 2))
Case 128: ReadChecksum = DataValue
Case 129: ReadChecksum = ReadChecksum + DataValue * 256
End Select
If ReadChecksum = Checksum Then ReturnFlag = "Checksum Valid" Else ReturnFlag = "Checksum Invalid"
Next
Else
' no data to read
If ReturnFlag <> "Timeout" Then ReturnFlag = "No new data"
End If
MSComm1.PortOpen = False
Exit Sub
ReadDataError: If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
End Sub

Sub UploadAllFiles()
Dim Success As Boolean
Dim NowTime As String
Dim H As String
Dim m As String
Dim StartIndex As String
Dim FinishIndex As String
Dim IndexUploadTime As Integer
Dim TimeNow As String
If InternetSlowPumpDisable = True And Check5.Value = 0 Then Exit Sub
' just one upload too slow disables uploads for the rest of the day
' too risky to do it any other way
' unless the check button says to do it
If Label7.Caption = "On" Then
Label11.Caption = "Disable - Sprnk"
Exit Sub ' no uploading if sprinklers on
End If
If Label10.Caption = "Pumping" Then
Label11.Caption = "Disable - Pump"
Exit Sub ' no uploading if pump on
End If
Label11.Caption = "Uploading..."
DoEvents
StartIndex = Now
Call UploadFile("index.htm", Success)
FinishIndex = Now
IndexUploadTime = DateDiff("s", StartIndex, FinishIndex)
If IndexUploadTime < 5 Then
' if network is slow then don't upload any more files
DoEvents
Call UploadFile("24Tank.txt", Success)
DoEvents
Call UploadFile("24Tank.jpg", Success)
DoEvents
Call UploadPictures
DoEvents
If Success = True Then
H = Hour(Now)
m = Minute(Now)
NowTime = H + ":" + m
Label11.Caption = "Uploaded @ " + NowTime
End If
Else
' taking way too long due to slow internet connection
Label11.Caption = "Slow, t=" + Trim(Str(IndexUploadTime)) + "s/5kb"
End If
LastUploadTime = IndexUploadTime
End Sub
Sub DisableUploads()
Dim TimeNow As String
If LastUploadTime > 25 And InternetSlowPumpDisable = False Then
InternetSlowPumpDisable = True
Label20.Caption = Str(LastUploadTime)
TimeNow = Now
Label11.Caption = "Disabled:" + TimeNow
End If
End Sub
Sub ResetUpload()
' done just after midnight
InternetSlowPumpDisable = False
End Sub
Sub GroupTotals()
Dim GroupTotals(1 To 9) As Integer
Dim i As Integer
Dim GroupNumber
Label58.Caption = ""
For i = 1 To 63
GroupNumber = Val(SolenoidGroup(i))
If GroupNumber <> 0 Then
GroupTotals(GroupNumber) = GroupTotals(GroupNumber) + Val(SolenoidTime(i))
End If
Next
For i = 1 To 4
Label58.Caption = Label58.Caption + "Group " + Trim(Str(i)) + "=" + Trim(Str(GroupTotals(i))) + " "
Next
End Sub
Sub ConvertBackupValues(ValueToConvert As Single, SampleHigh As Single, ActualHigh As Single, SampleLow As Single, ActualLow As Single)
Dim Ratio As Single
Dim NewValue As Single
Ratio = (SampleHigh - SampleLow) / (ActualHigh - ActualLow)
NewValue = ValueToConvert - SampleLow
NewValue = NewValue / Ratio
NewValue = NewValue + ActualLow
NewValue = Int(NewValue)
ValueToConvert = NewValue
End Sub
Sub ReadChairliftVolts()
Call SendDataToBus(7, 0, 1, 0, 0)
' data will be sent back and read back with group read
End Sub
Sub DisplayChairliftVolts()
Dim RawValue As Single
Dim Volts As Single
Dim DisplayVolts As Single
'22k/10k divider = 10/32k so to get volts x*3.2*5/255
' then tweak a bit based on multimeter value
RawValue = PostboxValues(4, 0)
Volts = RawValue * 3.22 * 5 / 255
DisplayVolts = Int(Volts * 100)
DisplayVolts = DisplayVolts / 100
Label72.Caption = Str(DisplayVolts)
End Sub
Sub ChairLiftCharge()
' charge for 10 minutes at a time
' if <13.0V then charge
'called once a minute
Static Countdown
Dim Volts As Single
Countdown = Countdown - 1
If Countdown <= 0 Then
Countdown = 0
Label28.Caption = "Ok"
Else
Label28.Caption = "++" + Trim(Str(Countdown))
End If
Volts = Val(Label72.Caption)
If Volts <= 13 And Volts > 2 Then
If Countdown = 0 Then
Countdown = 6 ' 6 minute cycle, so has 4 mins for volts to settle
Call SendDataToBus(7, 200, 0, 0, 0) ' 3 minutes
Label28.Caption = "++"
Call SendDataToBus(7, 200, 0, 0, 0) ' send again in case
End If
End If
End Sub

Main module common code subroutines

Option Compare Binary
Option Explicit
' sound
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'Declare Inp and Out for port I/O
Public Declare Function Inp Lib "inpout32.dll" Alias "Inp32" (ByVal PortAddress As Integer) As Integer
Public Declare Sub Out Lib "inpout32.dll" Alias "Out32" (ByVal PortAddress As Integer, ByVal Value As Integer)
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
' ftp declares
Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
' public variables
Public WindowString As String
Public RiverCalpeda As Boolean
Public DamSolenoid As Boolean
Public RiverRunTime As Integer
Public RiverMinute As Integer
Public StartRiverPercent As Single
Public VolumePerHour As Single
Public DamRuntime As Integer
Public PrinterPortDelay As Long
Public Port As Integer
Public OutPort As Integer
Public InPort As Integer
Public CtrlPort As Integer
Public CtrlPortVal As Byte
Public Sort(128) As String
Public FrontDoorLDR(1 To 10) As Integer
Public SortPointer(128) As Integer
Public Wrap As String
Public Cutup(1 To 20) As String
Public BoardAddress As Byte
Public BoardData As Byte
Public DigOut1 As Byte
Public DigOut2 As Byte
Public Relay(1 To 6) As Boolean
Public AnalogInputs(0 To 15) As Integer
Public SolenoidValue As Byte
Public Digout13 As Boolean
Public Digout14 As Boolean
Public Digout15 As Boolean
Public DigitalOutputs(0 To 15) As Boolean
Public Solenoid(0 To 63) As Boolean
Public SolenoidName(1 To 63) As String
Public SolenoidTime(1 To 63) As String
Public SolenoidGroup(1 To 63) As String
Public TankRecord(1 To 1440) As String
Public PostboxValues(0 To 31, 0 To 3) As Integer
Public TankRecordCount As Integer
'Public SprinklerResting As Boolean
Public SprinklerRunningCount As Integer
Public LightsAlwaysOn As Boolean
Public OverflowCount As Integer
Public ComputerName As String
Public LawnseedCount As Integer
Public AirArray(0 To 100) As Integer
Public SerialSprinklers(1 To 63) As Boolean
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Sub Main()
Load frmmain
frmmain.Show
End Sub
Sub SwapValues(a, b)
Dim c
c = a: a = b: b = c
End Sub

Sub ShellSort(n)
Dim sn As Integer
Dim ss As Integer
Dim a As Integer
Dim si As Integer
Dim sj As Integer
Dim na As Integer
Dim nb As Integer
Dim groupsize As Integer
Dim swapsize As Integer
Dim numberofsorts As Integer
Dim sk As Integer
Dim numberofswaps As Integer
Dim v1 As Integer
Dim v2 As Integer
Dim switchval As Integer
Dim numberofrecords As Integer
Dim newsp() As Integer
'works with sort(0)="" ie numberofrecords=1=sort(1) (option base 1)
numberofrecords = n
sn = numberofrecords: Sort(0) = ""
If sn < 1 Then SortPointer(0) = 0: Exit Sub
ss = (Int(Log(sn) / Log(2)) + 1): sn = 2 ^ ss: ' sn must be a power of 2
For a = numberofrecords + 1 To sn - 1: Sort(a) = Chr$(255): Next: ' guaranteed to be the last entry
For a = 1 To sn - 1: SortPointer(a) = a: Next
ReDim newsp(sn - 1): groupsize = 1
swapsize = sn / 2
For numberofsorts = 1 To ss
si = 0: sj = si + groupsize: sk = 0
For numberofswaps = 1 To swapsize
na = groupsize: nb = groupsize
Do
v1 = SortPointer(si): v2 = SortPointer(sj)
If Sort(v1) < Sort(v2) Then
switchval = 1: newsp(sk) = v1: na = na - 1: si = si + 1: sk = sk + 1
If na < 1 Then switchval = 2: Exit Do
Else
switchval = 2: newsp(sk) = v2: nb = nb - 1: sj = sj + 1: sk = sk + 1
If nb < 1 Then switchval = 1: Exit Do
End If
Loop
Select Case switchval
Case 1: For a = na To 1 Step -1
newsp(sk) = SortPointer(si): sk = sk + 1: si = si + 1
Next
Case 2: For a = nb To 1 Step -1
newsp(sk) = SortPointer(sj): sk = sk + 1: sj = sj + 1
Next
End Select
si = si + groupsize: sj = sj + groupsize
Next
groupsize = groupsize + groupsize: swapsize% = swapsize% / 2
For a = 0 To sn - 1: SortPointer(a) = newsp(a): Next
Next
End Sub
Sub CutUpString(MyString As String)
'pass string looks like a1|timer|input|output|etc
'returns cutup() array does not alter string
Dim LineToCutup As String
Dim Leftpt As Integer
Dim Rightpt As Integer
Dim Counter As Integer
LineToCutup = MyString
Erase Cutup
LineToCutup = LineToCutup + "|": Leftpt = 1
Rightpt = InStr(1, LineToCutup, "|")
Counter = 1
Do
Cutup(Counter) = Mid(LineToCutup, Leftpt, Rightpt - Leftpt)
Leftpt = Rightpt + 1
Rightpt = InStr(Leftpt, LineToCutup, "|")
If Rightpt = 0 Then Exit Do
Counter = Counter + 1
Loop
End Sub
Function coordstring$(a)
coordstring$ = LTrim$(Str$(a))
If Left$(coordstring$, 1) = "." Then coordstring$ = "0" + coordstring$
If Left$(coordstring$, 2) = "-." Then coordstring$ = "-0." + Mid$(coordstring$, 3)
End Function

Sub AussieDate(adate As String)
adate = Mid$(Date$, 4, 2) + "/" + Left$(Date$, 2) + "/" + Mid$(Date$, 7, 4)
End Sub

Sub SetPrinterPort()
' sets up printer port so all lines are 0V
' This avoids spurious signals when plugging and unplugging board.
OutPort = Port
InPort = OutPort + 1
CtrlPort = OutPort + 2
' Set all printer port pins to 0V
' outport = &H378: inport = &H379: ctrlport = &H37A:' standard IBM
CtrlPortVal = 0
CtrlPortVal = CtrlPortVal Or 2: ' AutoLFLow
CtrlPortVal = CtrlPortVal Or 8: ' SelectLow
CtrlPortVal = CtrlPortVal And 251: ' InitLow
CtrlPortVal = CtrlPortVal Or 1: ' Strobe low
Call OutControlPort
Call OutPrinterPort(0)
End Sub
Sub OutControlPort()
If ComputerName = "Garage" Then
Out CtrlPort, CtrlPortVal
Call PrinterPortWait
End If
End Sub
Sub OutPrinterPort(t As Byte)
If ComputerName = "Garage" Then
Out OutPort, t
Call PrinterPortWait
End If
End Sub
Sub Outbyte(b As Byte)
Call OutPrinterPort(b)
InitHigh
InitLow
End Sub
Sub PrinterPortWait()
Dim a As Long
For a = 1 To PrinterPortDelay
Next
End Sub
Sub TestPrinterPortSpeed(PrinterPortDelay As Long)
On Error GoTo SpdError
Dim start As Single
Dim Finish As Single
Dim a As Integer
Dim TotalTime As Single
'start = Timer
'For a = 1 To 30000
' Call OutPrinterPort(0)
'Next
'Finish = Timer
'TotalTime = Finish - start
'PrinterPortDelay = 70 / TotalTime
PrinterPortDelay = 1000
'Call ReadPrinterPortDelay
Exit Sub
SpdError: Close: PrinterPortDelay = 264: Exit Sub
End Sub
Sub ReadPrinterPortDelay()
On Error GoTo prnterror
Open "PrnDly.dat" For Input As #1
Input #1, PrinterPortDelay
Close #1
Exit Sub
prnterror: Close: Exit Sub
End Sub

Sub InitHigh()
CtrlPortVal = CtrlPortVal Or 4
Call OutControlPort
End Sub
Sub InitLow()
'init is pin 16 on IBM connector
CtrlPortVal = CtrlPortVal And 251
Call OutControlPort
End Sub
Sub SelectHigh()
' select is pin 17 on IBM connector
CtrlPortVal = CtrlPortVal And 247
Call OutControlPort
End Sub
Sub SelectLow()
CtrlPortVal = CtrlPortVal Or 8
Call OutControlPort
End Sub
Sub Strobe()
' pin 1 on IBM connector high then low
Call StrobeHigh
Call StrobeLow
End Sub
Sub StrobeHigh()
' pin 1 on IBM connector high then low
CtrlPortVal = CtrlPortVal And 254: ' Strobe high
Call OutControlPort
End Sub
Sub StrobeLow()
' pin 1 on IBM connector high then low
CtrlPortVal = CtrlPortVal Or 1: ' Strobe low
Call OutControlPort
End Sub
Sub AutoLFHigh()
' autolf is IBM pin 14
CtrlPortVal = CtrlPortVal And 253
Call OutControlPort
End Sub
Sub AutoLFLow()
CtrlPortVal = CtrlPortVal Or 2
Call OutControlPort
End Sub
Sub Delay(d As Single)
' delay of d seconds (increments of .1 secs)
Dim a As Single
a = Timer
Do
If Timer > a + d Then Exit Do: ' wait d seconds
Loop
End Sub
Sub byteto2hex(d As Byte, hx As String)
hx = Hex$(d)
If Len(hx) = 1 Then hx = "0" + hx
End Sub
Sub ReadNibble(Nibble As Byte)
Dim Inval As Byte
Dim v As Byte
Dim c As Integer
If MachineName = "Garage" Then
Inval = 0
v = Inp(InPort)
If v And 128 Then Inval = Inval Else Inval = Inval + 1
If v And 32 Then Inval = Inval + 2
If v And 16 Then Inval = Inval + 4
If v And 8 Then Inval = Inval + 8
Nibble = Inval
End If
End Sub
Sub OutBoardData(Data As Byte)
Call OutPrinterPort(Data)
Call AutoLFHigh
Call AutoLFLow
End Sub
Sub OutBoardAddress(Address As Byte)
Call OutPrinterPort(Address)
Call StrobeHigh
Call StrobeLow
End Sub
Sub DToA(Value As Byte)
' A0 is address byte
Call OutBoardData(Value)
Call BitFunction(0, True, BoardAddress)
Call OutBoardAddress(BoardAddress)
Call BitFunction(0, False, BoardAddress)
Call OutBoardAddress(BoardAddress)
End Sub
Sub BinaryToDecimal(Binary As String, Dec As Byte)
'pass 01010101 returns decimal value
Dec = 0
If Left(Binary, 1) = "1" Then Dec = Dec + 128
If Mid(Binary, 2, 1) = "1" Then Dec = Dec + 64
If Mid(Binary, 3, 1) = "1" Then Dec = Dec + 32
If Mid(Binary, 4, 1) = "1" Then Dec = Dec + 16
If Mid(Binary, 5, 1) = "1" Then Dec = Dec + 8
If Mid(Binary, 6, 1) = "1" Then Dec = Dec + 4
If Mid(Binary, 7, 1) = "1" Then Dec = Dec + 2
If Right(Binary, 1) = "1" Then Dec = Dec + 1
End Sub
Sub DecimalToBinary(Dec As Byte, Binary As String)
' pass 34 returns binary value
Binary = ""
If Dec And 1 Then Binary = "1" Else Binary = "0"
If Dec And 2 Then Binary = "1" + Binary Else Binary = "0" + Binary
If Dec And 4 Then Binary = "1" + Binary Else Binary = "0" + Binary
If Dec And 8 Then Binary = "1" + Binary Else Binary = "0" + Binary
If Dec And 16 Then Binary = "1" + Binary Else Binary = "0" + Binary
If Dec And 32 Then Binary = "1" + Binary Else Binary = "0" + Binary
If Dec And 64 Then Binary = "1" + Binary Else Binary = "0" + Binary
If Dec And 128 Then Binary = "1" + Binary Else Binary = "0" + Binary
End Sub
Sub BitFunction(Bit0To7 As Byte, BitValue As Boolean, Data As Byte)
' same as machine code bit
'eg bit 5,1 makes bit 5 of the data =1
Dim Binary As String
Dim Dec As Byte
Dim n As String
Dim i As Integer
If BitValue = True Then n = "1" Else n = "0"
Call DecimalToBinary(Data, Binary)
Select Case Bit0To7
Case 0: Binary = Left(Binary, 7) + n
Case 7: Binary = n + Mid(Binary, 2)
Case Else: i = 7 - Bit0To7
Binary = Left(Binary, i) + n + Mid(Binary, i + 2)
End Select
Call BinaryToDecimal(Binary, Dec)
Data = Dec
End Sub
Sub ChangeDigOut(OutPort As Byte, v As Byte)
' pass numbers rather than true/false
Dim VV As Boolean
If v = 0 Then VV = False Else VV = True
Call ChangeDigitalOutput(OutPort, VV)
End Sub

Sub ChangeDigitalOutput(Out0To15 As Byte, Value As Boolean)
Dim OutputNumber As Byte
Dim BitValue As Boolean
Dim DataByte As Byte
' sends to digout1 or digout2 - public variables
OutputNumber = Out0To15
BitValue = Value
Select Case OutputNumber
Case 0 To 7
Call BitFunction(OutputNumber, BitValue, DigOut1)
Call OutBoardData(DigOut1)
' now toggle A1
Call BitFunction(1, True, BoardAddress)
Call OutBoardAddress(BoardAddress)
Call BitFunction(1, False, BoardAddress)
Call OutBoardAddress(BoardAddress)
Case 8 To 15
DataByte = OutputNumber - 8
Call BitFunction(DataByte, BitValue, DigOut2)
Call OutBoardData(DigOut2)
' now toggle A2
Call BitFunction(2, True, BoardAddress)
Call OutBoardAddress(BoardAddress)
Call BitFunction(2, False, BoardAddress)
Call OutBoardAddress(BoardAddress)
End Select
End Sub
Sub ReadPort(PortNumber As Byte, AnalogValue As Byte)
' portnumber = 0 to 15
Dim TestByte As Byte
Dim Pin11 As Boolean
Dim i As Byte
' enable correct port
Select Case PortNumber
Case 0 To 7
Call BitFunction(6, False, BoardAddress)
Call BitFunction(7, True, BoardAddress)
' pin6 low for 4051 1
i = PortNumber
Case 8 To 15
Call BitFunction(7, False, BoardAddress)
Call BitFunction(6, True, BoardAddress)
' pin 6 low for 4051 2
i = PortNumber - 8
End Select
Select Case i
Case 0: Call Encode4051(0, 0, 0)
Case 1: Call Encode4051(0, 0, 1)
Case 2: Call Encode4051(0, 1, 0)
Case 3: Call Encode4051(0, 1, 1)
Case 4: Call Encode4051(1, 0, 0)
Case 5: Call Encode4051(1, 0, 1)
Case 6: Call Encode4051(1, 1, 0)
Case 7: Call Encode4051(1, 1, 1)
End Select
' have modified boardaddress so send now
Call OutBoardAddress(BoardAddress)
' now test value
TestByte = 128: ' set bit 7
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 128: ' reset bit 7
TestByte = TestByte + 64: 'set bit 6
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 64
TestByte = TestByte + 32: 'set bit 5
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 32
TestByte = TestByte + 16: 'set bit 4
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 16
TestByte = TestByte + 8: 'set bit 3
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 8
TestByte = TestByte + 4: 'set bit 2
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 4
TestByte = TestByte + 2: 'set bit 1
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 2
TestByte = TestByte + 1: 'set bit 0
Call DToA(TestByte)
Call ReadPin11(Pin11)
If Pin11 = False Then TestByte = TestByte - 1
AnalogValue = TestByte
End Sub
Sub Encode4051(a As Byte, b As Byte, c As Byte)
' modifies boardaddress
Dim d As Boolean
Dim e As Boolean
Dim f As Boolean
If a = 0 Then d = False Else d = True
If b = 0 Then e = False Else e = True
If c = 0 Then f = False Else f = True
Call BitFunction(3, d, BoardAddress)
Call BitFunction(4, e, BoardAddress)
Call BitFunction(5, f, BoardAddress)
End Sub
Sub ReadPin11(BitValue As Boolean)
Dim Nibble As Byte
Call ReadNibble(Nibble)
If Nibble And 1 Then
BitValue = True
Else
BitValue = False
End If
End Sub
Sub ConcreteUnitsToKilolitres(Units As Single, Kilolitres As Single)
'4.7.5=140 digital display = 55.5 inches = 141cm
'92ft=28 metres circumference
'8.91 metres diameter
'4.456 metres radius
'62.38 square metres
'
'5.3.5 = 185 on digital display =161.3cm''
'
'20.3cm=45 units
'1cm=.6238Kl
'45.11cm=100 units=28.14Kl
'1 unit=.2814Kl=281.4L

'base value is 140 units = 87.9558Kl
' 1 unit is .2814Kl
Dim KL As Single
Dim i As Single
Dim j As Long
i = Units - 140
KL = i * 0.2814
Kilolitres = 87.9558 + KL
' now truncate to one decimal places
j = Kilolitres * 10
Kilolitres = j / 10
End Sub
Sub ConcreteTankPercent(Units As Single, Percent As Single)
' 249=full
' 0= maybe 50%
Dim a As Single
a = Units / 2.49
a = a / 2
a = a + 50
Percent = a

End Sub
Public Function MachineName() As String
Dim sBuffer As String * 255
If GetComputerName(sBuffer, 255&) <> 0 Then
MachineName = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Else
MachineName = "(Not Known)"
End If
MachineName = UCase(Left(MachineName, 1)) + LCase(Mid(MachineName, 2))
End Function
Sub DownloadFile(Filename As String)
' note case must match
Dim lngINet
Dim LngINetConn
Dim blnRC
lngINet = InternetOpen("MyFTP Control", 1, vbNullString, vbNullString, 0)
LngINetConn = InternetConnect(lngINet, "ftp.users.on.net", 0, "moxhamj", "xxxxxx", 1, 0, 0)
blnRC = FtpGetFile(LngINetConn, Filename, Filename, 0, 0, 1, 0)
InternetCloseHandle LngINetConn
InternetCloseHandle lngINet
End Sub
Sub UploadFile(Filename As String, Success As Boolean)
' note case must match
Dim lngINet
Dim LngINetConn
Dim blnRC
lngINet = InternetOpen("MyFTP Control", 1, vbNullString, vbNullString, 0)
LngINetConn = InternetConnect(lngINet, "ftp.users.on.net", 0, "moxhamj", "xxxxxx", 1, 0, 0)
blnRC = FtpPutFile(LngINetConn, Filename, Filename, 2, 0): ' 2nd last figure = 1 for ascii and 2 for binary. Binary seems to work better
InternetCloseHandle LngINetConn
InternetCloseHandle lngINet
Success = blnRC
End Sub
Sub UploadPictures()
Dim Success As Boolean
Dim i As Integer
Dim UploadSourceName As String
For i = 1 To 8
UploadSourceName = "Camera" + Trim(Str(i)) + ".jpg"
Call UploadFile(UploadSourceName, Success)
DoEvents
Next
End Sub

Home