frm_hfecg2.frm

在VB上采用改进的阈值法检测心电高频向量

If HScroll12.Value > X Then
Picture12.Cls
X = HScroll12.Value
Picture12.Scale (X, Lmax + Lmax * 0.25)-(X + 2000, Lmin + Lmin * 0.25)
For k = X To X + 1999 Step 1
Picture12.Line (k, HFECG12(k))-(k + 1, HFECG12(k + 1))
Next k
Else
Picture12.Cls
X = HScroll12.Value
Picture12.Scale (X, Lmax + Lmax * 0.25)-(X + 2000, Lmin + Lmin * 0.25)
For k = X To X + 1999 Step 1
Picture12.Line (k, HFECG12(k))-(k + 1, HFECG12(k + 1))
Next k
End If
End Sub

Private Sub HScroll2_Change()
Static X As Integer
If HScroll2.Value > X Then
Picture2.Cls
X = HScroll2.Value
Picture2.Scale (X, Bmax + Bmax * 0.25)-(X + 2000, Bmin + Bmin * 0.25)
For k = X To X + 1999 Step 1
Picture2.Line (k, HFECG2(k))-(k + 1, HFECG2(k + 1))
For i = 2 To 4
If rpt2(i) > X And rpt2(i) < X + 1999 Then
Picture2.CurrentX = q2(i)
Picture2.CurrentY = HFECG2(q2(i))
Picture2.Print "q"
Picture2.CurrentX = s2(i)
Picture2.CurrentY = HFECG2(s2(i))
Picture2.Print "s"
Picture2.CurrentX = rpt2(i)
Picture2.CurrentY = HFECG2(rpt2(i))
Picture2.Print "R"
End If
Next i
Next k

Else
Picture2.Cls
X = HScroll2.Value
Picture2.Scale (X, Bmax + Bmax * 0.25)-(X + 2000, Bmin + Bmin * 0.25)
For k = X To X + 1999 Step 1
Picture2.Line (k, HFECG2(k))-(k + 1, HFECG2(k + 1))
Next k
End If
End Sub

Private Sub HScroll3_Change()
Static X As Integer
If HScroll3.Value > X Then
Picture3.Cls
X = HScroll3.Value
Picture3.Scale (X, Cmax + Cmax * 0.25)-(X + 2000, Cmin + Cmin * 0.25)
For k = X To X + 1999 Step 1
Picture3.Line (k, HFECG3(k))-(k + 1, HFECG3(k + 1))
Next k
For i = 2 To 4
If rpt3(i) > X And rpt3(i) < X + 1999 Then
Picture3.CurrentX = q3(i)
Picture3.CurrentY = HFECG3(q3(i))
Picture3.Print "q"
Picture3.CurrentX = s3(i)
Picture3.CurrentY = HFECG3(s3(i))
Picture3.Print "s"
Picture3.CurrentX = rpt3(i)
Picture3.CurrentY = HFECG3(rpt3(i))
Picture3.Print "R"
End If
Next i
Else
Picture3.Cls
X = HScroll3.Value
Picture3.Scale (X, Cmax + Cmax * 0.25)-(X + 2000, Cmin + Cmin * 0.25)
For k = X To X + 1999 Step 1
Picture3.Line (k, HFECG3(k))-(k + 1, HFECG3(k + 1))
Next k
End If
End Sub

Private Sub HScroll4_Change()
Static X As Integer
If HScroll4.Value > X Then
Picture4.Cls
X = HScroll4.Value
Picture4.Scale (X, Dmax + Dmax * 0.25)-(X + 2000, Dmin + Dmin * 0.25)
For k = X To X + 1999 Step 1
Picture4.Line (k, HFECG4(k))-(k + 1, HFECG4(k + 1))
Next k
Else
Picture4.Cls
X = HScroll4.Value
Picture4.Scale (X, Dmax + Dmax * 0.25)-(X + 2000, Dmin + Dmin * 0.25)
For k = X To X + 1999 Step 1
Picture4.Line (k, HFECG4(k))-(k + 1, HFECG4(k + 1))
Next k
End If
End Sub

