Option Explicit
'****************************************************************************
' 機能名    : EXCEL通信テスト(RS232C)
' 機能説明  : EXCELを使用したRS232Cの通信テストツール
' 著作権    : Copyright(C) 2010 のん All rights reserved
' 動作環境  : VB6の開発環境(特にMSCOMM32.OCX)
'****************************************************************************

' MSCOMM32.OCXを参照設定しています
Private WithEvents MSComm1 As MSCommLib.MSComm

' 受信データ表示行番号
Private InputRow As Long

' COMポートオープン
Private Sub Btn_Open_Click()
    ' COMポートオープンチェック
    If MSComm1 Is Nothing = False Then
        If MSComm1.PortOpen = True Then
            MsgBox "既にCOMポートがオープンされています"
            Exit Sub
        End If
    End If
    
    ' 受信データ表示カラムをクリア
    Sheet1.Range("B15:B999") = ""

    ' 受信データ表示行番号初期化
    InputRow = 15
    
    ' COMポートオープン情報取得
    Dim prt As String: prt = Sheet1.Cells(5, 4)
    Dim spd As String: spd = Sheet1.Cells(7, 4)
    Dim pri As String: pri = Sheet1.Cells(9, 4)
    Dim bit As String: bit = Sheet1.Cells(11, 4)
    Dim stp As String: stp = Sheet1.Cells(13, 4)
    
    ' COMポートのオープン
    Set MSComm1 = New MSCommLib.MSComm
    MSComm1.Settings = spd & "," & pri & "," & bit & "," & stp
    MSComm1.CommPort = prt
    MSComm1.PortOpen = True
    
    ' DTR、RTSの初期設定
    MSComm1.DTREnable = Chk_DTR.Value
    MSComm1.RTSEnable = Chk_RTS.Value

    ' CTS、DSRの初期確認
    Chk_CTS.Value = MSComm1.CTSHolding
    Chk_DSR.Value = MSComm1.DSRHolding

    ' COMポート受信イベント作成
    MSComm1.RThreshold = 1
End Sub

' COMポートクローズ
Private Sub Btn_Close_Click()
    ' COMポートオープンチェック
    If MSComm1 Is Nothing Then
        MsgBox "COMポートがオープンされていません"
        Exit Sub
    ElseIf MSComm1.PortOpen = False Then
        MsgBox "COMポートがオープンされていません"
        Exit Sub
    End If
    
    ' COMポートのクローズ
    MSComm1.PortOpen = False
    Set MSComm1 = Nothing
End Sub

' COMポートへデータ送信
Private Sub Btn_Send_Click()
    ' COMポートオープンチェック
    If MSComm1 Is Nothing Then
        MsgBox "COMポートがオープンされていません"
        Exit Sub
    ElseIf MSComm1.PortOpen = False Then
        MsgBox "COMポートがオープンされていません"
        Exit Sub
    End If
    
    ' 選択したセルのデータを送信データとする
    Dim sdat As String
    If ActiveCell.Row >= 4 And ActiveCell.Column >= 2 And _
       ActiveCell.Row <= 13 And ActiveCell.Column <= 4 Then
        sdat = Sheet1.Cells(ActiveCell.Row, ActiveCell.Column)
    End If
    
    If sdat <> "" Then
        If Sheet1.Chk_SHex.Value = True Then
            ' 送信データをHEXコードから文字列に変換--ここから--
            On Error Resume Next
            Dim i As Long
            ReDim shex(Int((Len(sdat) + 1) / 2) - 1) As Byte
            For i = 0 To Len(sdat) - 1 Step 2
                shex(i / 2) = "&H" & Mid$(sdat, i + 1, 2)
            Next i
            On Error GoTo 0
            ' 送信データをHEXコードから文字列に変換--ここまで--
            
            ' COMポートにデータ送信
            MSComm1.Output = shex
        Else
            ' COMポートにデータ送信
            MSComm1.Output = sdat
        End If
    Else
        MsgBox "送信データ(セル)を選択してください。"
    End If
End Sub

' COMポートからデータ受信
Private Sub MSComm1_OnComm()
    ' COMポートオープンチェック
    If MSComm1 Is Nothing Then
        'MsgBox "COMポートがオープンされていません"
        Exit Sub
    ElseIf MSComm1.PortOpen = False Then
        'MsgBox "COMポートがオープンされていません"
        Exit Sub
    End If
    
    ' COMポートからデータ受信
    If MSComm1.CommEvent = comEvReceive Then
        Dim rdat As String: rdat = ""
        If Sheet1.Chk_RHex.Value = True Then
            ' COMポートからデータ受信
            Dim rhex() As Byte
            MSComm1.InputMode = comInputModeBinary
            rhex = MSComm1.Input
            
            ' 受信データをHEXコードに変換--ここから----------------
            Dim i As Long
            For i = 0 To UBound(rhex)
                Dim str As String
                str = "00" & Hex(rhex(i))
                rdat = rdat & Right$(str, 2)
            Next i
            ' 受信データをHEXコードに変換--ここまで----------------
        Else
            ' COMポートからデータ受信
            MSComm1.InputMode = comInputModeText
            rdat = MSComm1.Input
        End If
        
        ' 受信データ表示セルに受信データを表示
        rdat = Replace$(rdat, Chr(0), "")
        Sheet1.Cells(InputRow, 2) = "" & rdat
        InputRow = InputRow + 1
    End If
    Chk_CTS.Value = MSComm1.CTSHolding
    Chk_DSR.Value = MSComm1.DSRHolding
End Sub

' COMポートへDTR設定
Private Sub Chk_DTR_Click()
    ' COMポートオープンチェック
    If MSComm1 Is Nothing Then
        Exit Sub
    ElseIf MSComm1.PortOpen = False Then
        Exit Sub
    End If
    MSComm1.DTREnable = Chk_DTR.Value
End Sub

' COMポートへRTS設定
Private Sub Chk_RTS_Click()
    ' COMポートオープンチェック
    If MSComm1 Is Nothing Then
        Exit Sub
    ElseIf MSComm1.PortOpen = False Then
        Exit Sub
    End If
    MSComm1.RTSEnable = Chk_RTS.Value
End Sub

' 送信データ選択カラム変更
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Sheet1.Unprotect
    Sheet1.Range("B4:C13").Font.ColorIndex = 0
    If Target.Cells.Row >= 4 And Target.Cells.Row <= 13 And _
       Target.Cells.Column >= 2 And Target.Cells.Column <= 3 Then
        Target.Font.ColorIndex = 3
    End If
    Sheet1.Protect
End Sub