sicl4.bas

通过GPIB接口读取频谱仪的测试曲线

Declare Function vb_ipeekx16 Lib "vbsicl32.dll" (ByVal id As Integer, ByVal handle As Long, ByVal offset As Long, value As Integer) As Integer
Declare Function vb_ipeekx32 Lib "vbsicl32.dll" (ByVal id As Integer, ByVal handle As Long, ByVal offset As Long, value As Long) As Integer
Declare Function vb_iblockmovex Lib "vbsicl32.dll" (ByVal id As Integer, ByVal srcHandle As Long, ByRef srcOffset As Variant, ByVal srcWidth As Integer, ByVal srcIncrement As Integer, ByVal destHandle As Long, ByRef destOffset As Variant, ByVal destWidth As Integer, ByVal destIncrement As Integer, ByVal count As Long, ByVal swap As Integer) As Integer

' Block copy and fifo routines
Declare Function vb_ibblockcopy Lib "vbsicl32.dll" (ByVal id As Integer, ByVal src As Long, ByVal dest As Long, ByVal cnt As Long) As Integer
Declare Function vb_iwblockcopy Lib "vbsicl32.dll" (ByVal id As Integer, ByVal src As Long, ByVal dest As Long, ByVal cnt As Long, ByVal swap As Integer) As Integer
Declare Function vb_ilblockcopy Lib "vbsicl32.dll" (ByVal id As Integer, ByVal src As Long, ByVal dest As Long, ByVal cnt As Long, ByVal swap As Integer) As Integer
Declare Function vb_ibpushfifo Lib "vbsicl32.dll" (ByVal id As Integer, ByVal src As Long, ByVal fifo As Long, ByVal cnt As Long) As Integer
Declare Function vb_iwpushfifo Lib "vbsicl32.dll" (ByVal id As Integer, ByVal src As Long, ByVal fifo As Long, ByVal cnt As Long, ByVal swap As Integer) As Integer
Declare Function vb_ilpushfifo Lib "vbsicl32.dll" (ByVal id As Integer, ByVal src As Long, ByVal fifo As Long, ByVal cnt As Long, ByVal swap As Integer) As Integer
Declare Function vb_ibpopfifo Lib "vbsicl32.dll" (ByVal id As Integer, ByVal fifo As Long, ByVal dest As Long, ByVal cnt As Long) As Integer
Declare Function vb_iwpopfifo Lib "vbsicl32.dll" (ByVal id As Integer, ByVal fifo As Long, ByVal dest As Long, ByVal cnt As Long, ByVal swap As Integer) As Integer
Declare Function vb_ilpopfifo Lib "vbsicl32.dll" (ByVal id As Integer, ByVal fifo As Long, ByVal dest As Long, ByVal cnt As Long, ByVal swap As Integer) As Integer
Declare Function vb_icmd Lib "vbsicl32.dll" (ByVal id As Integer, ByVal cmd As Long, ByVal datalen As Integer, ByVal datawidth As Integer, ByRef pdata As Long) As Integer

' Windows 3.1 Cleanup routines
Declare Function vb__siclcleanup Lib "vbsicl32.dll" () As Integer

' Windows 3.1 yield control routine
Declare Function vb__setsiclyield Lib "vbsicl32.dll" (ByVal yield_option As Integer) As Integer

' Peek/Poke routines
Declare Sub vb_ibpoke Lib "vbsicl32.dll" (ByVal addr As Long, ByVal value As Byte)
Declare Sub vb_iwpoke Lib "vbsicl32.dll" (ByVal addr As Long, ByVal value As Integer)
Declare Sub vb_ilpoke Lib "vbsicl32.dll" (ByVal addr As Long, ByVal value As Long)
Declare Function vb_ibpeek Lib "vbsicl32.dll" (ByVal addr As Long) As Byte
Declare Function vb_iwpeek Lib "vbsicl32.dll" (ByVal addr As Long) As Integer
Declare Function vb_ilpeek Lib "vbsicl32.dll" (ByVal addr As Long) As Long
#End If

Function iversion(specversion As Integer, implversion As Integer) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    ' Call the function in the SICL DLL and check for errors
    id = vb_iversion(specversion, implversion)
    iversion = id
    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function

Function idrvrversion(id1 As Integer, specversion As Integer, implversion As Integer) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    ' Call the function in the SICL DLL and check for errors
    id = vb_idrvrversion(id1, specversion, implversion)
    idrvrversion = id
    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function

