module3.bas

使用的是最小误差法的插补程序

Attribute VB_Name = "modMath"
    Option Explicit
Public Declare Sub SetMode Lib "rastruledll" (ByVal baseport As Integer, ByVal nMode As Byte)              '++
                                                                                                           '++
Public Declare Sub ClearInterruptFlag Lib "rastruledll" (ByVal baseport As Integer, ByVal nMode As Byte)   '++
Public Declare Sub ClearOriginFlag Lib "rastruledll" (ByVal baseport As Integer, ByVal nMode As Byte)      '++
Public Declare Sub ClearCounter Lib "rastruledll" (ByVal baseport As Integer, ByVal nMode As Byte)         '++
                                                                                                           '++
Public Declare Sub ResetAll Lib "rastruledll" (ByVal baseport As Integer, ByVal nMode As Byte)              '++
Public Declare Sub ResetOutEnable Lib "rastruledll" (ByVal baseport As Integer, ByVal nMode As Byte)       '++
Public Declare Sub ResetOutDisable Lib "rastruledll" (ByVal baseport As Integer, ByVal nMode As Byte)      '++
                                                                                                           '++
Public Declare Function ReadState Lib "rastruledll" (ByVal baseport As Integer) As Byte                    '++
Public Declare Function ReadDirect Lib "rastruledll" (ByVal baseport As Integer) As Byte                   '++
Public Declare Function ReadInterruptFlag Lib "rastruledll" (ByVal baseport As Integer) As Byte            '++
Public Declare Function ReadErroFlag Lib "rastruledll" (ByVal baseport As Integer) As Byte                 '++
Public Declare Function ReadCounter Lib "rastruledll" (ByVal baseport As Integer) As Long                  '++


Public Declare Function openDirectIO Lib "directio.dll" (ByVal hl As Long) As Byte

Public Declare Function mybeep Lib "vcdll.dll" () As Integer
Public Declare Function myout Lib "vcdll.dll" (ByVal base As Integer, ByVal value As Integer) As Integer
Public Declare Function myin Lib "vcdll.dll" (ByVal base As Integer) As Integer
'定义延时函数Sleep
Public Declare Sub sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

'声明VC库中的函数,对I/O进行读写的动态链接库（用vc编写）

Public Declare Function outportb Lib "inout.dll" (ByVal base As Integer, ByVal value As Integer) As Integer
Public Declare Function mydelay Lib "inout.dll" (ByVal wait As Integer) As Integer
Public Declare Function inportb Lib "inout.dll" (ByVal base As Integer) As Integer
Public RasterAddr(1 To 4) As Integer        '光栅卡的4个通道基地址
Public Const BaseAddrIO = &H340                'IO卡基地址
Public Const BaseAddrScale = &H350                 '光栅测量基地址
Public Const BaseBujin = &H378             '步进电机基地址
Public Shun(0 To 35534, 1 To 4) As Single   '瞬时值
Public SystemError(0 To 35535, 1 To 4) As Single    '系统误差
Public jump(1 To 4) As Single               '跳动量
Public bianhao As String                    '编号
Public MyMax(1 To 4) As Single        '测量距零点最大值
Public MyMin(1 To 4) As Single        '测量距零点最小值
Public Counter(1 To 5) As Integer     '各等级品的数量
Public ProNumber As Integer          '产品序号
Public Grade As String                '车轮等级





'对曲线全数据做剔除奇异项
'Public Sub Eliminate()
'Dim W1 As Single
'Dim W2 As Single
'Dim i As Integer
'Dim k As Integer
'Dim t As Integer
'Dim Xo(1 To 360/stepangle, 1 To 4) As Single
'W1 = 0.05                                       '误差限定
'W2 = 5 * W1
'k = 0

'For m = 1 To 4
'For i = 1 To 360  /stepangle                                '找起始点
'i = 3
'If Abs(Shun(i, m) - Shun(i - 1, m) - Shun(i - 1, m) + Shun(i - 2, m)) <= W1 Then
'   t = i
'Next i

'For i = t To 359
'Xo(i + 1, m) = 2 * Shun(i, m) - Shun(i - 1, m)
'E = Abs(Shun(i + 1, m) - Xo(i + 1, m))
'If E <= W1 Then
'   k = 0
'Else
'   k = k + 1
'   If k <= 2 Then
'      Shun(i + 1, m) = Xo(i + 1, m)
'   Else
'      If E < W2 Then
'         If k = 6 Then
'            k = 0
'         End If
'      Else
'         Shun(i + 1, m) = Xo(i + 1, m)
'      End If
'   End If
'Next i

