ab.com コミュニティ

コード: 全て選択

#console

'3-1-1.初期設定
'最初にWin32APIのコントロールとデータ入出力に必要なデータ領域を確保します． 
Type DCB
        DCBlength As Long            '構造体のサイズ
        BaudRate As Long             'ボーレイト（bps）の設定
        fBitFields As Long           'ビット単位のフィールド定義
        wReserved As Integer         '予約（0をセットする）
        XonLim As Integer            '受信バッファ中のデータが何バイトになったらXon文字を送るかを指定
        XoffLim As Integer           '受信バッファの空きが何バイトになったらXoff文字を送るかを指定
        ByteSize As Byte             '1データのビット数を指定
        Parity As Byte               'パリティの方式を指定
        StopBits As Byte             'ストップビット数を指定
        XonChar As Byte              'Xon文字を指定
        XoffChar As Byte             'Xoff文字を指定
        ErrorChar As Byte            'パリティエラーの場合に使う文字を指定
        EofChar As Byte              '非バイナリモードの場合のデータ終了文字の指定
        EvtChar As Byte              'イベントを生成する文字を指定
End Type

' COMMTIMEOUTS構造体の定義
Type COMMTIMEOUTS
        ReadIntervalTimeout As Long          '文字の読み込みの待ち時間
        ReadTotalTimeoutMultiplier As Long   '読み込みの１文字あたりの時間
        ReadTotalTimeoutConstant As Long     '読み込みの定数時間
        WriteTotalTimeoutMultiplier As Long  '書き込みの１文字あたりの時間
        WriteTotalTimeoutConstant As Long    '書き込みの定数時間
End Type

' COMSTAT構造体の定義
Type COMSTAT
		fCoBitFlds As Long 'See Comment in Win32API.Txt
		cbInQue As Integer
		cbOutQue As Integer
