finsedit.frm

OMRON FINS 串口 以太网通讯协议软件原代码

        Memory = "00"
    Case 1
 '       Text4.Text = "CIO Word"
        Memory = "80"
    Case 2
  '     Text4.Text = "T/C PV"
        Memory = "81"
    Case 3
  '      Text4.Text = "T/C Flag"
        Memory = "01"
    Case 4
    '    Text4.Text = "DM"
        Memory = "82"
    Case 5
     '   Text4.Text = "EM-0"
        Memory = "90"
    Case 6
     '   Text4.Text = "EM-1"
        Memory = "91"
    Case 7
     '   Text4.Text = "EM-2"
        Memory = "92"
    Case 8
     '   Text4.Text = "EM-3"
        Memory = "93"
    Case 9
     '   Text4.Text = "EM-4"
        Memory = "94"
    Case 10
     '   Text4.Text = "EM-5"
        Memory = "95"
    Case 11
     '   Text4.Text = "EM-6"
        Memory = "96"
    Case 12
     '   Text4.Text = "EM-7"
        Memory = "97"
    Case 13
     '   Text4.Text = "WR Bit"
        Memory = "31"
    Case 14
     '   Text4.Text = "WR Word"
        Memory = "B1"
End Select
End Sub

Private Sub Combo4_Click()
Dim TmpInx As Long
TmpInx = Combo4.ListIndex
If TmpInx < 16 Then
    Bit = "0" & Hex(TmpInx)
Else
    Bit = Hex(TmpInx)
End If

End Sub

Private Sub Command1_Click()
If Combo2.ListIndex < 2 Then
    Select Case Combo1(3).ListIndex
        Case 0
            Call SysMacWayDispose
        Case 1
            Call EthernetDispose
    End Select
Else
    Call FcsCnt
End If
Text1.Text = EndStr
If Check1.Value = 1 Then
    EndStr = EndStr & Chr(10) & " '" & "ICF= " & ICF & " RSV= " & RSV & " GCT= " & GCT & " DNA= " & DNA & " DA1= " & DA1 & " DA2= " & DA2 & " SNA= " & SNA & " SA1= " & SA1 & " SA2= " & SA2 & " SID= " & SID
    EndStr = EndStr & Chr(10) & "' CommandCode= " & CommandCode & " Memory= " & Memory & " Bit= " & Bit & " Address= " & Address & " Number= " & Num
End If
If Check2.Value = 1 Then
    Clipboard.Clear
    Clipboard.SetText EndStr
End If

End Sub

Private Sub Command2_Click()
'MsgBox PortID & " " & PortSet
Unload Me
End Sub

Private Sub Command3_Click()
Dim RemIp As String
RemIp = Combo1(10).Text & "." & Combo1(11).Text & "." & Combo1(12).Text & "." & Combo1(13).Text
If Combo1(3).ListIndex = 1 And Text1.Text <> " " Then
    StrToArr Text1.Text
    If RemIp <> Winsock1.RemoteHostIP Then
        Winsock1.Close
        Winsock1.RemoteHost = RemIp
        Winsock1.RemotePort = Text3.Text
    End If
    
    If Winsock1.State = 0 Then Winsock1.Connect
    Winsock1.SendData (EtnFins)
End If
End Sub

Private Sub EtnConnect()
Dim RemPort As Long
Dim RemIp As String
RemPort = Val(Text3.Text)

RemIp = Combo1(10).Text & "." & Combo1(11).Text & "." & Combo1(12).Text & "." & Combo1(13).Text
Winsock1.RemoteHost = RemIp
Winsock1.RemotePort = RemPort
Winsock1.Connect

End Sub

Private Sub Command4_Click()
On Error GoTo Err

Command1_Click
If MSComm1.PortOpen = False Then
    MSComm1.CommPort = Combo1(14).ListIndex + 1
    MSComm1.Settings = Combo5.Text & "," & Combo6.Text
    MSComm1.PortOpen = True
End If

MSComm1.Output = Text1.Text & vbCr
Exit Sub

Err:
MsgBox Error

End Sub