Private Sub HScroll5_Change()
Static X As Integer
If HScroll5.Value > X Then
Picture5.Cls
X = HScroll5.Value
Picture5.Scale (X, Emax + Emax * 0.25)-(X + 2000, Emin + Emin * 0.25)
For k = X To X + 1999 Step 1
Picture5.Line (k, HFECG5(k))-(k + 1, HFECG5(k + 1))
Next k
Else
Picture5.Cls
X = HScroll5.Value
Picture5.Scale (X, Emax + Emax * 0.25)-(X + 2000, Emin + Emin * 0.25)
For k = X To X + 1999 Step 1
Picture5.Line (k, HFECG5(k))-(k + 1, HFECG5(k + 1))
Next k
End If
End Sub

Private Sub HScroll6_Change()
Static X As Integer
If HScroll6.Value > X Then
Picture6.Cls
X = HScroll6.Value
Picture6.Scale (X, Fmax + Fmax * 0.25)-(X + 2000, Fmin + Fmin * 0.25)
For k = X To X + 1999 Step 1
Picture6.Line (k, HFECG6(k))-(k + 1, HFECG6(k + 1))
Next k
Else
Picture6.Cls
X = HScroll6.Value
Picture6.Scale (X, Fmax + Fmax * 0.25)-(X + 2000, Fmin + Fmin * 0.25)
For k = X To X + 1999 Step 1
Picture6.Line (k, HFECG6(k))-(k + 1, HFECG6(k + 1))
Next k
End If
End Sub

Private Sub HScroll7_Change()
Static X As Integer
If HScroll7.Value > X Then
Picture7.Cls
X = HScroll7.Value
Picture7.Scale (X, Gmax + Gmax * 0.25)-(X + 2000, Gmin + Gmin * 0.25)
For k = X To X + 1999 Step 1
Picture7.Line (k, HFECG7(k))-(k + 1, HFECG7(k + 1))
Next k
Else
Picture7.Cls
X = HScroll7.Value
Picture7.Scale (X, Gmax + Gmax * 0.25)-(X + 2000, Gmin + Gmin * 0.25)
For k = X To X + 1999 Step 1
Picture7.Line (k, HFECG7(k))-(k + 1, HFECG7(k + 1))
Next k
End If
End Sub

Private Sub HScroll8_Change()
Static X As Integer
If HScroll8.Value > X Then
Picture8.Cls
X = HScroll8.Value
Picture8.Scale (X, Hmax + Hmax * 0.25)-(X + 2000, Hmin + Hmin * 0.25)
For k = X To X + 1999 Step 1
Picture8.Line (k, HFECG8(k))-(k + 1, HFECG8(k + 1))
Next k

For i = 2 To 4
If rpt8(i) > X And rpt8(i) < X + 1999 Then
Picture8.CurrentX = q8(i)
Picture8.CurrentY = HFECG8(q8(i))
Picture8.Print "q"
Picture8.CurrentX = s8(i)
Picture8.CurrentY = HFECG8(s8(i))
Picture8.Print "s"
Picture8.CurrentX = rpt8(i)
Picture8.CurrentY = HFECG8(rpt8(i))
Picture8.Print "R"
End If
Next i

Else
Picture8.Cls
X = HScroll8.Value
Picture8.Scale (X, Hmax + Hmax * 0.25)-(X + 2000, Hmin + Hmin * 0.25)
For k = X To X + 1999 Step 1
Picture8.Line (k, HFECG8(k))-(k + 1, HFECG8(k + 1))
Next k
End If
End Sub

Private Sub HScroll9_Change()
Static X As Integer
If HScroll9.Value > X Then
Picture9.Cls
X = HScroll9.Value
Picture9.Scale (X, Imax + Imax * 0.25)-(X + 2000, Imin + Imin * 0.25)
For k = X To X + 1999 Step 1
Picture9.Line (k, HFECG9(k))-(k + 1, HFECG9(k + 1))
Next k
Else
Picture9.Cls
X = HScroll9.Value
Picture9.Scale (X, Imax + Imax * 0.25)-(X + 2000, Imin + Imin * 0.25)
For k = X To X + 1999 Step 1
Picture9.Line (k, HFECG9(k))-(k + 1, HFECG9(k + 1))
Next k
End If
End Sub




Public Sub FindR(p(), fr(), a())
Dim z1, z2
Dim z3

Dim n, s, m, h

'n = 0
'For i = 2 To 8398
'j = p(i - 2) + 4 * p(i - 1) + 6 * p(i) + 4 * p(i + 1) + p(i + 2)
'fr(n) = j
'n = n + 1
'Next i


