basfun.bas

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

Attribute VB_Name = "basfun"


'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'---------------------从硬件获得数据------------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function Getvol(ByVal Port As Integer) As Double
Dim L(1 To 100) As Integer, h(1 To 100) As Integer, i&, t As Double
Dim yl(1 To 100) As Long

                For i = 1 To 100
                    vbOut Cardbase, Port
h:
                    L(i) = vbInp(Cardbase + 5)
                    DoEvents
                    If (L(i) And &H80) <> &H80 Then GoTo h
                    L(i) = vbInp(Cardbase + 1)
                    h(i) = vbInp(Cardbase + 2)
                    h(i) = h(i) And 15
                    yl(i) = L(i) + h(i) * 256
                Next i
                    Getvol = Bsortp(yl)
                    If Getvol < 0 Then Getvol = 0

End Function
Function Bsortp(v As Variant) As Double
Dim i, j As Integer, K As Double
For i = 1 To 100
    For j = 1 To 99
        If v(j) > v(j + 1) Then
        K = v(j + 1)
        v(j + 1) = v(j)
        v(j) = K
        End If
    Next j
Next i
Bsortp = (v(20) + v(30) + v(40) + v(50) + v(60)) / 5
Bsortp = (Bsortp - 2047) * 10 / 4096 '- 0.03
'If bsortp < 0.1 Then bsortp = (v(50) - 2047) * 10 / 4096 + 0.03
End Function







'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'-------------------打印单行表格单元------------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Sub drawbox(x As Integer, Y As Integer, w As Integer, txt As Variant, Optional h As Integer, Optional flg As Integer)
'||x,y记录当前位置,w记录单元格宽度,txt记录单元格内容,h记录单元格高度,flag 标记是否居中
Dim prtth As Integer, prttw As Integer
On Local Error Resume Next
    prtth = Printer.TextHeight("d")
    prttw = Printer.TextWidth("d")
    
    If IsMissing(h) Then h = 350
    Printer.Line (x, Y)-(x + w, Y + h), , B
    Printer.CurrentX = x + 50
    
    If flg = 1 Then Printer.CurrentX = x + (w - Len(txt) * prttw) / 2
    Printer.CurrentY = Y + (h - prtth) / 2
    Printer.Print txt
    
End Sub
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'--------------------打印双行表格单元-----------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Sub drawbox2(x As Integer, Y As Integer, w As Integer, txt1 As Variant, txt2 As Variant, Optional h As Integer)
'||x,y记录当前位置,w记录单元格宽度,txt记录单元格内容,h记录单元格高度
Dim prtth As Integer, prttw1 As Integer, prttw2 As Integer, a As String
On Error Resume Next
    prtth = Printer.TextHeight("d")
    a = Mid(CStr(txt1), 1, 1)
    
    prttw1 = Printer.TextWidth("d")
    prttw2 = Printer.TextWidth("等")
    If Asc(a) >= 10 And Asc(a) <= 127 Then prttw2 = prttw1
    If IsMissing(h) Then h = 700
    Printer.Line (x, Y)-(x + w, Y + h), , B
    setp x + (w - Len(txt1) * prttw2) / 2, Y + (h / 2 - prtth) / 2
    Printer.Print txt1
    setp x + (w - Len(txt2) * prttw1) / 2, Y + h / 2 + (h / 2 - prtth) / 2
    Printer.Print txt2
    
End Sub

'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'-----------------设置上下标打印----------------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Sub Updown(txt1 As String, txt2 As String, x As Integer, Y As Integer, Optional flg As Boolean)
On Local Error Resume Next
oldsize = obj.FontSize
setp x, Y
Printer.Print txt1;
Printer.CurrentY = Printer.CurrentY - 30
If flg = True Then Printer.CurrentY = Printer.CurrentY + 60
Printer.FontSize = oldsize / 1.2
Printer.Print txt2;
Printer.FontSize = oldsize
End Sub
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'---------------设置当前打印位置----------------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Sub setp(x As Integer, Y As Integer)
Printer.CurrentX = x
Printer.CurrentY = Y
End Sub
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'------------------------打印图片---------------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Public Sub prt(pic As PictureBox, Optional flg As Integer)
On Error GoTo h:
'flg=0 页面双向居中打印
'flg=1 页面横轴居中打印
'flg=2 页面随机打印
    Dim x1 As Integer, y1 As Integer
    
    Select Case flg
        Case 0
            x1 = (Printer.Width - pic.Width) / 2
            y1 = (Printer.Height - pic.Height) / 2
        Case 1
            x1 = (Printer.Width - pic.Width) / 2
            y1 = Printer.CurrentY
        Case 2
            x1 = Printer.CurrentX
            y1 = Printer.CurrentY
    End Select
    
    Printer.PaintPicture pic.Image, x1, y1, pic.Width, pic.Height
    Printer.CurrentY = Printer.CurrentY + pic.Height
    Exit Sub