End Type 

Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (lpEventAttributes As *SECURITY_ATTRIBUTES, bManualReset As Long, bInitialState As Long, lpName As *Char) As Long
Declare Function GetCommState Lib "kernel32" Alias "GetCommState" (nCid As HANDLE,ByRef lpDCB As DCB) As Long
Declare Function GetCommTimeouts Lib "kernel32" Alias "GetCommTimeouts" (hFile As HANDLE,ByRef lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function BuildCommDCB Lib "kernel32" Alias "BuildCommDCBA" (ByVal lpDef As String,ByRef lpDCB As DCB) As Long
Declare Function BuildCommDCBAndTimeouts Lib "kernel32" Alias "BuildCommDCBAndTimeoutsA" (ByVal lpDef As String,ByRef lpDCB As DCB,ByRef lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function SetCommState Lib "kernel32" (hCommDev As HANDLE,ByRef lpDCB As DCB) As Long
Declare Function SetCommTimeouts Lib "kernel32" (hFile As HANDLE,ByRef lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function GetOverlappedResult Lib "kernel32" Alias "GetOverlappedResult" (hFile As HANDLE,ByRef lpOverlapped As OVERLAPPED,lpNumberOfBytesTransferred As VoidPtr, ByVal bWait As Long) As Long
Declare Function ResetEvent Lib "kernel32" (hEvent As HANDLE) As Long
Declare Function ClearCommError Lib "kernel32" Alias "ClearCommError" (hFile As HANDLE, lpErrors As Long,ByRef lpStat As COMSTAT) As Long
Declare Function SetCommMask Lib "kernel32" Alias "SetCommMask" (hFile As HANDLE, ByVal dwEvtMask As Long) As Long
Declare Function WaitCommEvent Lib "kernel32" Alias "WaitCommEvent" (hFile As HANDLE, lpEvtMask As Long,ByRef lpOverlapped As OVERLAPPED) As Long
Declare Function PurgeComm Lib "kernel32" Alias "PurgeComm" (hFile As HANDLE, ByVal dwFlags As Long) As Long

' Error Flags
Const CE_RXOVER = &H1                '  Receive Queue overflow
Const CE_OVERRUN = &H2               '  Receive Overrun Error
Const CE_RXPARITY = &H4              '  Receive Parity Error
Const CE_FRAME = &H8                 '  Receive Framing error
Const CE_BREAK = &H10                '  Break Detected
Const CE_TXFULL = &H100              '  TX Queue is full
Const CE_PTO = &H200                 '  LPTx Timeout
Const CE_IOE = &H400                 '  LPTx I/O Error
Const CE_DNS = &H800                 '  LPTx Device not selected
Const CE_OOP = &H1000                '  LPTx Out-Of-Paper
Const CE_MODE = &H8000               '  Requested mode unsupported

' Events
Const EV_RXCHAR = &H1                '  Any Character received
Const EV_RXFLAG = &H2                '  Received certain character
Const EV_TXEMPTY = &H4               '  Transmitt Queue Empty
Const EV_CTS = &H8                   '  CTS changed state
Const EV_DSR = &H10                  '  DSR changed state
Const EV_RLSD = &H20                 '  RLSD changed state
Const EV_BREAK = &H40                '  BREAK received
Const EV_ERR = &H80                  '  Line status error occurred
Const EV_RING = &H100                '  Ring signal detected
Const EV_PERR = &H200                '  Printer error occured
Const EV_RX80FULL = &H400            '  Receive buffer is 80 percent full
Const EV_EVENT1 = &H800              '  Provider specific event 1
Const EV_EVENT2 = &H1000             '  Provider specific event 2

'WaitForSingleObjectの戻り値
Const WAIT_OBJECT_0 = &h00000000 ' オブジェクトがシグナル状態になったことを示します。
Const WAIT_ABANDONED = &h00000080 ' 放棄されたためにミューテックスオブジェクトがシグナル状態になったことを示します。
Const WAIT_FAILED = &hFFFFFFFF 'エラーが発生したことを示します。拡張エラー情報を取得するには、 GetLastError 関数を使います。

'PurgeCommの引数
Const PURGE_TXABORT = 1
Const PURGE_RXABORT = 2
Const PURGE_TXCLEAR = 4
Const PURGE_RXCLEAR = 8

'*****************************************************************************************************
'*****************************************************************************************************

Const BUFFERSIZE = 1024
Const LineMax = 256
Const TIMEOUT_MUL = 50

'------------------------------------------------------------------------------------------
Dim ser_hdl As HANDLE
Dim dcb As  DCB
Dim comstat As COMSTAT
Dim timeout As COMMTIMEOUTS
Dim SerialEvent As DWORD
Dim o_send As OVERLAPPED
Dim o_receive As OVERLAPPED
Dim o_event As OVERLAPPED

Dim ByteRead As DWord
Dim ByteWrite As DWord
Dim DataLength As DWord
Dim ErrorMask As DWord
Dim IOBuf[BUFFERSIZE] As Byte
Dim RingBuf[BUFFERSIZE] As Byte
Dim DataBuf[BUFFERSIZE] As Byte
Dim OutBuf[256] As Byte
Dim WritePoint As Integer
Dim ReadPoint As Integer
Dim DataCount As DWord
Dim ev_chr As Byte

Dim Terminated As Byte
Terminated = 1

''Main()

	'3-2-2. Threadの開始方法
	'Threadを開始するにはC++のnewメソッドで行います．
    SerialThread = new TSerialThread(THREAD_PRIORITY_NORMAL , 3)

	'3-2-5. Threadとメインプログラムの間でデータの受け渡しをする方法
	'通常Threadではデータの取得のみを請け負い，取得されたデータの処理は別Threadもしくはメインプログラム側で行うことが多いと思います．このような場合２つのThread間で安全にデータの受け渡しができるように工夫する必要があります．このような場合にはEventとCRITICAL_SECTIONを利用します．これらを使用する場合には予めこれらのメモリー領域を確保しておく必要があります．

	Dim CritSec_Serial As CRITICAL_SECTION
	Dim hGet_event As HANDLE
	'と宣言しておいてメインフォームのOnCreate関数の中で 
	'//  Critical Section Initialize
	InitializeCriticalSection(CritSec_Serial)
	hGet_event = CreateEvent(NULL, FALSE, FALSE, NULL) As VoidPtr	

	''メイン処理は寝ている
	Sleep(9999999)

	'なおEventやCRITICAL_SECTIONはメインプログラムの終了時にはその領域を開放しなければなりません．
	'これは以下のようにメインフォームのFormDestroy関数に書いておきます．
	'//---------------------------------------------------------------------------
	'void __fastcall TForm1::FormDestroy(TObject *Sender)
	'//  Close Event Handle
    CloseHandle(hGet_event) 
	'//  Delete Critical Section

	'3-2-3. Threadの終了
	'Threadを終了させるにはTerminateメソッドを使用します．
    if SerialThread Then
        SerialThread.Terminate()
	EndIf

End

'*****************************************************************************************************
'*****************************************************************************************************

'3-2-1. Threadのヘッダ
'class TSerialThread : public TThread
class TSerialThread 
	public
'//---------------------------------------------------------------------------
'__fastcall TSerialThread::TSerialThread(TThreadPriority StartPriority) : TThread(true)
		Sub TSerialThread(TThreadPriority As Byte , StartPriority As Byte) As void
		    Priority = StartPriority
		    FreeOnTerminate = TRUE
		    Resume()
		End Sub

'//---------------------------------------------------------------------------
'__fastcall TSerialThread::~TSerialThread(void)
		Sub ~TSerialThread() As void
		    if ser_hdl <> NULL Then
		        COMclose()
		        ser_hdl = NULL
		    EndIf
		End Sub
'//---------------------------------------------------------------------------

	private
		Dim Message As String
		Sub Execute() As Void
		    While
				WaitForSingleObject(hGet_event, INFINITE)
		        if Terminate Then
					Exit While
				End If
				EnterCriticalSection( CritSec_Serial )
'//        Data 取得ルーチンをここに書く
				LeaveCriticalSection( CritSec_Serial )
'//        演算ルーチンをここに書く
			Wend
		End Sub

		'3-2-4. Threadから画面にデータを表示される方法
		'先に書きましたようにここではUpdateLine関数と UpdateDispLine関数を追加しています． 
		Sub UpdateLine(s As String)
		    Message = s
		    Synchronize(UpdateDispLine)
		End Sub

		Sub UpdateDispLine() As Void
''		    Form1.eEdit.Text = Message
		End Sub

End Class

'*****************************************************************************************************
'*****************************************************************************************************

Sub COMsetup() As Void
    o_send.Internal = 0
    o_send.InternalHigh = 0
    o_send.Offset = 0
    o_send.OffsetHigh = 0
    o_send.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL)

    o_receive.Internal = 0
    o_receive.InternalHigh = 0
    o_receive.Offset = 0
    o_receive.OffsetHigh = 0
    o_receive.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL)

    o_event.Internal = 0
    o_event.InternalHigh = 0
    o_event.Offset = 0
    o_event.OffsetHigh = 0
    o_event.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL)