n = 0
For i = 2 To 8398
j = p(i) - p(i - 1)
fr(n) = j
n = n + 1
Next i








m = fr(0)
For k = 0 To 4199
If fr(k + 1) > m Then
m = fr(k + 1)
Else
End If
Next k


s = fr(4200)
For k = 4200 To 8399
If fr(k + 1) > s Then
s = fr(k + 1)
Else
End If
Next k


h = (s + m) / 2


z1 = 2 * h / 5
z2 = 2 * h / 5 + 0.01
z3 = 2 * h / 9
k = 0
For i = 0 To 8400
If Abs(fr(i)) > z1 Then
   i = i + 1
If Abs(fr(i)) > z2 Then
  n = 0
Do
  i = i + 1
  n = n + 1
  If i > 8400 Then
  Exit Do
  End If
If fr(i) < 0 Then
If Abs(fr(i)) > z3 Then
  k = k + 1
  a(k) = i - n
If k > 2 Then
Exit Do
End If
Else: End If
Else: End If
Loop Until n = 1000
  
  
  If k > 1 Then
   h1 = Abs(fr(a(k - 1)))
For Y = a(k - 1) To a(k)
  If Abs(fr(Y + 1)) > h1 Then
 h1 = Abs(fr(Y + 1))
 End If
 Next Y
If h1 > h Then
      z1 = h1 / 4 + h1 / 10
      z2 = h1 / 4 + h1 / 10 + 0.01
      z3 = h1 / 8 + h1 / 10
Else: End If
End If
End If
End If
Next i
    
End Sub

Public Sub Rpoint(g(), p(), q())
For i = 0 To 49
If p(i + 1) - p(i) < 100 Then

If Abs(g(p(i + 1))) > Abs(g(p(i))) Then

q(n) = i + 1

End If
Else: n = n + 1
End If
Next i

End Sub



Public Sub Lvbo(X(), h(), d())
Dim d1(8400), d11(8400), d2(8400), d22(8400)
For n = 0 To 8400
d1(n) = Abs(h(n + 1) - h(n))
Next n
For n = 1 To 8398
d11(n) = (d1(n + 1) + 3 * d1(n) + d1(n - 1)) / 5
Next n
For n = 2 To 8399
d2(n) = Abs(h(n) - 2 * h(n - 1) + h(n - 2))
Next n
For n = 1 To 8398
d22(n) = (d2(n + 1) + 3 * d2(n) + d2(n - 1)) / 5
Next n
For n = 2 To 8399
d(n) = d22(n) + d11(n)
Next n



End Sub

Public Sub jz1(j(), p(), na(), nb(), jza(), jzb())


For i = 1 To 4
jza(i) = j(p(i))
For k = p(i) To p(i) + 500
If j(k + 1) > jza(i) Then
jza(i) = j(k + 1)
na(i) = k + 1
Else: End If
Next k
Next i

For i = 1 To 4
jzb(i) = j(p(i))

If p(i) > 500 Then
For k = p(i) - 500 To p(i)
If j(k + 1) > jzb(i) Then
jzb(i) = j(k + 1)
nb(i) = k + 1
Else: End If
Next k
End If
Next i


End Sub

Public Sub rposit(a(), b(), c())
For i = 1 To 4
c(i) = a(b(i))
Next i
End Sub