'For i = t To 1 Step -1
'Xo(i) = 2 * Shun(i - 1, m) - Shun(i - 2, m)
'E = Abs(Shun(i, m) - Xo(i, m))
'If E <= W1 Then
'   k = 0
'Else
'   k = k + 1
'   If k <= 2 Then
'      Shun(i, m) = Xo(i, m)
'   Else
'      If E < W2 Then
'         If k = 6 Then
'            k = 0
'         End If
'      Else
'         Shun(i, m) = Xo(i, m)
'      End If
'   End If
'Next i
'Next m
'End Sub


'对曲线做实时剔除奇异项
Public Sub Eliminate(cta As Integer)
Dim W As Single
Dim E As Single
Dim Xo(1 To 4) As Single                     '预测值
W = 5                                  '误差限定
Dim m As Integer
For m = 1 To 4
    'If cta < 10 And m = 1 Then
    'MsgBox (Shun(cta - 1, m))
    'MsgBox (Shun(cta - 2, m))
    'End If
    Xo(m) = 2 * Shun(cta - 1, m) - Shun(cta - 2, m) '预测值
    E = Abs(Xo(m) - Shun(cta, m))
    If E <= W Then
    Else
        Shun(cta, m) = Xo(m)
    End If
Next m
End Sub
'对曲线做最小二乘法的拟合
Public Sub DoData()

Dim i As Integer            '循环变量
Dim xAve As Double          'X的平均值
    
Dim a(6) As Double                  '存储多项式的5个系数
Dim dt(3) As Double
Dim j As Integer, k As Integer
Dim g As Double
Dim z As Double, p As Double, c As Double, q As Double, d1 As Double, d2 As Double
Dim s(20) As Double, t(20) As Double, b(20) As Double
Dim m As Integer           '循环变量
Dim xSum As Double         '存储X的总和
Dim N As Integer

'首先获得最小二成拟合多项式的系数
For m = 1 To 4
    For i = 0 To 5
        a(i) = 0
    Next i
    z = 0
    For i = 4 To 362
        z = z + i / 360
    Next i
        b(0) = 1
        d1 = 360
        p = 0
        c = 0
    For i = 4 To 362
        p = p + i - z
        c = c + Shun(i, m)
    Next i
    c = c / d1
    p = p / d1
    a(0) = c * b(0)
        
    t(1) = 1
    t(0) = -1 * p
    d2 = 0
    c = 0
    g = 0
    For i = 4 To 362
        q = i - z - p
        d2 = d2 + q * q
        c = c + Shun(i, m) * q
        g = g + (i - z) * q * q
    Next i
               
    c = c / d2
    p = g / d2
    q = d2 / d1
    d1 = d2
    a(1) = c * t(1)
    a(0) = c * t(0) + a(0)
    For j = 2 To 5
        s(j) = t(j - 1)
        s(j - 1) = -p * t(j - 1) + t(j - 2)
        If (j >= 3) Then
            For k = 1 To j - 2
                s(j - 1 - k) = -p * t(j - 1 - k) + t(j - 2 - k) - q * b(j - 1 - k)
            Next k
        End If
        s(0) = -p * t(0) - q * b(0)
        d2 = 0
        c = 0
        g = 0
        For i = 4 To 362
            q = s(j)
            For k = 0 To j - 1
                q = q * (i - z) + s(j - 1 - k)
            Next k
            d2 = d2 + q * q
            c = c + Shun(i, m) * q
            g = g + (i - z) * q * q
        Next i
        c = c / d2
        p = g / d2
        q = d2 / d1
        d1 = d2
        a(j) = c * s(j)
        t(j) = s(j)
        For k = 0 To j - 1
            a(j - 1 - k) = c * s(j - 1 - k) + a(j - 1 - k)
            b(j - 1 - k) = t(j - 1 - k)
            t(j - 1 - k) = s(j - 1 - k)
        Next k
    Next j
    '===========================
    '获取系数结束
    '===========================
        

    xSum = 0
        
    For i = 4 To 362
        xSum = i + xSum
    Next i
    xAve = xSum / 360
    '根据多项式生成你和结果和最大值、最小值
    For i = 4 To 362
    '生成结果数组
        Shun(i, m) = a(0) + a(1) * (i - xAve) + a(2) * (i - xAve) * (i - xAve) _
            + a(3) * (i - xAve) * (i - xAve) * (i - xAve) + a(4) * (i - xAve) _
            * (i - xAve) * (i - xAve) * (i - xAve) + a(5) * (i - xAve) _
            * (i - xAve) * (i - xAve) * (i - xAve) * (i - xAve)
    Next i
