日志
OMRON PLC 通过FINS协议 以太网通讯和串口通信示例程序VB源代码
||
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form finsform
BorderStyle = 1 'Fixed Single
Caption = "Form1"
ClientHeight = 6885
ClientLeft = 45
ClientTop = 330
ClientWidth = 7020
Icon = "Finsedit.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6885
ScaleWidth = 7020
StartUpPosition = 2 '屏幕中心
Begin MSCommLib.MSComm MSComm1
Left = 450
Top = 6900
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
RThreshold = 1
End
Begin VB.Frame Frame7
Caption = "通讯参数"
Height = 600
Left = 45
TabIndex = 49
Top = 4455
Width = 6975
Begin VB.CommandButton Command4
Caption = "Test"
Height = 350
Left = 5640
TabIndex = 56
Top = 195
Width = 1140
End
Begin VB.ComboBox Combo1
Height = 300
Index = 14
ItemData = "Finsedit.frx":030A
Left = 960
List = "Finsedit.frx":0326
Style = 2 'Dropdown List
TabIndex = 52
Top = 240
Width = 900
End
Begin VB.ComboBox Combo6
Height = 300
ItemData = "Finsedit.frx":0362
Left = 4560
List = "Finsedit.frx":038A
Style = 2 'Dropdown List
TabIndex = 51
Top = 210
Width = 900
End
Begin VB.ComboBox Combo5
Height = 300
ItemData = "Finsedit.frx":03E2
Left = 2880
List = "Finsedit.frx":03F5
Style = 2 'Dropdown List
TabIndex = 50
Top = 240
Width = 900
End
Begin VB.Label Label9
Caption = "格式："
Height = 255
Left = 3825
TabIndex = 55
Top = 225
Width = 735
End
Begin VB.Label Label8
Caption = "端口号："
Height = 255
Left = 120
TabIndex = 54
Top = 240
Width = 735
End
Begin VB.Label Label6
Caption = "波特率："
Height = 255
Index = 6
Left = 2040
TabIndex = 53
Top = 240
Width = 855
End
End
Begin VB.Frame Frame6
Caption = "接收 FINS 信息"
Height = 1710
Left = 45
TabIndex = 46
Top = 5115
Width = 6975
Begin VB.TextBox Text2
Height = 1380
Left = 60
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 48
Top = 240
Width = 6840
End
End
Begin VB.Frame Frame5
Caption = "目标 PLC IP 地址"
Height = 675
Left = 45
TabIndex = 39
Top = 3705
Width = 6975
Begin VB.CommandButton Command3
Caption = "Test"
Height = 350
Left = 5640
TabIndex = 47
Top = 210
Width = 1140
End
Begin VB.TextBox Text3
Height = 300
Left = 4560
TabIndex = 44
Text = "9600"
Top = 240
Width = 600
End
Begin VB.ComboBox Combo1
Height = 300
Index = 13
ItemData = "Finsedit.frx":041C
Left = 2715
List = "Finsedit.frx":041E
Style = 2 'Dropdown List
TabIndex = 43
Top = 240
Width = 800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 12
ItemData = "Finsedit.frx":0420
Left = 1890
List = "Finsedit.frx":0422
Style = 2 'Dropdown List
TabIndex = 42
Top = 240
Width = 800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 11
ItemData = "Finsedit.frx":0424
Left = 1050
List = "Finsedit.frx":0426
Style = 2 'Dropdown List
TabIndex = 41
Top = 240
Width = 800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 10
ItemData = "Finsedit.frx":0428
Left = 210
List = "Finsedit.frx":042A
Style = 2 'Dropdown List
TabIndex = 40
Top = 240
Width = 800
End
Begin VB.Label Label7
Caption = "端口："
Height = 225
Left = 3750
TabIndex = 45
Top = 270
Width = 735
End
End
Begin VB.CheckBox Check2
Caption = "发送到剪贴板"
Height = 180
Left = 120
TabIndex = 31
Top = 3360
Value = 1 'Checked
Width = 1935
End
Begin VB.CheckBox Check1
Caption = "生成 Visual basic 注释"
Height = 180
Left = 2160
TabIndex = 25
Top = 3360
Width = 2535
End
Begin VB.CommandButton Command1
Appearance = 0 'Flat
Caption = "&Enter"
Default = -1 'True
Height = 290
Left = 4800
TabIndex = 14
Top = 3345
Width = 700
End
Begin VB.CommandButton Command2
Caption = "E&xit"
Height = 290
Left = 6000
TabIndex = 13
Top = 3360
Width = 700
End
Begin VB.Frame Frame2
Caption = "FINS 信息"
Height = 1260
Left = 0
TabIndex = 11
Top = 1935
Width = 6975
Begin VB.Frame Frame3
Height = 580
Left = 120
TabIndex = 17
Top = 550
Width = 6735
Begin VB.ComboBox Combo4
Height = 300
ItemData = "Finsedit.frx":042C
Left = 6000
List = "Finsedit.frx":0460
Style = 2 'Dropdown List
TabIndex = 28
Top = 200
Width = 615
End
Begin VB.ComboBox Combo3
Height = 300
ItemData = "Finsedit.frx":049A
Left = 840
List = "Finsedit.frx":04C8
Style = 2 'Dropdown List
TabIndex = 26
Top = 180
Width = 975
End
Begin VB.VScrollBar VScroll4
Height = 270
Left = 3360
TabIndex = 23
Top = 200
Width = 255
End
Begin VB.TextBox Text5
Height = 270
Left = 2520
TabIndex = 22
Text = "Text5"
Top = 200
Width = 855
End
Begin VB.VScrollBar VScroll5
Height = 270
Left = 5160
TabIndex = 19
Top = 200
Width = 255
End
Begin VB.TextBox Text6
Height = 270
Left = 4320
TabIndex = 18
Text = "Text6"
Top = 200
Width = 855
End
Begin VB.Label Label2
Caption = "Bit："
Height = 255
Left = 5520
TabIndex = 27
Top = 250
Width = 375
End
Begin VB.Label Label4
Caption = "地址："
Height = 255
Left = 1920
TabIndex = 24
Top = 250
Width = 615
End
Begin VB.Label Label5
Caption = "数量："
Height = 255
Left = 3720
TabIndex = 21
Top = 250
Width = 735
End
Begin VB.Label Label3
Caption = "内存区："
Height = 255
Left = 120
TabIndex = 20
Top = 250
Width = 735
End
End
Begin VB.ComboBox Combo2
Height = 300
ItemData = "Finsedit.frx":0530
Left = 1080
List = "Finsedit.frx":053D
Style = 2 'Dropdown List
TabIndex = 15
Top = 240
Width = 1095
End
Begin VB.TextBox Text1
Height = 300
Left = 2280
TabIndex = 12
Top = 240
Width = 4575
End
Begin VB.Label Label1
Caption = "操作类型："
Height = 255
Left = 120
TabIndex = 16
Top = 260
Width = 975
End
End
Begin VB.Frame Frame1
Caption = "FINS网络参数"
Height = 1875
Left = 0
TabIndex = 0
Top = 0
Width = 6975
Begin VB.Frame Frame4
Caption = "源计算机 IP 地址"
Height = 680
Left = 120
TabIndex = 32
Top = 1080
Width = 6615
Begin VB.ComboBox Combo1
Height = 300
Index = 9
ItemData = "Finsedit.frx":055A
Left = 5640
List = "Finsedit.frx":055C
Style = 2 'Dropdown List
TabIndex = 38
Top = 240
Width = 800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 8
ItemData = "Finsedit.frx":055E
Left = 4680
List = "Finsedit.frx":0560
Style = 2 'Dropdown List
TabIndex = 37
Top = 240
Width = 800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 7
ItemData = "Finsedit.frx":0562
Left = 3720
List = "Finsedit.frx":0564
Style = 2 'Dropdown List
TabIndex = 36
Top = 240
Width = 800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 6
ItemData = "Finsedit.frx":0566
Left = 2760
List = "Finsedit.frx":0568
Style = 2 'Dropdown List
TabIndex = 35
Top = 240
Width = 800
End
Begin VB.OptionButton Option2
Caption = "其它地址"
Height = 180
Left = 1440
TabIndex = 34
Top = 300
Width = 1095
End
Begin VB.OptionButton Option1
Caption = "本机地址"
Height = 180
Left = 240
TabIndex = 33
Top = 300
Value = -1 'True
Width = 1095
End
End
Begin VB.ComboBox Combo1
Height = 300
Index = 5
ItemData = "Finsedit.frx":056A
Left = 5760
List = "Finsedit.frx":056C
Style = 2 'Dropdown List
TabIndex = 29
Top = 720
Width = 975
End
Begin VB.ComboBox Combo1
Height = 300
Index = 4
ItemData = "Finsedit.frx":056E
Left = 4320
List = "Finsedit.frx":0570
Style = 2 'Dropdown List
TabIndex = 9
Top = 720
Width = 800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 3
ItemData = "Finsedit.frx":0572
Left = 1080
List = "Finsedit.frx":057C
Style = 2 'Dropdown List
TabIndex = 7
Top = 720
Width = 1800
End
Begin VB.ComboBox Combo1
Height = 300
Index = 2
ItemData = "Finsedit.frx":0596
Left = 5760
List = "Finsedit.frx":0598
Style = 2 'Dropdown List
TabIndex = 5
Top = 240
Width = 975
End
Begin VB.ComboBox Combo1
Height = 300
Index = 1
ItemData = "Finsedit.frx":059A
Left = 3360
List = "Finsedit.frx":059C
Style = 2 'Dropdown List
TabIndex = 3
Top = 240
Width = 975
End
Begin VB.ComboBox Combo1
Height = 300
Index = 0
ItemData = "Finsedit.frx":059E
Left = 1080
List = "Finsedit.frx":05A0
Style = 2 'Dropdown List
TabIndex = 2
Top = 240
Width = 975
End
Begin VB.Label Label6
Caption = "SID："
Height = 255
Index = 5
Left = 5160
TabIndex = 30
Top = 780
Width = 495
End
Begin VB.Label Label6
Caption = "主链接单元号："
Height = 255
Index = 4
Left = 3000
TabIndex = 10
Top = 780
Width = 1335
End
Begin VB.Label Label6
Caption = "通讯界面："
Height = 255
Index = 3
Left = 120
TabIndex = 8
Top = 780
Width = 975
End
Begin VB.Label Label6
Caption = "目标节点号："
Height = 255
Index = 2
Left = 4560
TabIndex = 6
Top = 300
Width = 1215
End
Begin VB.Label Label6
Caption = "目标网络号："
Height = 255
Index = 1
Left = 2160
TabIndex = 4
Top = 300
Width = 1215
End
Begin VB.Label Label6
Caption = "源网络号："
Height = 255
Index = 0
Left = 120
TabIndex = 1
Top = 300
Width = 975
End
End
Begin MSWinsockLib.Winsock Winsock1
Left = 0
Top = 7000
_ExtentX = 741
_ExtentY = 741
_Version = 393216
Protocol = 1
RemoteHost = "192.168.1.74"
RemotePort = 9600
LocalPort = 9600
End
End
Attribute VB_Name = "finsform"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private ICF As String
Private RSV As String
Private GCT As String
Private DNA As String
Private DA1 As String
Private DA2 As String
Private SNA As String
Private SA1 As String
Private SA2 As String
Private SID As Byte
Private HostNode As String
Private HeaderCode As String
Private DelayTim As String
Private Memory As String
Private CommandCode As String
Private Address As String
Private Bit As String
Private Num As String
Private WriteData As String
Private EndStr As String
Dim EtnFins() As Byte
Dim RevInfo() As Byte
Dim RevInfoStr As String
Dim RevinfoCnt As Long
Private Function GetIPAddress() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
If Not SocketsInitialize() Then
GetIPAddress = ""
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPAddress = ""
MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
" has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
GetIPAddress = ""
MsgBox "Windows Sockets are not responding. " & _
"Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End Function
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function
Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
Private Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
MsgBox "Socket error occurred in Cleanup."
End If
End Sub
Private Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
MsgBox "The 32-bit Windows Socket is not responding."
SocketsInitialize = False
Exit Function
End If
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
MsgBox "This application requires a minimum of " & _
CStr(MIN_SOCKETS_REQD) & " supported sockets."
SocketsInitialize = False
Exit Function
End If
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte = CStr(HiByte(WSAD.wVersion))
sLoByte = CStr(LoByte(WSAD.wVersion))
MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
" is not supported by 32-bit Windows Sockets."
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function
'Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Sub Combo1_Click(Index As Integer)
Dim TmpInx As Long
TmpInx = Combo1(Index).ListIndex
Select Case Index
Case 0
If TmpInx < 16 Then
SNA = "0" & Hex(TmpInx)
Else
SNA = Hex(TmpInx)
End If
Case 1
If TmpInx < 16 Then
DNA = "0" & Hex(TmpInx)
Else
DNA = Hex(TmpInx)
End If
Case 2
If TmpInx < 16 Then
DA1 = "0" & Hex(TmpInx)
Else
DA1 = Hex(TmpInx)
End If
Case 3
If Combo1(3).ListIndex = 1 Then
Label6(0).Enabled = True
Combo1(0).Enabled = True
Label6(4).Enabled = False
Combo1(4).Enabled = False
Combo1(4).ListIndex = 0
Label6(5).Enabled = True
Combo1(5).Enabled = True
Option1.Enabled = True
Option2.Enabled = True
Frame4.Enabled = True
If Option1.Value = False Then
Combo1(6).Enabled = True
Combo1(7).Enabled = True
Combo1(8).Enabled = True
Combo1(9).Enabled = True
End If
Call IPDispose
ElseIf Combo1(3).ListIndex = 0 Then
Label6(0).Enabled = False
Combo1(0).Enabled = False
Combo1(0).ListIndex = 0
Label6(4).Enabled = True
Combo1(4).Enabled = True
Label6(5).Enabled = False
Combo1(5).Enabled = False
Combo1(5).ListIndex = 0
Option1.Enabled = False
Option2.Enabled = False
Frame4.Enabled = False
Combo1(6).Enabled = False
Combo1(7).Enabled = False
Combo1(8).Enabled = False
Combo1(9).Enabled = False
End If
Case 4
If TmpInx < 10 Then
HostNode = "0" & TmpInx
Else
HostNode = TmpInx
End If
Case 5
If TmpInx < 16 Then
SID = "0" & Hex(TmpInx)
Else
SID = Hex(TmpInx)
End If
Case 9
If TmpInx < 16 Then
SA1 = "0" & Hex(TmpInx)
Else
SA1 = Hex(TmpInx)
End If
End Select
End Sub
Private Sub Combo2_Click()
Dim Inx As Long
If Combo2.ListIndex = 0 Then
CommandCode = "0101"
WriteData = ""
ElseIf Combo2.ListIndex = 1 Then
CommandCode = "0102"
End If
If Combo2.ListIndex = 2 Then
Frame1.Enabled = False
For Inx = 0 To 4
Combo1(Inx).Enabled = False
Label6(Inx).Enabled = False
Next Inx
Frame3.Enabled = False
Label3.Enabled = False
Combo3.Enabled = False
Combo4.Enabled = False
Label2.Enabled = False
' VScroll3.Enabled = False
' Text4.Enabled = False
Label4.Enabled = False
VScroll4.Enabled = False
Text5.Enabled = False
Label5.Enabled = False
VScroll5.Enabled = False
Text6.Enabled = False
Text1.Locked = False
Check1.Enabled = False
Else
Frame1.Enabled = True
For Inx = 0 To 4
Combo1(Inx).Enabled = True
Label6(Inx).Enabled = True
Next Inx
Frame3.Enabled = True
Label3.Enabled = True
Combo3.Enabled = True
Combo4.Enabled = True
Label2.Enabled = True
' VScroll3.Enabled = True
' Text4.Enabled = True
Label4.Enabled = True
VScroll4.Enabled = True
Text5.Enabled = True
Label5.Enabled = True
VScroll5.Enabled = True
Text6.Enabled = True
If Combo2.ListIndex = 1 Then
Text1.Locked = False
Else
Text1.Locked = True
End If
Check1.Enabled = True
End If
End Sub
Private Sub Combo3_Click()
If Combo3.ListIndex = 0 Then
Label2.Enabled = True
Combo4.Enabled = True
Else
Label2.Enabled = False
Combo4.Enabled = False
Combo4.ListIndex = 0
Bit = ""
End If
Select Case Combo3.ListIndex
Case 0
' Text4.Text = "CIO Bit"
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 
