Option Strict Off
Option Explicit On
Imports System.Text

Module SubRutine




    '///// The global variable used by ¢SubFunc.vb£ //////////////////////////////////////////
    Public CmdNum As Integer            'Number of command
    Public Mode As Integer              'Master(=0) or Slave(=1)
    Public MyAddr As Integer            'MyAddress
    Public YrAddr As Integer            'Partner Address
    Public Cmd(50) As Integer           'Number of message
    Public Cnt As Integer               'Count
    Public Delim As Integer             'Delimiter
    Public Eoi As Integer               'EOI
    Public Timeout As Integer           'Timeout
    Public Dmamode As Integer           'DMA mode
    Public DmaPos As Integer            'DMA channel
    Public Ret As Integer               'Return code
    Public Srbuf As New String("", 10000)
    Public Srlen As Integer
    Public ErrText As String
    Public RetTmp As Integer
    Public pCmd As IntPtr               'IntPtr for cmd array

    '///// [ CheckRet ] Function /////////////////////////////////////////////////////////////////////////////////////////
    Public Function CheckRet(ByRef Buf As String, ByRef RetCode As Integer, ByRef Text As String) As Integer
        Dim RetSts As Integer
        Text = Buf & " : It was terminated normally."
        CheckRet = RetCode And &HFFS
        RetSts = 0
        If (CheckRet >= 3) Then
            RetSts = 1
            If (CheckRet = 80) Then Text = Buf & " : It is I/O address error." : GoTo CheckStatus
            If (CheckRet = 82) Then Text = Buf & " : Resistry setup is wrong. Review resistry setup." : GoTo CheckStatus
            If (CheckRet = 128) Then Text = Buf & " : Data receiving was exceeded.and polling is not." : GoTo CheckStatus
            If (CheckRet = 140) Then Text = Buf & " : Asynchronous function is executing now." : GoTo CheckStatus
            If (CheckRet = 141) Then Text = Buf & " : Asynchronous function is Stopped by GpStopAsync()." : GoTo CheckStatus
            If (CheckRet = 190) Then Text = Buf & " : Cannot create new event object." : GoTo CheckStatus
            If (CheckRet = 200) Then Text = Buf & " : Thread can not be made." : GoTo CheckStatus
            If (CheckRet = 201) Then Text = Buf & " : Other event is in practice." : GoTo CheckStatus
            If (CheckRet = 210) Then Text = Buf & " : DMA could not be established." : GoTo CheckStatus
            If (CheckRet = 240) Then Text = Buf & " : [Esc] key was pushed." : GoTo CheckStatus
            If (CheckRet = 241) Then Text = Buf & " : It is an I/O error of file." : GoTo CheckStatus
            If (CheckRet = 242) Then Text = Buf & " : Address appoint is wrong." : GoTo CheckStatus
            If (CheckRet = 243) Then Text = Buf & " : Buffer Error." : GoTo CheckStatus
            If (CheckRet = 244) Then Text = Buf & " : Error of array size." : GoTo CheckStatus
            If (CheckRet = 245) Then Text = Buf & " : A buffer is too small." : GoTo CheckStatus
            If (CheckRet = 246) Then Text = Buf & " : It is an unjust object name." : GoTo CheckStatus
            If (CheckRet = 247) Then Text = Buf & " : A side check of a device name is invalid." : GoTo CheckStatus
            If (CheckRet = 248) Then Text = Buf & " : It is an unjust data model." : GoTo CheckStatus
            If (CheckRet = 249) Then Text = Buf & " : Device can not be added further." : GoTo CheckStatus
            If (CheckRet = 250) Then Text = Buf & " : A device name is not found out." : GoTo CheckStatus
            If (CheckRet = 251) Then Text = Buf & " : A delimiter is wrong between device." : GoTo CheckStatus
            If (CheckRet = 252) Then Text = Buf & " : It is an error of GP-IB." : GoTo CheckStatus
            If (CheckRet = 253) Then Text = Buf & " : Only a delimiter was receiving." : GoTo CheckStatus
            If (CheckRet = 254) Then Text = Buf & " : It was done a time out." : GoTo CheckStatus
            If (CheckRet = 255) Then Text = Buf & " : It is a parameter error." : GoTo CheckStatus
        End If
