module1.bas

通过VB, GPIB协议控制测试仪器, 实现测试自动化, 这个行业的人才有些缺乏, 本人愿意分享

Attribute VB_Name = "Module1"
Option Explicit
Public Const ENTER_KEY_IN = 13
Public Const IMEI_STR_LENGTH = 15

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


'Declare Sub Sleep Lib "kernel32" (ByVal dwMiniSeconds As Long)
'Declare Function GetTickCount Lib "kernel32" () As Long

' Return the char position
' Return 0 if none is found
Public Function FindChar(ByVal sChar As String, ByVal sline As String, Optional ByVal iOccurrence As Integer = 1) As Integer
Dim i As Integer, iCount As Integer, iPos As Integer

    For i = 1 To Len(sline)
        If Mid(sline, i, 1) = sChar Then iCount = iCount + 1
        If iCount >= iOccurrence Then
            iPos = i
            Exit For
        End If
    Next
    
    FindChar = iPos
End Function
' start find from the end of line
' Return the char position
' Return 0 if none is found
Public Function FindCharR(ByVal sChar As String, ByVal sline As String) As Integer
Dim i As Integer, iCount As Integer, iPos As Integer

    iPos = 0
    For i = Len(sline) To 1 Step -1
        If Mid(sline, i, 1) = sChar Then
            iPos = i
        Exit For
        End If
    Next
    
    FindCharR = iPos
End Function
Public Function AmendResult(ByVal sline As String) As String
Dim tmpStr As String
Dim i As Integer
    tmpStr = ""
    For i = 1 To Len(sline)
        If IsNumeric(Mid(sline, i, 1)) = True Then
            tmpStr = Mid(sline, i, Len(sline) - i)
            Exit For
        End If
    Next
    If tmpStr <> "" Then
        sline = tmpStr
        
        For i = Len(sline) To 1 Step -1
            If IsNumeric(Mid(sline, i, 1)) = True Then
                tmpStr = Left(sline, i)
                Exit For
            End If
        Next
    End If
    
    
    AmendResult = tmpStr
End Function



Public Function FindItemInCollection(ByVal cCollection As Collection, ByVal sItem As String, ByVal itemIndex As Integer) As Integer
Dim i As Integer, iPos As Integer
    iPos = 0
    For i = itemIndex + 1 To cCollection.count
        If cCollection.Item(i) = sItem Then
            iPos = i
        End If
    Next
    
    FindItemInCollection = iPos
End Function



Public Function CheckIfRedunant(ByVal cCollection As Collection) As Collection
Dim i As Integer
Dim ctempRedunant As New Collection

    For i = 1 To cCollection.count - 1
        If FindItemInCollection(cCollection, cCollection.Item(i), i) <> 0 Then
            ctempRedunant.Add cCollection.Item(i)
        End If
    Next
            
    Set CheckIfRedunant = ctempRedunant
    
End Function

Public Function ClearCollection(ByVal cCollection As Collection)
    Dim i As Integer
    If cCollection.count <> 0 Then
        For i = cCollection.count To 1 Step -1
            cCollection.Remove (i)
        Next
    End If
End Function

Public Function CheckLinesInFile(ByVal sfileName As String) As Integer
Dim sline As String
Dim iFH As Integer
Dim iLine As Integer

On Error GoTo Err

iLine = 0
iFH = FreeFile
Open sfileName For Input As iFH
Do While Not EOF(iFH)
    Input #iFH, sline
    iLine = iLine + 1
Loop
Close #iFH

CheckLinesInFile = iLine

Err:
    'MsgBox "File doesn't exist..."
End Function

Public Sub CreateFolder(ByVal sPathName As String)
On Error GoTo Err
    MkDir sPathName
Err:
End Sub


Public Function FormatTimer(ByVal lseconds As Long) As String
Dim iMin As Integer
Dim iSec As Integer

iMin = lseconds \ 60
iSec = CInt(lseconds Mod 60)

If iSec > 9 Then
    FormatTimer = Str(iMin) & ":" & Str(iSec)
Else
    FormatTimer = Str(iMin) & ":0" & Str(iSec)
End If

End Function

'time delay sub program, unit is minisecond
Public Sub TimeDelay(ByVal DT As Long)
Dim TT As Long


TT = GetTickCount

Do
    DoEvents
Loop Until GetTickCount - TT >= DT

End Sub

Public Function Maximum(ByVal tempArray As Variant) As Single
'Dim tempArray As Variant
Dim i As Integer
Dim tempSingle As Single

'tempArray = Array(ArrayString)