'//  Initialize COM port
    ser_hdl = CreateFile("COM1", GENERIC_READ Or GENERIC_WRITE,0,ByVal 0,OPEN_EXISTING,FILE_FLAG_OVERLAPPED, 0 )
    GetCommState(ser_hdl, dcb)
    GetCommTimeouts(ser_hdl, timeout)
    BuildCommDCB("baud=9600 parity=N data=8 stop=1",dcb)
'//   BuildCommDCBAndTimeouts("baud=9600 parity=N data=8 stop=1",dcb,timeout)

'   DCB構造体fBitFieldsにBit指定されているメンバだが一気に設定する。
	'dcb.fRtsControl = RTS_CONTROL_DISABLE
	'dcb.fOutxDsrFlow = FALSE
	'dcb.fAbortOnError = FALSE
    dcb.fBitFields = &H0000
    dcb.EvtChar = ev_chr

    timeout.WriteTotalTimeoutConstant = 0
    timeout.WriteTotalTimeoutMultiplier = TIMEOUT_MUL
    timeout.ReadIntervalTimeout = &HFFFFFFFF
    timeout.ReadTotalTimeoutConstant = 0
    timeout.ReadTotalTimeoutMultiplier = TIMEOUT_MUL

    SetCommState(ser_hdl,dcb)
    SetCommTimeouts(ser_hdl,timeout)

    ReadPoint = 0 : WritePoint = 0 : DataCount = 0 

End Sub	

'*****************************************************************************************************
'*****************************************************************************************************

'
'3-1-2. ASCIIデータの受信
'データの読み込みにはReadFile関数を用います．OVERLAP構造体を用いたbackground読み込みのためにRead_BackGround関数を作成しています．以下にはThreadオブジェクトのExecute関数も示しています．
'
'//  Get and Fill RingBuf from System Buffer
Sub Read_BackGround(cnt As DWord) As void

	Dim endtime As DWord 

    if ReadFile(ser_hdl, IOBuf, cnt,VarPtr(ByteRead), o_receive) <> 0  Then
        ByteRead = 0
        if GetLastError() = ERROR_IO_PENDING Then
            endtime = GetTickCount() + 200
            while GetOverlappedResult(ser_hdl, o_receive,VarPtr(ByteRead), 0 ) <> 0
                if( GetTickCount() > endtime )	Then
                    Exit While
                EndIf
            Wend
        else
            GetLastError()
        EndIf
    EndIf
    ResetEvent(o_receive.hEvent As HANDLE)
