module1.bas

vb作的化学试剂测试程序

Attribute VB_Name = "Module1"

Public win_Flag As Integer
Public tele_Flag As Integer
Public chk_Flag As Integer
Public option_Flag As Integer
Public AbssOpt_Flag As Integer
Public light_Flag As Integer
Public cs_Stat_Flag As Integer
Public Chk3_Flag As Integer
Public Power_Suply, Light_Suply As Integer

Public signal_Val(7) As Integer
Public Chnn_Abs_flag As Single
Public dd_ABSstd() As String
Public Out() As Byte, Outb() As Byte, Order() As Byte

Public I100(7), I0(7), Istart(7), Iend(7) As Integer
Public ABSend(7), AbsStart(7), Def_ABSstd(7), ABSstd(7), ABSstay(7) As Single

Public YpId As String
Public YpNum(7) As String
Public Clk_Num As Integer
Public sPlash(2, 7, 30) As String
Public CSy_Sum As Integer

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function GetTickCount Lib "kernel32" () As Long

Public Function Get_Float(b0 As Byte, b1 As Byte, b2 As Byte, b3 As Byte) As Single

Dim A(3) As Byte
Dim B(3) As Byte

Dim i As Long
Dim Result As Single
        
A(0) = b0: A(1) = b1: A(2) = b2: A(3) = b3

'先用一个临时数组倒序数组A
   
For i = 0 To 3
  B(i) = A(3 - i)
Next
CopyMemory Result, B(0), 4

Get_Float = Result

End Function

'Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'Public Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
'Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Sub DbAbsstd_Select()

    Dim ii, jj As Integer

    Dim ddd As Date
    Dim ij, ji As Date
    Dim rs As Recordset
    Dim Connstring As String
    
    
    Dim db As Connection
    Set db = New Connection
    Set rs = New Recordset
      
    Connstring = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & Form1.App.Path & "\nycl.mdb"
    
    
    db.Errors.Clear
    On Error GoTo ErrP
    db.Open Connstring
    rs.Open "select Comp_Val as 对照, Chann_ID as 通道号, Jc_Date as 检测日期, Jc_time as 检测时间,Yp_Id as 样品号, Yp_dress as 产地, Yp_cls as 类别, Trans as 透光度, Absorb as 吸光度, Contrl as 抑制率  from nycl where Comp_Val=1 Order by Jc_Date and Jc_time ", db, adOpenStatic, adLockOptimistic
    If Val(rs.RecordCount) <= 0 Then
        MsgBox "数据库中没有对照数据！请在《设置管理》中进行对照设置！", , "警告"
        Exit Sub
    End If
    ReDim dd_ABSstd(Val(rs.RecordCount), 10)
    
    For j = 0 To Val(rs.RecordCount) - 1
        For i = 0 To 9
            If rs.Fields.Item(i) = Null Then
                dd_ABSstd(j, i) = ""
            Else
                dd_ABSstd(j, i) = rs.Fields.Item(i)
    
            End If
        Next i
        If rs.EOF Then
            Exit For
        Else
            rs.MoveNext
        End If
    Next j
    rs.Close
    
    ii = UBound(dd_ABSstd, 1)
    jj = UBound(dd_ABSstd, 2)
    If ii = 0 Then Exit Sub
    ij = dd_ABSstd(0, 2)
    ji = dd_ABSstd(0, 3)
    
    ddd = Date
    
    For i = 0 To ii - 1
        Select Case AbssOpt_Flag
            Case 0:
                
            Case 1:
            
            Case 2:
            
            Case 3:
            
            If dd_ABSstd(i, 2) > ij Then ij = dd_ABSstd(i, 2)
        End Select
    Next
ErrP: '
    If Err.Number = -2147467259 Then
        MsgBox "数据库错误！请检查数据库！", , "警告"
        menu_Query_db.Enabled = False
        menu_Test_Setup.Enabled = False
        menu_Setup.Enabled = False
        Exit Sub
    End If
End Sub

Sub YpId_Creat()
    Dim YY, mm, dd, hh, ss As String
    
    Select Case Val(Mid(Trim(Str(Date)), 3, 2))
        Case Is < 10
            YY = Mid(Trim(Str(Date)), 4, 1)
        Case Is >= 10
            YY = Chr(Val(Mid(Trim(Str(Date)), 3, 2)) + 55)
    End Select
    
    Select Case Val(Mid(Trim(Str(Date)), 6, 2))
        Case Is < 10
            mm = Mid(Trim(Str(Date)), 6, 1)
        Case Is >= 10
            mm = Chr(Val(Mid(Trim(Str(Date)), 6, 2)) + 55)
    End Select
    If Len(Trim(Str(Date))) = 8 Then
        dd = Mid(Trim(Str(Date)), 8, 1)
    Else
        dd = Mid(Trim(Str(Date)), 9, 2)
    End If
   ' a = Mid(Trim(Str(Time)), 1, 2)
   
    If Len(Str(Time)) = 7 Then
        hh = Chr(Val(Mid(Str(Time), 1, 1)) + 65)
        ss = Chr(Int(Val(Mid(Str(Time), 3, 2)) / 5) + 65)
    Else
        hh = Chr(Val(Mid(Str(Time), 1, 2)) + 65)
        ss = Chr(Int((Val(Mid(Str(Time), 4, 2))) / 5) + 65)
    End If
    YpId = YY & mm & dd & hh & ss
End Sub