CheckStatus:
        '----- IFC & SRQ message  ------
        CheckRet = RetCode And &HFF00S
        If (CheckRet = &H100S) Then Text = Text & " [SRQ] was receiving.<STATUS>" : GoTo CheckEnd '[256]decimal
        If (CheckRet = &H200S) Then Text = Text & " [IFC] was receiving.<STATUS>" : GoTo CheckEnd '[512]decimal
        If (CheckRet = &H300S) Then Text = Text & " [SRQ] and [IFC] was receiving.<STATUS>" '[768]decimal
CheckEnd:
        CheckRet = RetSts

    End Function

    '///// [ AddCommand ] Function ////////////////////////////////////////////////////////////////////
    Public Function AddCommand(ByRef CommandType As Integer, ByRef CommandNum As Short) As Boolean
        Dim ErrMsg As String                'For error message

        If (CmdNum > 30) Then               'In terms of message at the time of more than 30.
            ErrMsg = "It can not be added further."
            MsgBox(ErrMsg)
            AddCommand = False
            Exit Function
        End If
        If (CommandNum = 2) Then            'Remote machine vessel address is added.
            Cmd(CmdNum) = (YrAddr Or &H20S)
            CmdNum = CmdNum + 1
        End If
        Cmd(CmdNum) = CommandType           'Message is found by a value.
        CmdNum = CmdNum + 1
        AddCommand = True

    End Function

    '///// [ DispCommandList ] Function ///////////////////////////////////////////////////////////////
    Public Function DispCommandList() As String
        Dim TxtRet As Integer               'For message of hexadecimal.
        Dim Txt As String
        Dim TmpString As String             'TmpString = Making MSG¤Text = All MSG

        Txt = ""
        For Cnt = 1 To CmdNum - 1           'The message which was made at the end of all message is added.
            TxtRet = Cmd(Cnt)               'Some turn of an array is shown.
            TmpString = "[" & Hex(TxtRet) & "h] "
            Txt = Txt & TmpString           'New MSG is added.
        Next

        DispCommandList = Txt

    End Function

    '///// [ GpinInit ] Function //////////////////////////////////////////////////////////////////////
    Public Function GpibInit(ByRef TextInit As String) As Integer

        'Delim = 1: Eoi = 1                                 'Delim = 0:None/1:CR+LF/2:CR/3:LF Eoi = 0:Without EOI/1:With EOI
        Timeout = 10000                             'Initial setting
        GpibInit = 0                                'Initial setting

        Ret = GpExit()                              'An error by reinitialization is prevented.
        Ret = GpIni()                               'Initialization of GP-IB board.,It is started use of function.
        If CheckRet("GpIni", Ret, TextInit) = 1 Then GoTo Err_Renamed
        'In following GpBoardsts(), information is acquirable from a registry.
        'The 1st argument has a contrast table in a help. The 2nd is the variable name to substitute.
        Ret = GpBoardsts(&HAS, Mode)                'Master(=0) or Slave(=1) It is acquired.
        Ret = GpBoardsts(&H8S, MyAddr)              'MyAddr(MyAddress) is acquired.
        Ret = GpBoardsts(&HCS, Dmamode)             'DMA mode
        Ret = GpBoardsts(&HDS, DmaPos)              'DMA channel

        If (Mode) = 0 Then                          'Processing is different in a master or a slave.
            Ret = GpIfc(1)                          'Interface clear.(1 = 100us)
            If CheckRet("GpIfc", Ret, TextInit) = 1 Then GoTo Err_Renamed

            Ret = GpRen()                           'A remote machine vessel is turned into a remote state.
            If CheckRet("GpRen", Ret, TextInit) = 1 Then GoTo Err_Renamed
        End If
        'The initial value when not performing is CR+LF+EOI.
        'Ret = GpDelim(Delim, Eoi)
        'If CheckRet("GpDelim", Ret, TextInit) = 1 Then GoTo Err_Renamed

        'The initial value when not performing is 10000ms -> 10s.
        Ret = GpTimeout(Timeout)                    'A time of a time out is designated.
        If CheckRet("GpTimeout", Ret, TextInit) = 1 Then GoTo Err_Renamed

        TextInit = "It was terminated normally."    'All in the case of 0
        Exit Function