h:
    MsgBox "打印出错！", vbOKOnly + vbCritical, "意外出错"
    End Sub

'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'------------------------计算数值差距-----------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function getspan(num1 As Variant, num2 As Variant) As Double
If num1 <> 0 Then
getspan = Abs(CDbl(num2) - CDbl(num1)) / CDbl(num1)
Else
getspan = 1
End If
End Function
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'--------------------------小数保留-------------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function getdigit(ddd As Double, i As Integer)
Dim Tmp As Double
Tmp = CLng(ddd * 10 ^ i) / (10 ^ i)
getdigit = Tmp
End Function

'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'--------------------------得到临界值-----------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function getlj(ByVal a As Variant, ByVal j As Integer, ByVal maxv As Double, ByRef yd As Double) As Double
'a记录数据，j为记录数，maxv为最大渗透率，yd返回最大自变量值，getlj返回临界渗透率
Dim i As Integer, TmpStl As Double
getlj = 0
TmpStl = 0
    For i = 1 To j
        If getspan(maxv, a(2, i)) >= 0.1 Then
            yd = a(1, i)
            getlj = a(2, i)
            Exit Function
        End If
        If i = j Then Exit Function
        If (a(2, i) - a(2, i + 1)) / (a(1, i) - a(1, i + 1)) > TmpStl Then
            TmpStl = (a(2, i) - a(2, i + 1)) / (a(1, i) - a(1, i + 1))
            yd = a(1, i + 1)
            getlj = a(2, i + 1)
        End If
    Next i
End Function

Function getljvel(ByVal a As Variant, ByVal j As Integer, ByVal maxv As Double, ByRef yd As Double) As Double
'j为记录数，maxv为最大渗透率，yd返回临界渗透率对应流速，getljvel返回临界渗透率
Dim i As Integer, K As Integer, TmpStl As Double
TmpStl = 0
getljvel = a(2, 1)
yd = a(1, 1)
For i = 1 To j
If Abs(a(2, i) - maxv) < 0.000001 Then Exit For
Next i
If i = j + 1 Then i = j
'以上返回最大渗透率对应的流速所在点

For K = i To j
        If getspan(maxv, a(2, K)) >= 0.1 Then
            yd = a(1, K)
            getljvel = a(2, K)
            Exit Function
        End If
        If K = j Then Exit Function
        If (a(2, K) - a(2, K + 1)) / (a(1, K) - a(1, K + 1)) > TmpStl Then
            TmpStl = (a(2, K) - a(2, K + 1)) / (a(1, K) - a(1, K + 1))
            yd = a(1, K + 1)
            getljvel = a(2, K + 1)
        End If
Next K

End Function



'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'--------------------------改变字符串-----------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function replace(ByVal a As String, ByVal pri As String, ByVal Last As String) As String
'该函数将字符串中指定的字符pri转换成last并返回
Dim i As Integer, lenth As Integer
lenth = Len(a)
If lenth < 1 Then
    replace = ""
    Exit Function
Else
    For i = 1 To lenth
    Tmp = Mid(a, i, 1)
    If Tmp = pri Then Tmp = Last
    replace = replace & Tmp
    Next i
End If
End Function
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'------------------------取得路径---------------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function getpath(path As String) As String
Dim i As Integer                                '||即从完整路径中去掉具体文件名
    For i = Len(path) To 1 Step -1
        If Mid(path, i, 1) = "\" Then Exit For
    Next i
    getpath = Mid(path, 1, i - 1)
End Function

Function getfullpath(filename As String) As String
Dim i As Integer
Dim a As String
a = getpath(filename)
i = Len(a)
getfullpath = a
If Mid(a, i, 1) <> "\" Then getfullpath = getfullpath & "\"
End Function
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'------------------------取得具体文件名---------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function getfile(path As String) As String
Dim i&
For i = Len(path) To 1 Step -1
If Mid(path, i, 1) = "\" Then Exit For
Next i
getfile = Mid(path, i + 1)
End Function

'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'------------------------取得数值串---------------------
'|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Function getno(a As String) As Double
On Error Resume Next
Dim i As Integer, j As Integer
Static Tmp As Double
i = InStr(1, a, "s", vbTextCompare)
j = InStr(i + 1, a, "g", vbTextCompare)
If i = 0 Or j = 0 Then
getno = 0
Exit Function
End If
getno = CDbl(Mid(a, i + 2, j - i - 2))
'If Tmp > 0 And getspan(Tmp, getno) > 1 Then getno = Tmp
Tmp = getno
End Function


'冒泡排序
Sub BSort(ByRef List() As Double, flg As Integer)