Attribute VB_Name = "PLC"
 Option Explicit
   Public RcvData() As Byte        '接收數組
   Public RcvLen As Integer        '接收數組長度
   Public Flag As Integer          '狀態標志
   Public Num As Integer           '重發次數計數器
   Public RcvFinFlag As Boolean    '接收完成標志
   Public SaveString As String     '輸入命令暫存字符串
 Public Sub Dread(instring As String, ByteCount As Integer)        '讀 D
  Dim s As String
  Flag = 0
  s = "0" & TransAd(instring) & Format(ByteCount, "00")
  Send s
 End Sub
  Public Sub Dwrite(instring As String, ByteCount As Integer, Data As String)        '寫 D
  Dim str1 As String
  Dim s As String
  Flag = 1
 Select Case ByteCount
 Case 2
    str1 = Exchange(Data)
 Case 4
    str1 = Exchange(Mid(Data, 1, 4)) & Exchange(Mid(Data, 5, 4))
 End Select
    s = "1" & TransAd(instring) & Format(ByteCount, "00") & str1
   Send s
 End Sub
 Public Sub BitForce(instring As String, AtOn As Boolean)         'Bit元件置位/復位
   Dim s As String
   If AtOn = True Then
     Flag = 7
     s = "7" & TransAd(instring)
   Else
     Flag = 8
     s = "8" & TransAd(instring)
   End If
   Send s
 End Sub
 Public Sub BitSearch(instring As String)             'Bit元件查詢狀態
    Dim s As String
    Flag = 9
    s = "0" & TransAdForSearch(instring) & "01"
    Send s
 End Sub
 Private Sub Send(Xstring As String)    '發送子程序
    Dim OutData() As Byte              '發送數組
    Dim length As Integer, i As Integer
 If RcvFinFlag = True Then
    SaveString = Xstring              '***保存發送字符串,為出錯重發做準備
    RcvLen = -1                       '接收數組長度初始化
    RcvFinFlag = False
    length = Len(Xstring)
    ReDim Preserve OutData(0 To length + 1) As Byte
    OutData(0) = &H2                    'STX
    For i = 1 To length
       OutData(i) = AscB(Mid(Xstring, i, 1))
    Next i
    OutData(length + 1) = &H3               'ETX
    Call FcSCheck(OutData)                  '加校驗和
    Form1.MSComm1.Output = OutData
    Call OutTxt(OutData)              '顯示數據
    Form1.Timer2.Enabled = True          '準備接收，打開定時器
Else
    MsgBox "前一個命令尚未執行完", vbExclamation, "操作提示"
End If
End Sub
Private Function Exchange(str1 As String) As String      '高低字節換位
    Dim i As Integer
    Dim Temp(3) As String
    Dim str2 As String
    str2 = ""
     Temp(0) = Mid(str1, 3, 1)
     Temp(1) = Mid(str1, 4, 1)
     Temp(2) = Mid(str1, 1, 1)
     Temp(3) = Mid(str1, 2, 1)
     For i = 0 To 3
     str2 = str2 & Temp(i)
     Next
     Exchange = str2
   End Function
 Private Function TransAd(Component As String) As String          ' Component地址轉換(5位格式)
    Dim Temp(4) As String
    Dim i As Integer, XY As Integer
    Dim str1 As String
    Dim value As Integer
    For i = 0 To 4
    Temp(i) = Mid(Component, i + 1, 1)
    Next
    value = Val(Temp(1) & Temp(2) & Temp(3) & Temp(4))
  Select Case Temp(0)
  Case "D"
     value = 2 * value + &H1000                      'D0 ,1 0 0 0
     str1 = Hex(value)
     TransAd = str1
  Case "M"
     value = value + &H800                            'M0, 0 0 0 8
     str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
     TransAd = Exchange(str1)
  Case "Y"
     If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "輸入錯誤,將改變Y" & value + 2 & "的值!", vbInformation
     XY = Fix(value / 10) * 2
     value = value + &H500 - XY                         'Y0, 0 0 0 5
     str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
     TransAd = Exchange(str1)
  Case "X"
    If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "輸入錯誤,將改變X" & value + 2 & "的值!", vbInformation
     XY = Fix(value / 10) * 2
     value = value + &H400 - XY                         'X0, 0 0 0 4
     str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
     TransAd = Exchange(str1)
  Case Else
     MsgBox "沒有定義!"
  End Select