Err_Renamed:
        GpibInit = 1

    End Function

    '///// [ GpibExit ] Function //////////////////////////////////////////////////////////////////////
    Public Function GpibExit() As Integer

        Ret = GpBoardsts(&HAS, Mode)                'Master(=0) or Slave(=1)
        If (Mode = 0) Then
            Cmd(0) = 2                              'Number of command
            Cmd(1) = &H3FS                          'Unlisten/UNL
            Cmd(2) = &H5FS                          'Untalken/UNT
            Ret = GpComand(pCmd)
            Ret = GpResetren()                      'A remote state is cancelled.
        End If
        Ret = GpExit()                              'End proccessing is perfomed.

    End Function

    '///// [ GpibPrint Function ] ////////////////////////////////////////////////////////////////////////////////////////
    Public Function GpibPrint(ByRef DeviceAddr As Integer, ByRef Str_Renamed As String) As Integer

        Ret = GpBoardsts(&H8S, MyAddr)
        Cmd(0) = 2
        Cmd(1) = MyAddr
        Cmd(2) = DeviceAddr

        'Srbuf = Str_Renamed
        Srlen = Len(Str_Renamed)
        'Ret = GpTalk(pCmd, Srlen, Srbuf)
        Ret = GpTalk(pCmd, Srlen, Str_Renamed)
        If (Ret <> 0) Then
            GpibPrint = 1
            RetTmp = CheckRet("GpTalk", Ret, ErrText)
            Ret = MsgBox("Send failed [ " & DeviceAddr & " ] <- [ " & Str_Renamed & " ] ", MsgBoxStyle.YesNo, "Continue?")
            If Ret = MsgBoxResult.No Then GpibPrint = 1
            If Ret = MsgBoxResult.Yes Then GpibPrint = 0
        End If

    End Function

    '///// [ GpibInput Function ] ////////////////////////////////////////////////////////////////////////////////////////
    Public Function GpibInput(ByRef DeviceAddr As Integer, ByRef Str_Renamed As String) As Integer

        Str_Renamed = Space(10000)
        Ret = GpBoardsts(&H8S, MyAddr)
        Srlen = 10000
        Cmd(0) = 2
        Cmd(1) = DeviceAddr
        Cmd(2) = MyAddr

        Ret = GpListen(pCmd, Srlen, Srbuf)

        If (Ret >= 3) Then
            RetTmp = CheckRet("GpListen", Ret, ErrText)
            Ret = MsgBox("Receive failed from [ " & DeviceAddr & " ] ", MsgBoxStyle.YesNo, "Continue?")
            If Ret = MsgBoxResult.No Then GpibInput = 1
            If Ret = MsgBoxResult.Yes Then
                GpibInput = 0
            End If
        End If
        Str_Renamed = Mid(Srbuf, 1, Srlen)

    End Function


    'Add HIOKI
    '///// [ GpibInputHioki Function ] //////////////////////////////////////////////////////////
    Public Function GpibInputHioki(ByRef DeviceAddr As Integer, ByRef Str As StringBuilder) As Integer

        Ret = GpBoardsts(&H8S, MyAddr)
        Cmd(0) = 2                                      'Number of command
        Cmd(1) = DeviceAddr                             'Slave device
        Cmd(2) = MyAddr                                 'My address(PC)

        Str.Clear()                                     'Initialise
        While True
            Srlen = 10000                               'Max receive size
            Ret = GpListen(pCmd, Srlen, Srbuf)
            If Ret <= 2 Then                            'Complete
                Str.Append(Mid(Srbuf, 1, Srlen))
                Exit While
            ElseIf Ret = 128 Then                       'Over
                Str.Append(Mid(Srbuf, 1, Srlen))
                Cmd(0) = 0
            Else                                        'Error check
                CheckRet("GpListen", Ret, ErrText)
                MsgBox("Receive failed from [ " & DeviceAddr & " ] ", MsgBoxStyle.OkOnly)
                Return 1                                'Invalid
            End If
        End While
        Return 0                                        'Valid

    End Function


    'Tektronix/TDS3000 for Binary Data Receive ///////////////////////////////////////////////////////////////////////////
    Public Function GpibListenB(ByRef Dev As Integer, ByVal pByteData As IntPtr, ByRef Srlen As Integer) As Integer
        Dim DataLen As New String("", 10)

        Ret = GpBoardsts(&H8S, MyAddr)
        Srlen = 2
        Cmd(0) = 2
        Cmd(1) = Dev
        Cmd(2) = MyAddr
        Ret = GpDelim(0, 1)                 'Change Delimita
        Ret = GpListen(pCmd, Srlen, DataLen)
        If (Ret <> 128) Then
            If (Ret >= 3) Then
                RetTmp = CheckRet("GpListen", Ret, ErrText)
                Ret = MsgBox("Receive failed from [ " & Dev & " ] ", MsgBoxStyle.YesNo, "Continue?")
                If (Ret = MsgBoxResult.No) Then
                    GpibListenB = 1
                    Exit Function
                End If
                If (Ret = MsgBoxResult.Yes) Then GpibListenB = 0
            End If
        End If
        Cmd(0) = 0                          'Don't sending
        Srlen = Val(Mid(DataLen, 2, 1))
        Ret = GpListen(pCmd, Srlen, DataLen)

        Srlen = Val(Mid(DataLen, 1, Srlen))
        Ret = GpListenBinary(pCmd, Srlen, pByteData)
        Ret = GpDelim(3, 1)                 'Return Delimita

    End Function

    '///// [ GpibInputB Function ] ///////////////////////////////////////////////////////////////////////////////////////
    Public Function GpibInputB(ByRef Dev As Integer, ByVal pByteData As IntPtr) As Integer

        Ret = GpBoardsts(&H8S, MyAddr)
        Srlen = 10000
        Cmd(0) = 2
        Cmd(1) = Dev
        Cmd(2) = MyAddr

        Ret = GpListenBinary(pCmd, Srlen, pByteData)
        If (Ret >= 3) Then
            RetTmp = CheckRet("GpListenBinary", Ret, ErrText)
            Ret = MsgBox(ErrText & "Continue?", MsgBoxStyle.YesNo, "Error")
            If (Ret = MsgBoxResult.No) Then
                GpibInputB = 1
                Exit Function
            End If
        Else
            GpibInputB = 0
        End If

    End Function

    '///// [ GpibCmd Function] //////////////////////////////////////////////////////////////////////////////////////////
    Public Function GpibCmd() As Integer

        Cmd(0) = 2
        Cmd(1) = &H3FS
        Cmd(2) = &H5FS

        Ret = GpComand(pCmd)
        If Ret <> 0 Then
            GpibCmd = 1
            RetTmp = CheckRet("GpComand", Ret, ErrText)
            Ret = MsgBox(ErrText, MsgBoxStyle.OkOnly, "Error")
            End
        End If
        GpibCmd = 0

    End Function

    ' Check "*OPC" ////////////////////////////////////////////////////////////////////////////////
    Public Sub WaitOPC(ByRef Dev As Integer)
        Dim RdData As String = ""

        Ret = GpibPrint(Dev, "*OPC?")
        Ret = GpibInput(Dev, RdData)

    End Sub
End Module