Private Sub Form_Load()
Dim IPAddress As String
Dim a As Long
Dim hbitmap As Long
'Dim hwnda As Long
'hwnda = Me.hwnd
'Me.AutoRedraw = True
'a = SetWindowPos(hwnda, -1, 500, 0, 108, 15, &H40)
'-------------------------------------------------------------
'finsform.Width = 7100
'finsform.Height = 4100
finsform.Caption = "欧姆龙 FINS 命令编辑器"
finsform.Appearance = 1
Command1.Caption = "&Enter"
Command1.Default = True
Command2.Caption = "E&xit"
'Text4.Text = "DM"
Text5.Text = "000000"
VScroll4.Value = 0
Address = "000000"
Text6.Text = "0001"
VScroll5.Value = 1
Num = "0001"
Me.Refresh
'========================== 源添加网络号 =============================
Dim Inx As Long
For Inx = 0 To 255
    If Inx < 128 Then
        Combo1(0).AddItem Inx
        Combo1(1).AddItem Inx
    End If
    If Inx < 127 Then Combo1(2).AddItem Inx
    If Inx < 32 Then Combo1(4).AddItem Inx
    Combo1(5).AddItem Inx
    Combo1(6).AddItem Inx
    Combo1(7).AddItem Inx
    Combo1(8).AddItem Inx
    Combo1(9).AddItem Inx
    Combo1(10).AddItem Inx
    Combo1(11).AddItem Inx
    Combo1(12).AddItem Inx
    Combo1(13).AddItem Inx
Next Inx
Combo1(0).ListIndex = 0
Combo1(1).ListIndex = 0
Combo1(2).ListIndex = 0
Combo1(3).ListIndex = 0
Combo1(4).ListIndex = 0
Combo1(5).ListIndex = 0
Combo2.ListIndex = 0
Combo3.ListIndex = 0
Combo4.ListIndex = 0
Label6(0).Enabled = False
Combo1(0).Enabled = False
Call IPDispose
End Sub

Private Sub MSComm1_OnComm()
Dim Tmpstr As String
Dim Tmplon As Long
Dim Tmplon1 As Long

Tmpstr = MSComm1.Input
RevInfoStr = RevInfoStr & Tmpstr
Tmplon = InStr(1, RevInfoStr, "@", vbBinaryCompare)
If Tmplon < 1 Then Exit Sub
Tmplon1 = InStr(Tmplon, RevInfoStr, vbCr, vbBinaryCompare)

If Tmplon1 > Tmplon And Tmplon > 0 Then
    Tmpstr = Mid(RevInfoStr, Tmplon, Tmplon1 - Tmplon)
    RevInfoStr = Mid(RevInfoStr, Tmplon1, Len(RevInfoStr) - tmpstr1)
    RevinfoCnt = RevinfoCnt + 1
End If

Text2.Text = RevinfoCnt & ":" & Tmpstr

End Sub

Private Sub Option1_Click()
Call IPDispose
Combo1(6).Enabled = False
Combo1(7).Enabled = False
Combo1(8).Enabled = False
Combo1(9).Enabled = False
End Sub
Private Sub Option2_Click()
Combo1(6).Enabled = True
Combo1(7).Enabled = True
Combo1(8).Enabled = True
Combo1(9).Enabled = True
End Sub

Private Sub Text5_LostFocus()
Dim lon As Long
Dim textval As String
Dim hexlon As Long
On Error GoTo Err
textval = (Text5.Text)
lon = Len(textval)
If lon <= 6 Then lon = lon Else lon = 6
If textval <= 24575 Then
        Text5.Text = String$((6 - lon), "0") & textval
    Else
        Text5.Text = 24575
End If
VScroll4.Value = textval
hexlon = Len((Hex$(Val(Text5.Text))))
Address = String$((4 - hexlon), "0") & Hex$(Text5.Text) & "00"
Exit Sub
Err:
Text5.Text = "000000"
MsgBox "输入的数据有错误！", vbOKOnly + vbInformation, "错误"
End Sub
Private Sub VScroll4_Change()
Dim lon As Long
Dim textval As String
Dim hexlon As Long
textval = VScroll4.Value
lon = Len(textval)
If textval <= 24575 Then
        Text5.Text = String$((6 - lon), "0") & textval
    Else
        VScroll4.Value = 24575
