Option Explicit
Dim data(30) As Long
Dim ptr As Integer
Private Sub Class_Initialize()
Dim i As Integer
For i = 0 To 30
data(i) = -1
Next i
End Sub
'移動平均を計算する -1は無視される
Function average(str_val As String) As Long
Dim val As Long
On Error GoTo err
val = CLng(str_val)
On Error GoTo 0
If -1 <> val Then
data(ptr) = val
If 30 - 1 = ptr Then
ptr = 0
Else
ptr = ptr + 1
End If
Dim i As Integer
Dim pos As Long
pos = 0
For i = 0 To 30 - 1 Step 1
If -1 <> data(i) Then
pos = pos + data(i)
Else
Exit For
End If
Next i
average = Int(pos / i)
Exit Function
End If
err:
average = val
End Function
１、 目標がON → OFF になってから実際には１０分間 ON 状態を保つ、待機中に一瞬でも目標が ON になったらそこから実際には１０分間 ON 状態を保つ
(点灯状態は常に１０分以上連続する)
２、 目標がOFF → ON になってから実際には１分間 OFF 状態を保つ、待機中に一瞬でも目標が OFF になったらそこから実際には１分間 OFF 状態を保つ
(消灯状態は常に１分以上連続する)
３、 待機中に実際のON/OFF状態が変化したら（タイマーなどで ON/OFF が切り替わったら）リセットし不感時間が経過した事にする
４、 アプリの設定を即時反映するためにタイマーのリセット手段が必要(無いと設定後にタイマーがカウントアップするまで待つことになる)
Option Explicit
Dim timer As Long
Dim power_change As Integer
Dim power_real As Integer
Private Sub Class_Initialize()
power_change = 1
timer = 0
End Sub
'タイマーを減算する、現実の出力が変化したらリセットする
Public Sub clock(real As Integer)
If timer <> 0 Then
timer = timer - 1
Else
timer = 0
End If
If power_real <> real Then
power_real = real
timer = 0
End If
End Sub
'出力の変化を要請
Public Property Let Power(change As Integer)
If power_change = 1 And change = 0 Then
power_change = 0
'リレーがON状態からOFFの要請
timer = 60 / 2 '60秒のタイマーセット
ElseIf power_change = 0 And change = 1 Then
power_change = 1
'リレーがOFF状態からONの要請
timer = (10 * 60) / 2 '10分のタイマーセット
End If
End Property
'出力の状態を取得
Public Property Get Power() As Integer
If timer = 0 Then
Power = power_change
Else
Power = power_real
End If
End Property
'タイマーのリセット
Public Sub reset()
timer = 0
End Sub
'センサーの値を判定する sensor センサーの値 real_output 現在の出力 enable 有効/無効
Public Function calc(sensor As Long, real_output As Integer, enable As Integer) As Integer
If 1 = enable Then
If sensor > 400 Then
calc = 0
ElseIf sensor < 350 Then
calc = 1
Else
calc = real_output
End If
Else
calc = 0
End If
End Function
'自動制御にて関数開始状態を設定する変数 初期値:0
Public auto_control_func_next_state_setting As Integer
Public Const NONE_SETTING = 0 '何もしない
Public Const ENABLE_SETTING_1 = 1 '有効
Public Const DISABLE_SETTING_0 = -1 '無効
Option Explicit
Dim threshold_ As New threshold
Dim map1() As Variant
Dim map1_w As Long
Private Sub Class_Initialize()
'数列の作成
map1 = Array( _
0, 900, 1100, 1300, 1500, 2400, _
380, 380, 385, 385, 380, 380 _
)
'数列の幅を計算
map1_w = (UBound(map1) + 1) / 2
End Sub
'線形補間のマクロ
Private Function INTERP(xi As Long, xi1 As Long, yi As Long, yi1 As Long, x As Long) As Long
INTERP = (yi + (((yi1 - yi) * (x - xi)) / (xi1 - xi)))
End Function
'線形補間 x:補間する値 ar:数列 w:数列の横の長さ
Private Function interp1dim(x As Long, ByRef ar_() As Variant, w As Long) As Long
Dim i As Long
'xの値が範囲外の場合はxが最大最小値の値を返す
If x <= ar_(0) Then
interp1dim = ar_(w)
Exit Function
ElseIf x >= ar_(w - 1) Then
interp1dim = ar_(w * 2 - 1)
Exit Function
End If
For i = 0 To (w - 1) Step 1
If ar_(i) >= x Then Exit For
Next i
' y=yi + (yi+1-yi)(x-xi)/(xi+1-xi) を行い値を返す
interp1dim = INTERP(CLng(ar_(i - 1)), CLng(ar_(i)), CLng(ar_(i + w - 1)), CLng(ar_(i + w)), x)
End Function
'センサーの値を判定する sensor センサーの値 real_output 現在の出力 enable 有効/無効
Public Function calc(sensor As Long, real_output As Integer, enable As Integer) As Integer
Dim str As String
str = Format(Now, "HH:MM:ss")
Dim m, h, v, pos As Long
m = CLng((CLng(Mid(str, 4, 2)) / 60) * 100)
h = CLng(Mid(str, 1, 2) & "00")
v = h + m
pos = interp1dim(CLng(v), map1, map1_w)
'Form1.Caption = CStr(pos) + " " + CStr(350) 'デバッグのため
Call threshold_.setThreshold(pos, 350)
calc = threshold_.calc(sensor, real_output, enable)
End Function
改良２
他のアプリで値を利用するために値を特定のファイルに連続上書きする関数を作成しました。
Private Sub share_data_file(str As String, filename As String)
改行なしでファイルに毎度、上書き保存します。
同一ファイルの連続保存のため基本的にキャッシュの中で処理されるためディスクの負荷は少ないと思います。
今回追加した機能と、他の改良を取り込んだソースはこちらですversion 0_14_4_1
Private Sub Timer1_Timer()
If sleep_timer1 > 0 Then 'timer1を一時的に停止する
sleep_timer1 = sleep_timer1 - 1
Exit Sub
End If
On Error GoTo Err1
Do
MSComm1.Output = "r" & vbCr & vbLf
Loop While MSComm1.OutBufferCount >= 1
Do
MSComm1.Output = "r" & vbCr & vbLf
Loop While MSComm1.OutBufferCount >= 1
Do
MSComm1.Output = "a" & vbCr & vbLf
Loop While MSComm1.OutBufferCount >= 1
Do
MSComm1.Output = "a" & vbCr & vbLf
Loop While MSComm1.OutBufferCount >= 1
Do
MSComm1.Output = "x" & vbCr & vbLf
Loop While MSComm1.OutBufferCount >= 1
Do
MSComm1.Output = "x" & vbCr & vbLf
Loop While MSComm1.OutBufferCount >= 1
On Error GoTo 0
Dim str As String
Dim st_arry() As String
Do While data_ptr <> 0
str = pop()
If Mid(str, 1, 1) = "x" Then
com_x_data_old = com_x_data
com_x_data = str
If com_x_data = com_x_data_old Then
st_arry = Split(com_x_data, ",")
Text5.Text = Replace(st_arry(1), vbCrLf, "") '最後のCRLFを取り除く
End If
End If
If Mid(str, 1, 1) = "r" Then
com_r_data_old = com_r_data
com_r_data = str
If com_r_data = com_r_data_old Then
digital_pin(0) = CInt(Mid(str, 3, 1))
digital_pin(1) = CInt(Mid(str, 4, 1))
digital_pin(2) = CInt(Mid(str, 5, 1))
digital_pin(3) = CInt(Mid(str, 6, 1))
digital_pin(4) = CInt(Mid(str, 7, 1))
digital_pin(5) = CInt(Mid(str, 8, 1))
digital_pin(6) = CInt(Mid(str, 9, 1))
digital_pin(7) = CInt(Mid(str, 10, 1))
digital_pin(8) = CInt(Mid(str, 11, 1))
digital_pin(9) = CInt(Mid(str, 12, 1))
End If
End If
If Mid(str, 1, 1) = "a" Then
com_a_data_old = com_a_data
com_a_data = str
If com_a_data = com_a_data_old Then
'Dim st_arry() As String 変数宣言を削除
st_arry = Split(com_a_data, ",")
Text1(0).Text = st_arry(1)
Text1(1).Text = st_arry(2)
Text1(2).Text = st_arry(3)
以下続くため省略