Public Function Get_Csy_Absstd() As Single
    Dim K As Integer
    Dim S As String
    Dim DataS() As Byte
    
    Dim addH As Byte, addL As Byte
    Dim lenH As Byte, lenL As Byte
    
    Get_Csy_Absstd = 0
    
    If Form2.MSComm1.PortOpen = False Then Form2.MSComm1.PortOpen = True
    Form2.MSComm1.PortOpen = False
    Form2.MSComm1.PortOpen = True
    
    addH = Val("&H01"): addL = Val("&H40")
    lenH = Val("&H00"): lenL = Val("&H04")
     
    S = Chr$(addH) & Chr$(addL) & Chr$(lenH) & Chr$(lenL)
 
    Form2.MSComm1.Output = "RE" & S & vbKeyReturn           '读8通道数据
    For i = 0 To 200000
    Next i
    Do
        DoEvents
        
        K = Form2.MSComm1.InBufferCount

        If K > 1 Then
            ReDim DataS(K - 1)
            DataS = Form2.MSComm1.Input
            Exit Do
        End If
        
    Loop Until K >= 4
    
    Get_Csy_Absstd = Format(Get_Float(DataS(0), DataS(1), DataS(2), DataS(3)), "#.###")
    
    Form2.MSComm1.PortOpen = False
End Function

Sub Get_AbsStd_single()
    Dim Chanl_Str As String
    Dim ch_index As Integer
    If tele_Flag = 0 Then
        MsgBox "请检查测试仪与计算机的连接！", , "警告"
        Exit Sub
    End If
    Time_Daily (4)
    
    For i = 0 To 7
        If Form3.Check1(i).Value = 1 Then
            Chanl_Str = Chanl_Str & i + 1 & ", "
            Get_I100_Single (i)
        End If
    Next i

    Chanl_Str = Left(Chanl_Str, Len(Chanl_Str) - 2)
    
    For i = 0 To 7
        If Form3.Check1(i).Value = 1 Then GEt_I0_Single (i)
    Next i
    i = MsgBox("请在第" & Chanl_Str & "通道放入对照样品！", vbOKCancel, "提示")
    If i = 2 Then
        MsgBox "取消第" & Chanl_Str & "通道对照样品检测！", "提示"
        Exit Sub
    End If
    Time_Daily (10)
    For i = 0 To 7
        If Form3.Check1(i).Value = 1 Then GEt_Istart_Single (i)
    Next i
    
    Time_Daily (60) '(180)
    For i = 0 To 7
        If Form3.Check1(i).Value = 1 Then GEt_Iend_Single (i)
    Next i
    
    For ch_index = 0 To 7
        If Form3.Check1(ch_index).Value = 1 Then
            If Istart(ch_index) <> I0(ch_index) Then
                AbsStart(ch_index) = Log((I100(ch_index) - I0(ch_index)) / (Istart(ch_index) - I0(ch_index))) / Log(10)
            Else
                AbsStart(ch_index) = -1
            End If
            
            If Iend(ch_index) <> I0(ch_index) Then
                ABSend(ch_index) = Log((I100(ch_index) - I0(ch_index)) / (Iend(ch_index) - I0(ch_index))) / Log(10)
            Else
                ABSend(ch_index) = -1
            End If
            
            If ABSend(ch_index) <> AbsStart(ch_index) Then ABSstd(ch_index) = ABSend(ch_index) - AbsStart(ch_index)
            Insert_Absstd_Db_single (ch_index)
        End If
        
    Next ch_index
End Sub
Sub GEt_ABSstd_All()
    If tele_Flag = 0 Then
        MsgBox "请检查测试仪与计算机的连接！", , "警告"
        Exit Sub
    End If
    Time_Daily (4)
    GEt_I100_All
    GEt_I0_All (0)
    
    i = MsgBox("请在8个通道放入对照样品！", vbOKCancel, "提示")
    If i = 2 Then
        MsgBox "取消全部通道对照样品检测！", "提示"
        Exit Sub
    End If
    
    Time_Daily (10)
    GEt_Istart_All
    Time_Daily (180)
    
    Get_Iend_All
    

    For i = 0 To 7
        If Istart(i) <> I0(i) Then
            AbsStart(i) = Log((I100(i) - I0(i)) / (Istart(i) - I0(i))) / Log(10)
        Else
            AbsStart(i) = -1
        End If
        If Iend(i) <> I0(i) Then
            ABSend(i) = Log((I100(i) - I0(i)) / (Iend(i) - I0(i))) / Log(10)
        Else
            ABSend(i) = -1
        End If
        If ABSend(i) <> AbsStart(i) Then
            ABSstd(i) = ABSend(i) - AbsStart(i)
            Insert_Absstd_Db_single (i)
        End If
        
    Next i
    
End Sub
Sub Time_Daily(InterValu As Integer)
    Dim tm1 As Long
    tm1 = GetTickCount
    Do
        DoEvents
    Loop Until GetTickCount - tm1 >= InterValu * 500

End Sub

Function Tele_Test()
    Dim oUtt() As Byte
    Dim K As Integer
    
    If Form2.MSComm1.PortOpen = False Then Form2.MSComm1.PortOpen = True
    tele_Flag = 0
    '检测通信端口
    Do
        DoEvents
        Form2.MSComm1.Output = "CC" & vbKeyReturn
        Time_Daily (1)
        'For i = 0 To 5000
            K = Form2.MSComm1.InBufferCount
            If K > 0 Then
                ReDim oUtt(K)
            End If
        'Next i
        If K >= 2 Then
            oUtt = Form2.MSComm1.Input
            If oUtt(0) = Asc("R") Then
                tele_Flag = 1
                Form1.StatusBar1.Panels(1).Text = "通信端口：" & Form2.MSComm1.CommPort & "  " & "通信速率：9600,n,8,1"
                Tele_Test = 1
            End If
        End If
        If K = 0 Then
            Form2.MSComm1.PortOpen = False
            If Form2.MSComm1.CommPort = 1 Then