tempSingle = tempArray(0)
For i = 1 To UBound(tempArray) - 1
    If tempSingle < tempArray(i) Then
        tempSingle = tempArray(i)
    End If
Next

Maximum = tempSingle

End Function

Public Function Minimum(ByVal tempArray As Variant) As Single
'Dim tempArray As Variant
Dim i As Integer
Dim tempSingle As Single

'tempArray = Array(ArrayString)

tempSingle = tempArray(0)
For i = 1 To UBound(tempArray) - 1
    If tempSingle > tempArray(i) Then
        tempSingle = tempArray(i)
    End If
Next

Minimum = tempSingle

End Function

Public Function Medium(ByVal tempArray As Variant) As Single
Dim min_to_max As Variant
Dim i As Integer
Dim tempSingle As Single


min_to_max = ReArrange(tempArray)

Medium = min_to_max(Int(UBound(tempArray) / 2))

End Function

Public Function ReArrange(ByVal tempArray As Variant) As Variant
'Dim tempArray As Variant
Dim i, j As Integer
Dim tempSingle As Single
Dim MinToMax() As Single
Dim tempString As String
Dim bLoopStart As Boolean
Dim ilastLocation As Integer
Dim iLocation As Integer

'tempArray = Array(ArrayString)

ReDim MinToMax(UBound(tempArray))

tempSingle = tempArray(0)
For i = 1 To UBound(tempArray) - 1
    If tempSingle > tempArray(i) Then
        tempSingle = tempArray(i)
        iLocation = i
    End If
Next

ilastLocation = iLocation
MinToMax(0) = tempSingle

bLoopStart = True

For i = 1 To UBound(tempArray) - 1
    For j = 0 To UBound(tempArray) - 1
        If tempArray(j) > MinToMax(i - 1) Then
            If bLoopStart = True Then
                MinToMax(i) = tempArray(j)
                iLocation = j
                bLoopStart = False
            ElseIf tempArray(j) < MinToMax(i) Then
                MinToMax(i) = tempArray(j)
                iLocation = j
            End If
        ElseIf tempArray(j) = MinToMax(i - 1) And j > ilastLocation Then
                MinToMax(i) = tempArray(j)
                iLocation = j
                Exit For
        End If

    Next
    bLoopStart = True
    ilastLocation = iLocation
Next

ReArrange = MinToMax


End Function

Public Function ArrayToString(ByVal tempArray As Variant, ByVal keyChar As String) As String
Dim i As Integer
Dim tempString As String

tempString = ""
For i = 0 To UBound(tempArray) - 1
    tempString = tempString & tempArray(i) & keyChar    '","
Next

ArrayToString = Left(tempString, Len(tempString) - 1)


End Function

Public Function StringToArray(ByVal tempString As String, ByVal keyChar As String) As Variant
Dim tempArray(100) As Single
Dim i As Integer
Dim tempSingle As Single
Dim sLeft As String
Dim sRight As String
Dim sRemain As String
Dim lastArray() As Single

i = 0
sRemain = tempString
Do
    If InStr(sRemain, keyChar) > 0 Then
        sLeft = Left(sRemain, InStr(sRemain, keyChar) - 1)
        tempArray(i) = CSng(sLeft)
        sRight = Mid(sRemain, InStr(sRemain, keyChar) + 1)
        sRemain = sRight
    Else
        tempArray(i) = CSng(sRemain)
        Exit Do
    End If
    i = i + 1
Loop

ReDim lastArray(i + 1)
For i = 0 To UBound(lastArray)
lastArray(i) = tempArray(i)
Next

StringToArray = lastArray

End Function

Public Function StringReplace(ByVal StringLine As String, ByVal OriginalKey As String, ByVal TargetChar As String) As String
Dim i As Integer
Dim tempString As String
Dim tempChar As String

tempString = ""
For i = 1 To Len(StringLine)
    tempChar = Mid(StringLine, i, 1)
    If tempChar = OriginalKey Then
        tempString = tempString & TargetChar
    Else
        tempString = tempString & tempChar
    End If
Next

StringReplace = tempString

End Function

Public Function KeepValueDigit(ByVal sNumber As String, ByVal iValueDigit As Integer) As String
Dim sLeft, sRight As String
    
    If InStr(sNumber, ".") > 0 Then
        sLeft = Left(sNumber, InStr(sNumber, ".") - 1)
        sRight = Mid(sNumber, InStr(sNumber, "."), iValueDigit + 1)
    Else
        sLeft = sNumber
        sRight = "." & String(iValueDigit, "0")
    End If
    
    KeepValueDigit = sLeft & sRight
    
End Function