Public Sub QSpt(a(), b(), c(), d())
Dim t, m
For i = 1 To 4
m = a(b(i))
If b(i) > 500 Then
For k = b(i) - 500 To b(i) - 10  '''shenme
t = a(k) - m / 2
If t < 0.00001 Then
c(i) = k
End If
Next k
End If
Next i


For i = 1 To 4
m = a(b(i))
For k = b(i) To b(i) + 200
t = a(k) - m / 4
If t < 0.00001 Then
d(i) = k
End If
Next k
Next i

End Sub

Public Sub qieji(s(), e(), a(), d())   'd()是切迹的位置，b（）是零点的位置
 Dim Y(5 To 8500): Dim n: Dim t As Integer
 Dim b(1000), c(1000)
   If s(1) > 5 Then
   k = 1
   n = 2
 For m = 1 To 4
 If e(m) > 1 And s(m) > 1 Then
 For i = s(m) To e(m)
 If i > 5 Then
   Y(i) = (-5) * a(i - 5) + (-4) * a(i - 4) + (-3) * a(i - 3) + (-2) * a(i - 2) - a(i - 1) + a(i + 1) + 2 * a(i + 2) + 3 * a(i + 3) + 4 * a(i + 4) + 5 * a(i + 5)
   End If
Next i
 
 For i = s(m) To e(m)
 If i > 5 Then
 If Y(i) * Y(i + 1) <= 0 Then
 If Abs(Y(i)) > Abs(Y(i + 1)) Then
 b(n) = i + 1
 Else: b(n) = i
 End If
 n = n + 1
 End If
 End If
 Next i

 
 
 b(n + 1) = e(m) + 40
 b(1) = s(m) - 30
 

 For i = 2 To n - 1
 If (b(i + 1) - b(i)) < 14 And (b(i + 1) - b(i)) > 4 Then
 c(k) = i
 k = k + 1
 End If
 Next i
 End If

 Next m
  
  
  If c(1) > 1 Then
 If (b(c(1) + 1) - b(c(1))) > (b(c(1)) - b(c(1) - 1)) Then '修改
 d(1) = b(c(1))
 Else
 d(1) = b(c(1) + 1)
 End If
 
 
 slope = Y(b(c(1)) - 1) - Y(b(c(1)) + 1)
 t = 2
 For i = c(1) To c(k - 1)
  slope1 = Y(b(i) - 1) - Y(b(i) + 1)
 If slope1 * slope > 0 Then
 d(t) = b(i)
 Else: i = i + 1: d(t) = b(i)
 End If
 t = t + 1
 Next i
 End If
End If
End Sub

Public Sub niujie(s(), e(), a(), d())
 Dim Y(8500): Dim n: Dim t As Integer
 Dim y1(8500)
 Dim b(500), c(500)
   If s(1) > 5 Then
   k = 1
   n = 2
 For m = 1 To 4
 If s(m) > 100 And e(m) > 100 Then
 For i = s(m) To e(m)
 If i > 5 Then
   Y(i) = (-5) * a(i - 5) + (-4) * a(i - 4) + (-3) * a(i - 3) + (-2) * a(i - 2) + (-a(i - 1)) + a(i + 1) + 2 * a(i + 2) + 3 * a(i + 3) + 4 * a(i + 4) + 5 * a(i + 5)
   End If
Next i
 For i = s(m) To e(m)
 If i > 5 Then
   y1(i) = (-5) * Y(i - 5) + (-4) * Y(i - 4) + (-3) * Y(i - 3) + (-2) * Y(i - 2) + (-Y(i - 1)) + Y(i + 1) + 2 * Y(i + 2) + 3 * Y(i + 3) + 4 * Y(i + 4) + 5 * Y(i + 5)
   End If
Next i
 
 For i = s(m) To e(m)
 If i > 5 Then
 If y1(i) * y1(i + 1) <= 0 Then
 If Abs(y1(i)) > Abs(y1(i + 1)) Then
 b(n) = i + 1
 Else: b(n) = i
 End If
 n = n + 1
 End If
 End If
 Next i

 
 
 b(n + 1) = e(m) + 40
 b(1) = s(m) - 30
 

 For i = 2 To n - 1
 If (b(i + 1) - b(i)) < 14 And (b(i + 1) - b(i)) > 4 Then
 c(k) = i
 k = k + 1
 End If
 Next i
 End If

 Next m
  
 If (b(c(1) + 1) - b(c(1))) > (b(c(1)) - b(c(1) - 1)) Then '修改
 d(1) = b(c(1))
 Else
 d(1) = b(c(1) + 1)
 End If
 
 
 slope = y1(b(c(1)) - 1) - y1(b(c(1)) + 1)
 t = 2
 For i = c(1) To c(k - 1)
  slope1 = y1(b(i) - 1) - y1(b(i) + 1)
 If slope1 * slope > 0 Then
 d(t) = b(i)
 Else: i = i + 1: d(t) = b(i)
 End If
 t = t + 1
 Next i
End If
End Sub


Public Sub countqj(a(), n)
n = 0
For i = 0 To 50
If a(i) > 0 Then
n = n + 1
End If
Next i
End Sub


Public Sub countnc(a(), n)
n = 0
For i = 0 To 50
If a(i) > 0 Then
n = n + 1
End If
Next i
End Sub