Next m
End Sub
Public Sub JudgeMaxMin()
Dim MaxMin(1 To 2, 1 To 4) As Single    '最大值，最小值
Dim m As Integer, i As Integer
For m = 1 To 4
    '获得最大值、最小值和Y的总和
    MaxMin(1, m) = Shun(0, m) '最大值
    MaxMin(2, m) = Shun(0, m) '最小值
    For i = 1 To AllPlus / StepAngle
        If MaxMin(1, m) < Shun(i, m) Then MaxMin(1, m) = Shun(i, m)   '获得最大值
        If MaxMin(2, m) > Shun(i, m) Then MaxMin(2, m) = Shun(i, m)   '获得最小值
    Next i
    jump(m) = MaxMin(1, m) - MaxMin(2, m)
Next m
End Sub
Public Function GetGrade(Latitude As Single, Longitude As Single) As String

If Latitude <= CSng(txt1) Then
    If Longitude <= CSng(txt2) Then
        GetGrade = "合格品"
    ElseIf Longitude <= CSng(txt4) Then GetGrade = "一级处理品"
    ElseIf Longitude <= CSng(txt6) Then GetGrade = "二级处理品"
    ElseIf Longitude <= CSng(txt8) Then GetGrade = "返修品"
    Else
        GetGrade = "废品"
    End If
ElseIf Latitude <= CSng(txt3) Then
    If Longitude <= CSng(txt4) Then
        GetGrade = "一级处理品"
    ElseIf Longitude <= CSng(txt6) Then GetGrade = "二级处理品"
    ElseIf Longitude <= CSng(txt8) Then GetGrade = "返修品"
    Else
        GetGrade = "废品"
    End If
ElseIf Latitude <= CSng(txt5) Then
    If Longitude <= CSng(txt6) Then
        GetGrade = "二级处理品"
    ElseIf Longitude <= CSng(txt8) Then GetGrade = "返修品"
    Else
        GetGrade = "废品"
    End If
ElseIf Latitude <= CSng(txt7) Then
    If Longitude <= CSng(txt8) Then
        GetGrade = "返修品"
    Else
        GetGrade = "废品"
    End If
Else
    GetGrade = "废品"
End If
End Function
Public Function CreateBianHao() As String
Dim CurrentDate As Date
Dim ctmpBanOrder As Byte          '班号
Dim str() As String               '用于处理的字符串
Dim i As Integer                  '循环变量
Dim str1 As String                '用于处理日期字符串
Dim dateStr As String
Dim strGuiGe As String
Dim tmp As String
  
CurrentDate = Date                '获得当前的日期，格式如：01-8-10
  
str1 = CStr(CurrentDate)
str = Split(str1, "-")
For i = 0 To 2
    If (Len(str(i)) = 1) Then str(i) = "0" & str(i)
Next                              '处理日期字符串，8转换为08
  
ctmpBanOrder = CreatBanNumber()

ProNumber = ProNumber + 1       '生产序号加1
If Len(CStr(ProNumber)) = 1 Then
    tmp = "000" & CStr(ProNumber)
ElseIf Len(CStr(ProNumber)) = 2 Then
    tmp = "00" & CStr(ProNumber)
ElseIf Len(CStr(ProNumber)) = 3 Then
    tmp = "0" & CStr(ProNumber)
Else
    tmp = CStr(ProNumber)
End If
    
dateStr = str(0) & str(1) & str(2)       '返回处理后的字符串
  
CreateBianHao = dateStr & CStr(ctmpBanOrder) & tmp   '编号=日期+班次+生产序号
End Function
Public Function CreatBanNumber() As Byte
Dim CurrentTime As Date
Dim CurrentHour As Integer
CurrentTime = Time                '获得当前的系统时间，格式如：18:20:19
CurrentHour = Hour(CurrentTime)
If CurrentHour > 8 And CurrentHour < 18 Then
    CreatBanNumber = 1
Else
    CreatBanNumber = 2
End If
End Function