basfun.bas

气体流动仪控制软件 属于工业控制软件 delphi开发

'   Sorts an array using bubble sort algorithm
'flg=0 Desc flg=1 Asc

    Dim First As Double, Last As Double
    Dim i As Integer, j As Integer
    Dim Temp As Double
    
    First = LBound(List())
    Last = UBound(List())
    If flg = 0 Then
        For i = First To Last - 1
            For j = i + 1 To Last
                If List(i) < List(j) Then
                    Temp = List(j)
                    List(j) = List(i)
                    List(i) = Temp
                End If
            Next j
        Next i
    Else
        For i = First To Last - 1
            For j = i + 1 To Last
                If List(i) > List(j) Then
                    Temp = List(j)
                    List(j) = List(i)
                    List(i) = Temp
                End If
            Next j
        Next i
    End If
End Sub




Function getmax(val1() As Double, flg As Integer) As Double
Dim i, j As Long
i = LBound(val1())
j = UBound(val1())
getmax = CDbl(val1(i))
For K = i + 1 To j
If flg = 0 Then
    If getmax > CDbl(val1(K)) Then getmax = CDbl(val1(K))
Else
    If getmax < CDbl(val1(K)) Then getmax = CDbl(val1(K))
End If
Next K
End Function

Public Sub RectoXls(Rec As ADODB.Recordset, fname As String) ''记录集到Excel文件
On Error GoTo h
Dim i&, j&, rowcount&, colcount&
Dim ExcelSheet As Object

Dim K As Long, L As Long
    Rec.MoveFirst
    Rec.MoveLast
    Rec.MoveFirst
    i& = Rec.RecordCount
    j& = Rec.Fields.count
    If fname = "" Then Exit Sub

    Set ExcelSheet = CreateObject("Excel.Sheet")
    Set ExcelSheet = ExcelSheet.Application.ActiveWorkbook.ActiveSheet

    ExcelSheet.Application.Visible = False
    For K = 1 To i
        For L = 1 To j
        ExcelSheet.Cells(1, L) = CStr(Rec.Fields(L - 1).Name)
        If L = j Then
            ExcelSheet.Cells(K + 1, L) = Year(Rec.Fields(L - 1)) & "年" & Month(Rec.Fields(L - 1)) & "月" & Day(Rec.Fields(L - 1)) & "日"
        Else
            ExcelSheet.Cells(K + 1, L) = CStr(Rec.Fields(L - 1) & " ")
        End If

    Next L
    Rec.MoveNext
    Next K

    ExcelSheet.SaveAs fname
    ExcelSheet.Application.Quit
    Set ExcelSheet = Nothing
    MsgBox "保存成功！", vbInformation, "提示："
    Exit Sub

h:
    MsgBox "保存到Excel失败：" & Err.Description, vbCritical, "提示："
End Sub
Function In6160(ByVal Port As Integer) As String ''从6160卡读取数据，其中port取值为0-3
On Local Error Resume Next
Dim a As Integer, s0 As String, s1 As String, s2 As String, s3 As String, s4 As String
Dim b As Integer

h:
    a = vbInp(Cardbase + Port + 4)
    b = (a And 240) / 16
    
    If b = 1 Then '首位
        a = (a And 15)
        s0 = (a Mod 10) '(a \ 10) * 8 +
    Else
        DoEvents
        GoTo h:
    End If

i:
    a = vbInp(Cardbase + Port + 4)
    b = (a And 240) / 16
    
    If b = 2 Then '2位
        a = (a And 15)
        s1 = (a Mod 10) '(a \ 10) * 8 +
    Else
        DoEvents
        GoTo i:
    End If

j:
    a = vbInp(Cardbase + Port + 4)
    b = (a And 240) / 16
    
    If b = 4 Then '3位
        a = (a And 15)
        s2 = (a Mod 10) '(a \ 10) * 8 +
    Else
        DoEvents
        GoTo j:
    End If

K:
    a = vbInp(Cardbase + Port + 4)
    b = (a And 240) / 16
    
    If b = 8 Then '4位
        a = (a And 15)
        s3 = (a Mod 10) '(a \ 10) * 8 +
    Else
        DoEvents
        GoTo K:
    End If