End Sub

'//  Get and Fill RingBuf from System Buffer
Sub COMread_line() As void
	Dim i As Word

    ClearCommError(ser_hdl, &ErrorMask, comstat)
    if comstat.cbInQue = 0 Then
		Exit Sub
	End If
    if comstat.cbInQue > BUFFERSIZE - DataCount Then
        Read_BackGround( BUFFERSIZE - DataCount )
    else
        Read_BackGround(comstat.cbInQue)
    End If
    if DataLength = 0 Then
		Exit Sub
    End If
    for i=0 To i<DataLength Step 1
		RingBuf( WritePoint = WritePoint + 1 ) = IOBuf(i)
        DataCount++
        if  WritePoint >= BUFFERSIZE Then
            WritePoint = 0
		EndIf
	Next i
End Sub

'//  Get 1 line from RingBuf if exist then return TRUE
'//                                   else return FALSE
Function get_COM_line(ByRef buf As Byte)Integer
	Dim i As DWord
	Dim j As Integer

    COMread_line()
	j=ReadPoint
	For i=0 To i<DataCount Step 1 
		SetByte(buf,RingBuf[j])
        if  GetByte(buf) = ev_chr Then
            SetByte(buf,0)
    	    Exit For
		End If

'//  ignore control code ( <0x20 )
        if GetByte(buf) >= &h20 Then
    	    buf++
        else
            SetByte(buf,0)
        End If
    	if ++j = BUFFERSIZE Then
    		j=0
    	EndIf
    Next i
    if i >= DataCount Then
		get_COM_line = FALSE : Exit Sub
   	EndIf
    if ++j = BUFFERSIZE Then
    	j = 0
   	EndIf
    ReadPoint = j
    DataCount -= (i+1)
	get_COM_line = TRUE : Exit Sub

End Function
'//---------------------------------------------------------------------------
Sub TSerialThread() As void
'void __fastcall TSerialThread::Execute(void)
    ev_chr = &h0a

    COMsetup()
    if ser_hdl = NULL Then
        Exit Sub
    End If
    Do
        SetCommMask(ser_hdl, EV_RXFLAG)
        WaitCommEvent(ser_hdl, &SerialEvent As Long, o_event)
		Do
		    if WaitForSingleObject(o_event.hEvent As VoidPtr,200) = WAIT_OBJECT_0 Then
                ClearCommError(ser_hdl, &ErrorMask As Long, comstat)
                ResetEvent(o_event.hEvent As VoidPtr)
'//	if Serial communication error occured, then call PurgeComm
                if ErrorMask or CE_IOE Then
'                    PurgeComm(ser_hdl,PURGE_REABORT);
                    PurgeComm(ser_hdl,PURGE_TXABORT Or PURGE_RXABORT)

                EndIf
                Exit Do
           	End If	
            if Terminated Then
                Exit Sub
            End If
        Loop
        Do
            if get_COM_line(DataBuf) = FALSE Then
                Exit Do
            End If
'//    Add DataBuf processing routines here !!
        Loop
    Loop

End Sub

'*****************************************************************************************************
'*****************************************************************************************************

'通信が終了したら回線を閉じます．回線を閉じるにはCloseHandle関数を用います． 
'//---------------------------------------------------------------------------
'void __fastcall COMclose(void)
Sub COMclose() As Void
    SetCommMask(ser_hdl, 0)
    PurgeComm(ser_hdl, PURGE_RXCLEAR)
    PurgeComm(ser_hdl, PURGE_TXCLEAR)
    PurgeComm(ser_hdl, PURGE_RXABORT)
    PurgeComm(ser_hdl, PURGE_TXABORT)
    GetCommState(ser_hdl, dcb)

'   DCB構造体fBitFieldsにBit指定されているメンバだが一気に設定する。
'    dcb.fOutxCtsFlow = FALSE
'    dcb.fRtsControl = RTS_CONTROL_DISABLE
'    dcb.fAbortOnError = TRUE
'    dcb.fOutxDsrFlow = FALSE
    dcb.fBitFields = &HE000

    SetCommState(ser_hdl, dcb)
    CloseHandle(o_receive.hEvent As VoidPtr)
    CloseHandle(o_send.hEvent As VoidPtr)
    CloseHandle(o_event.hEvent As VoidPtr)
    CloseHandle(ser_hdl as VoidPtr)
EndSub