End Function
Private Function TransAdForSearch(Component As String) As String 'Bit Component查詢地址轉換(5位格式)
    Dim Temp(4) As String
    Dim i As Integer, j As Integer
    Dim str1 As String
    Dim value As Integer
    For i = 0 To 4
    Temp(i) = Mid(Component, i + 1, 1)
    Next
    value = Val(Temp(1) & Temp(2) & Temp(3) & Temp(4))
  Select Case Temp(0)
   Case "M"
      value = Fix(value / 8)
      value = value + &H100
      str1 = IIf(Len(Hex(value)) = 3, "0" & Hex(value), Hex(value))
      TransAdForSearch = str1
   Case "Y"
     If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "輸入錯誤,將查詢Y" & value - 8 & "的值!", vbInformation
      value = Fix(value / 10)
      value = value + &HA0
      str1 = Hex(value)
      j = Len(str1)
      str1 = String(4 - j, "0") & str1
      TransAdForSearch = str1
   Case "X"
     If Temp(4) = "8" Or Temp(4) = "9" Then MsgBox "輸入錯誤,將查詢X" & value - 8 & "的值!", vbInformation
      value = Fix(value / 10)
      value = value + &H80
      str1 = Hex(value)
      j = Len(str1)
      str1 = String(4 - j, "0") & str1
      TransAdForSearch = str1
   Case Else
    MsgBox "沒有定義!"
    End Select
 End Function
   Public Function OutTxt(ss() As Byte) '發送記錄
      Dim i As Integer
      Dim vv As String
      Dim str1 As String
        For i = LBound(ss) To UBound(ss)
        str1 = IIf(Len(Hex(ss(i))) = 1, "0" & Hex(ss(i)), Hex(ss(i)))
        vv = vv & str1 & " "
        Next i
        Form1.Text6.Text = Form1.Text6.Text & "發送 " & vv & vbCrLf
     End Function
      Public Function InTxt(ss() As Byte) '接收記錄
       Dim i As Integer
       Dim vv As String
       Dim str1 As String
        For i = LBound(ss) To UBound(ss)
       str1 = IIf(Len(Hex(ss(i))) = 1, "0" & Hex(ss(i)), Hex(ss(i)))
        vv = vv & str1 & " "
        Next i
        Form1.Text6.Text = Form1.Text6.Text & "接收 " & vv & vbCrLf
     End Function
Private Sub FcSCheck(xData() As Byte)             '數組求校驗和
    Dim BufLen As Integer, Buf As String
    Dim i As Integer
    Dim CheckSum As Long
    BufLen = UBound(xData)
    CheckSum = 0
    For i = LBound(xData) + 1 To BufLen
       CheckSum = (CheckSum + xData(i)) And &HFF
    Next i
    Buf = IIf(Len(Hex(CheckSum)) = 1, "0" & Hex(CheckSum), Hex(CheckSum))
    ReDim Preserve xData(BufLen + 2) As Byte
    xData(BufLen + 1) = Asc(Mid(Buf, 1, 1))
    xData(BufLen + 2) = Asc(Mid(Buf, 2, 1))
End Sub
Public Sub ErrorHandle()                 ' 通信錯誤處理子程序
    If Num >= 0 And Num < 2 Then         '***重發次數2
        Num = Num + 1
        RcvFinFlag = True
        Call Send(SaveString)
        Exit Sub
    Else
        Form1.Timer2.Enabled = False
        MsgBox "請檢查硬件連接及報文設置", vbExclamation, "通信超時或通信過程出錯"
        Num = 0
        RcvFinFlag = True
        Exit Sub
     End If
 End Sub
       Public Function RcvDataChk(cData() As Byte) As Boolean     '校驗子程序
          Dim CheckFlag As Boolean
          CheckFlag = False
          Dim i As Integer, EndNo As Integer
          For i = 0 To UBound(cData)
          If cData(i) = &H3 Then                    '"ETX"
             EndNo = i
             Exit For
          End If
          Next i
          Dim dData() As Byte
          ReDim Preserve dData(0 To EndNo) As Byte
          For i = 0 To EndNo
          dData(i) = cData(i)
          Next i
          Call FcSCheck(dData)
          If dData(EndNo + 1) = cData(EndNo + 1) And dData(EndNo + 2) = cData(EndNo + 2) Then
          CheckFlag = True
          End If
          RcvDataChk = CheckFlag
        End Function
        Public Function RcvDataDisplay(xRcv() As Byte) As String    '顯示子函數
           Dim str1 As String
           Dim i As Integer
           str1 = ""
          If xRcv(0) = &H2 Then                           '"STX"
             For i = 1 To UBound(xRcv)
             If xRcv(i) <> &H3 Then                       '"ETX"
             str1 = str1 & Chr(xRcv(i))
             Else
             Exit For
             End If
             Next i
            Select Case Len(str1)
             Case 4
             RcvDataDisplay = Exchange(str1)
             Case 8
             RcvDataDisplay = Exchange(Mid(str1, 1, 4)) & Exchange(Mid(str1, 5, 4))       '十六進制
            End Select
            'Form1.txtview = Format((Val("&h" & ShwTemp) / 10), "# #0.0")  '十進制
           End If
        End Function
        Public Sub BitDisplay(xRcv() As Byte)    '顯示子函數
           Dim str1 As String
           Dim i As Integer, j As Integer
           Dim value As Integer
           Dim Binary(7) As Byte
            str1 = Chr(xRcv(1))
            str1 = str1 & Chr(xRcv(2))
               value = Val("&h" & str1)
               j = 128
               For i = 7 To 0 Step -1
               Binary(i) = Fix(value / j)
               value = value Mod j
               j = j / 2
               Next i
            If Form1.Combo1.Text = "M" Then
               value = Val(Form1.Text5.Text)
               i = 0
                 For j = 0 To 7
                  If value Mod 8 = 0 Then Exit For
                  i = i + 1
                  value = value - 1
                 Next
            Else
                i = Val(Mid(Form1.Text5.Text, 4, 1))
                If i = 8 Then i = 0
                If i = 9 Then i = 1
            End If
            If Binary(i) = 1 Then
                  Form1.Shape1.FillColor = vbRed
                Else
                  Form1.Shape1.FillColor = vbBlack
            End If
        End Sub
        Public Sub ConFirm(CodeByte As Byte)
            Dim OutData(0) As Byte              '發送數組
            OutData(0) = CodeByte
            Form1.MSComm1.Output = OutData
            Call OutTxt(OutData)              '顯示數據
        End Sub