L:
    a = vbInp(Cardbase + Port + 4)
    b = (a And 240) / 16

    If b = 0 Then '4位
        a = (a And 15)
        s4 = (a Mod 10) '(a \ 10) * 8 +
    Else
        DoEvents
        GoTo L:
    End If



In6160 = s3 & s2 & s1 & s0 & s4


End Function

Function Max(a As Integer, b As Integer) As Integer ''返回ab中的最大值
    Max = a
    If b > a Then Max = b
End Function

Function Valid(Num As Double, K As Integer) As String ''有效数字转换成字符输出
Dim d As Double, a As Double, b As Integer, c As Double, e As Double, s As String
If Num = 0 Then
    Valid = 0
    Exit Function
End If

If Num = 1 Then
    Valid = "1.00"
    Exit Function
End If

d = Abs(Num)
a = Log(d) / Log(10)
b = Int(a)
c = Abs(b - a)
e = 10 ^ c
s = CStr(e) & "0000000000"
s = Mid(s, 1, K + 1)
If Num < 0 Then s = "-" & s
Valid = s & "E" & b
End Function


Sub Out6080(Port As Integer, a As Double, Optional Tmp As Boolean)
On Error GoTo h
Dim i As Integer

vbOut CardbaseA, Int(a * 51)
vbOut CardbaseA + 1, Port
vbOut CardbaseA + 2, 0
'If Port > 3 Or Tmp = True Then Exit Sub
'    If A = 0 Then Frmkxd.sss(Port).Visible = True
'   If A = 3 Then Frmkxd.sss(Port).Visible = False
Exit Sub

h:
    MsgBox "出错：" & Err.Description, vbCritical, "提示"
End Sub

Sub delay(delSecond As Integer)
Dim PauseTime, Start

    PauseTime = delSecond * 2 ' 设置暂停时间。
    'If delSecond = 8 Then PauseTime = 30
    Start = Timer   ' 设置开始暂停的时刻。
    Do While Timer < Start + PauseTime
        DoEvents    ' 将控制让给其他程序。
    Loop
End Sub

Function CalcBin(a() As Integer) As Integer '
'本函数将8位二进制串转为10进制数，注意顺序
    CalcBin = a(7) * 128 + a(6) * 64 + a(5) * 32 + a(4) * 16 _
           + a(3) * 8 + a(2) * 4 + a(1) * 2 + a(0)
End Function

Function GetT(Port As Integer) As Double  '获取温度
On Error Resume Next
Dim buf(0 To 7) As Byte
Dim tmplen As Integer
Dim NewBuf(0 To 9) As Byte

    buf(0) = 128 + Port
    buf(1) = 128 + Port
    buf(2) = 82
    buf(3) = 0
    buf(4) = 0
    buf(5) = 0
    buf(6) = 82 + Port
    buf(7) = 0
    '================================================================
    tmplen = sio_write(Port, buf(0), 8)
    
    If tmplen < 0 Then
        MsgBox "Fail write" 'fail
        T1 = 0
        Exit Function
    End If
    DoEvents
    tmplen = sio_read(Port, NewBuf(0), 10)
    If tmplen < 0 Then
        MsgBox "Fail write"
    Else
       GetT = (NewBuf(1) * 256 + NewBuf(0)) / 10
    End If
End Function

Function Set_hy(ByVal R As Integer)  '调节围压泵转速
    Dim OutF As Long, Lb As Integer, Hb As Integer
    OutF = R * 4.37  ''按1000hz对应223转，即每转需要4.4843hz
    ''======================
    DoEvents
    vbOut CardbaseB + 7, &H82
    DoEvents
    vbOut CardbaseB + 6, &HD
    DoEvents: DoEvents: DoEvents: DoEvents: DoEvents ''先停止
    If R = 0 Then Exit Function
    
    OutF = 2000000 / OutF
    Hb = OutF \ 256
    Lb = OutF Mod 256
    
    vbOut CardbaseB + 3, &H36 '00110110
    DoEvents
    vbOut CardbaseB + 0, Lb    '低位
    vbOut CardbaseB + 0, Hb    '高位以1000HZ启动
    DoEvents
    vbOut CardbaseB + 6, &HFF


End Function