End If
hexlon = Len((Hex$(Val(Text5.Text))))
Address = String$((4 - hexlon), "0") & Hex$(Text5.Text) & "00"
End Sub
Private Sub Text6_LostFocus()
If Val(Text6.Text) < 998 Then
    VScroll5.Value = Val(Text6.Text)
Else
    VScroll5.Value = 998
    Text6.Text = 998
End If
End Sub
Private Sub VScroll5_Change()
Dim lon As Long
Dim textval As String
Dim hexlon As Long
textval = VScroll5.Value
lon = Len(textval)
If VScroll5.Value <= 998 Then
        Text6.Text = String$((4 - lon), "0") & VScroll5.Value
    Else
        VScroll5.Value = 998
End If
hexlon = Len(Hex$(VScroll5.Value))
Num = String$((4 - hexlon), "0") & Hex$(VScroll5.Value)
End Sub

'============================== 选择以太网时数据处理
Private Sub EthernetDispose()
Dim Tmpstr As String
'Ethernet Fins Command
'  80   00   02  XX   XX 00  XX   00  00  XX   XXXX             XXX...          ...XXX
'  ICF  RSV GCT DNA  DA1 DA2 SNA  SA1 SA2 SID  COMMAND CODE     Text Max 1998 Bytes
If CommandCode = "0102" Then
EntData:

    Tmpstr = InputBox(" 请写入" & Str(VScroll5.Value * 4) & "位数据！" & vbCr & " 数据格式为 0000～FFFF ！", "写入数据", String(VScroll5.Value * 4, "0"))
    If Tmpstr = "" Then Exit Sub
    If Len(Tmpstr) < VScroll5.Value * 4 Then GoTo EntData
    WriteData = Mid(UCase(Tmpstr), 1, VScroll5.Value * 4)
End If

ICF = "80": RSV = "00": GCT = "02": DA2 = "00":  SA2 = "00"
EndStr = ICF & RSV & GCT & DNA & DA1 & DA2 & SNA & SA1 & SA2 & SID & CommandCode & Memory & Bit & Address & Num & WriteData

End Sub
'============================== 选择 SYSMAC WAY 时数据处理
Private Sub SysMacWayDispose()
Dim Tmpstr As String
Dim TmpSID As String
If CommandCode = "0102" Then
EntData:

    Tmpstr = InputBox(" 请写入" & Str(VScroll5.Value * 4) & "位数据！" & vbCr & " 数据格式为 0000～FFFF ！", "写入数据", String(VScroll5.Value * 4, "0"))
    If Tmpstr = "" Then Exit Sub
    If Len(Tmpstr) < VScroll5.Value * 4 Then GoTo EntData
    WriteData = Mid(UCase(Tmpstr), 1, VScroll5.Value * 4)
End If

'Host Fins Command
' @ XX          FA              X       80  00  02  XX  XX  00  00  00  00   XX     XXXX       XX...     ...XX     XX   * Chr(13)
'   Node Num    Header Code   Delay     ICF RSV GCT DNA DA1 DA2 SNA SA1 SA2 SID  COMMAND CODE  Text Max 540 Bytes  FCS

        
        
        
If SID > 256 Then SID = 0
SID = SID + 1
        If SID < 16 Then
            TmpSID = "0" & Hex(SID)
        Else
            TmpSID = Hex(SID)
        End If
        

ICF = "80": RSV = "00": GCT = "02": DA2 = "00": SNA = "00": SA1 = "00": SA2 = "FC"
Tmpstr = "@" & HostNode & "FA" & "0" & ICF & RSV & GCT & DNA & DA1 & DA2 & SNA & SA1 & SA2 & TmpSID & CommandCode & Memory & Bit & Address & Num & WriteData
Tmpstr = Tmpstr & FcsChk(Tmpstr)
EndStr = Tmpstr & "*"
End Sub