Function iopen(siclAddr As String) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    ' Call the function in the SICL DLL and check for errors
    id = vb_iopen(siclAddr)
    iopen = id

    ' If we get 0 back, there was an error, try to report it
    If id = 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function



Function iclose(ByVal id1 As Integer) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    ' Call the function in the SICL DLL and check for errors
    id = vb_iclose(id1)
    iclose = id
    
    ' If return value was not 0, we had an error
    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function


Function igetintfsess(ByVal id1 As Integer) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    ' Call the function in the SICL DLL and check for errors
    id = vb_igetintfsess(id1)
    igetintfsess = id

    ' If we get 0 back, there was an error, try to report it
    If id = 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function

Function iwrite(ByVal id1 As Integer, ByVal BUF As Variant, ByVal datalen As Long, ByVal endi As Integer, actual As Long) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    tmp = VarType(BUF)

    'If the buf is a string, then Win16 requires it to be < 32768 bytes
    If tmp = 8 Then
#If Win16 Then
       If datalen > 32767 Then
          Err.Clear
          myerrstr = "Second param string length must be <= 32767"
          Err.Description = myerrstr
          MsgBox myerrstr
          Err.Raise (I_ERR_PARAM) 'Raise the error
       End If
#End If
    End If

    ' Call the function in the SICL DLL and check for errors
    id = vb_iwrite(1, id1, BUF, datalen, endi, actual)
    
    iwrite = id
    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function

Function ifwrite(ByVal id1 As Integer, ByVal BUF As Variant, ByVal datalen As Long, ByVal endi As Integer, actual As Long) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    tmp = VarType(BUF)

    'If the buf is a string, then Win16 requires it to be < 32768 bytes
    If tmp = 8 Then
#If Win16 Then
       If datalen > 32767 Then
          Err.Clear
          myerrstr = "Second param string length must be <= 32767"
          Err.Description = myerrstr
          MsgBox myerrstr
          Err.Raise (I_ERR_PARAM) 'Raise the error
       End If
#End If
    End If

    ' Call the function in the SICL DLL and check for errors
    id = vb_iwrite(2, id1, BUF, datalen, endi, actual)
    
    ifwrite = id
    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function


Function iread(ByVal id1 As Integer, ByRef BUF As Variant, ByVal bufsize As Long, reason As Integer, actual As Long) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer
        
    tmp = VarType(BUF)

    'If the buf parameter string, Win16 needs it to be < 32768 bytes
    If tmp = 8 Then
#If Win16 Then
       If bufsize > 32767 Then
          Err.Clear
          myerrstr = "Second param string length must be <= 32767"
          Err.Description = myerrstr
          MsgBox myerrstr
          Err.Raise (I_ERR_PARAM) 'Raise the error
       End If
#End If
    End If

    ' Call the function in the SICL DLL and check for errors
    id = vb_iread(1, id1, BUF, bufsize, reason, actual)
    
    iread = id

    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function

Function ifread(ByVal id1 As Integer, ByRef BUF As Variant, ByVal bufsize As Long, reason As Integer, actual As Long) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer
        
    tmp = VarType(BUF)

    'If the buf parameter string, Win16 needs it to be < 32768 bytes
    If tmp = 8 Then
#If Win16 Then
       If bufsize > 32767 Then
          Err.Clear
          myerrstr = "Second param string length must be <= 32767"
          Err.Description = myerrstr
          MsgBox myerrstr
          Err.Raise (I_ERR_PARAM) 'Raise the error
       End If
#End If
    End If

    ' Call the function in the SICL DLL and check for errors
    id = vb_iread(2, id1, BUF, bufsize, reason, actual)
    
    ifread = id

    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If

End Function



Function itermchr(ByVal id1 As Integer, ByVal tchr As Integer) As Integer
    Dim id As Integer
    Dim thisErrno As Integer
    Dim myerrstr As String * 60
    Dim tmp As Integer

    ' Call the function in the SICL DLL and check for errors
    id = vb_itermchr(id1, tchr)
    itermchr = id
    If id <> 0 Then
        thisErrno = vb_igeterrno()
        If thisErrno <> 0 Then
            Err.Clear    ' set default values in the error object
            ' set the error string and raise the error
            tmp = vb_igeterrstr(thisErrno, myerrstr)
            Err.Description = myerrstr
            Err.Raise (thisErrno) 'Raise the error
        End If
    End If