'******************* FCS *****************
Private Function FcsChk(Infor As String) As String
Dim InforLong As Long
Dim i As Long
Dim FCS As Long
Dim FcsText As String
Dim OneBit As String
InforLong = Len(Infor)
FCS = 0
For i = 1 To InforLong
    OneBit = Mid$(Infor, i, 1)
    FCS = FCS Xor (Asc(OneBit))
Next i
FcsText = Hex$(FCS)
If Len(FcsText) < 2 Then FcsText = String$((2 - Len(FcsText)), "0") & (FcsText)
FcsChk = FcsText
End Function

Private Sub FcsCnt()
Dim Tmpstr As String
EndStr = ""
Tmpstr = UCase(Text1.Text)
Tmpstr = Tmpstr & FcsChk(Tmpstr)
EndStr = Tmpstr
End Sub

Private Sub IPDispose()
Dim Tmpstr As String
Dim TmpIp As String
Dim StrLon As Long
Dim TmpVal As Long
Tmpstr = GetIPAddress
StrLon = Len(Tmpstr)
TmpVal = InStr(1, Tmpstr, ".") + 1
TmpIp = Mid(Tmpstr, 1, TmpVal - 2)
Tmpstr = Mid(Tmpstr, TmpVal, StrLon - TmpVal + 1)
Combo1(6).ListIndex = Val(TmpIp)
Combo1(10).ListIndex = Val(TmpIp)

StrLon = Len(Tmpstr)
TmpVal = InStr(1, Tmpstr, ".") + 1
TmpIp = Mid(Tmpstr, 1, TmpVal - 2)
Tmpstr = Mid(Tmpstr, TmpVal, StrLon - TmpVal + 1)
Combo1(7).ListIndex = Val(TmpIp)
Combo1(11).ListIndex = Val(TmpIp)
StrLon = Len(Tmpstr)
TmpVal = InStr(1, Tmpstr, ".") + 1
TmpIp = Mid(Tmpstr, 1, TmpVal - 2)
Tmpstr = Mid(Tmpstr, TmpVal, StrLon - TmpVal + 1)
Combo1(8).ListIndex = Val(TmpIp)
Combo1(12).ListIndex = Val(TmpIp)
Combo1(9).ListIndex = Val(Tmpstr)
Combo1(13).ListIndex = Val(Tmpstr)
SA1 = Hex(Combo1(9).ListIndex)
End Sub

Function StrToArr(Str As String)
Dim Tmpstr As String
Dim StrLon As Long
Dim Inx As Long
StrLon = Len(Str)
ReDim EtnFins((StrLon / 2) - 1)
For Inx = 0 To StrLon - 2 Step 2
    Tmpstr = Mid(Str, Inx + 1, 2)
    EtnFins(Inx / 2) = AsciiToHex(Tmpstr)
Next Inx
End Function

Function ArrToStr() As String
Dim Tmpstr As String
Dim TmpByt As Byte
Dim StrLon As Long
Dim Inx As Long
StrLon = UBound(RevInfo)
For Inx = 0 To StrLon
    TmpByt = RevInfo(Inx)
    Tmpstr = Hex(TmpByt)
    If Len(Tmpstr) = 1 Then Tmpstr = "0" & Tmpstr
    ArrToStr = ArrToStr & Tmpstr
Next Inx
End Function
'ASCII To Byte
Function AsciiToHex(Str As String) As Byte
Dim Inx As Long
Dim TmpByt As Byte
Dim Tmpstr As String
    If Len(Str) = 1 Then Str = "0" & Str
    
    For Inx = 0 To 255
        Tmpstr = Hex(Inx)
        If Len(Tmpstr) = 1 Then Tmpstr = "0" & Tmpstr
        If Str = Tmpstr Then
               TmpByt = Inx
               Inx = 256
        End If
        
    Next Inx
    
AsciiToHex = TmpByt

End Function

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim Tmplon As Long
Tmplon = Winsock1.BytesReceived
Winsock1.GetData RevInfo, vbByte, Tmplon
Text2.Text = ArrToStr
End Sub