『共享』VB 读写WinCC OPC变量源程序

自己试验过，可以的，代码如下：(复制代码保存为.frm文件就可以用VB打开了)
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3735
ClientLeft = 60
ClientTop = 345
ClientWidth = 6345
LinkTopic = "Form1"
ScaleHeight = 3735
ScaleWidth = 6345
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text5
Height = 375
Left = 2640
TabIndex = 13
Text = "Text5"
Top = 1560
Width = 3495
End
Begin VB.TextBox Text4
Height = 375
Left = 1560
TabIndex = 12
Text = "Text4"
Top = 1560
Width = 975
End
Begin VB.TextBox Text3
Height = 375
Left = 4200
TabIndex = 11
Text = "Text3"
Top = 960
Width = 1935
End
Begin VB.TextBox Text2
Height = 375
Left = 2640
TabIndex = 10
Text = "Text2"
Top = 960
Width = 1455
End
Begin VB.TextBox Text1
Height = 375
Left = 1560
TabIndex = 9
Text = "Text1"
Top = 960
Width = 975
End
Begin VB.Frame Frame1
Caption = "自动更新"
Height = 1455
Left = 120
TabIndex = 7
Top = 2160
Width = 6135
Begin VB.TextBox Text8
Height = 375
Index = 0
Left = 4080
TabIndex = 16
Text = "Text8"
Top = 840
Width = 1935
End
Begin VB.TextBox Text7
Height = 375
Index = 0
Left = 2520
TabIndex = 15
Text = "Text7"
Top = 840
Width = 1455
End
Begin VB.TextBox Text6
Height = 375
Index = 0
Left = 1440
TabIndex = 14
Text = "Text6"
Top = 840
Width = 975
End
Begin VB.CheckBox chkGroupActive
Caption = "自动"
Enabled = 0 'False
Height = 255
Left = 120
TabIndex = 8
Top = 360
Width = 975
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "值"
ForeColor = &H80000008&
Height = 255
Index = 5
Left = 1560
TabIndex = 19
Top = 480
Width = 375
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "品质/写结果"
ForeColor = &H80000008&
Height = 255
Index = 4
Left = 2400
TabIndex = 18
Top = 480
Width = 1095
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "时间戳"
ForeColor = &H80000008&
Height = 255
Index = 3
Left = 3960
TabIndex = 17
Top = 480
Width = 1095
End
End
Begin VB.CommandButton Command_Exit
Caption = "关闭连接"
Enabled = 0 'False
Height = 375
Left = 1320
TabIndex = 6
Top = 120
Width = 1095
End
Begin VB.CommandButton Command_Write
Caption = "写"
Enabled = 0 'False
Height = 375
Left = 120
TabIndex = 2
Top = 1560
Width = 1095
End
Begin VB.CommandButton Command_Read
Caption = "读"
Enabled = 0 'False
Height = 375
Left = 120
TabIndex = 1
Top = 960
Width = 1095
End
Begin VB.CommandButton Command_Start
Caption = "连接"
Height = 375
Left = 120
TabIndex = 0
Top = 120
Width = 1095
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "时间戳"
ForeColor = &H80000008&
Height = 255
Index = 2
Left = 4080
TabIndex = 5
Top = 600
Width = 1095
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "品质/写结果"
ForeColor = &H80000008&
Height = 255
Index = 1
Left = 2520
TabIndex = 4
Top = 600
Width = 1095
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "值"
ForeColor = &H80000008&
Height = 255
Index = 0
Left = 1680
TabIndex = 3
Top = 600
Width = 375
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1

Const WRITEASYNC_ID = 1
Const READASYNC_ID = 2
Const REFRESHASYNC_ID = 3
Public WithEvents ServerObj As OPCServer
Attribute ServerObj.VB_VarHelpID = -1
Public WithEvents GroupObj As OPCGroup
Attribute GroupObj.VB_VarHelpID = -1
Dim ItemObj1 As OPCItem
'Dim ItemObj2 As OPCItem
'Dim Serverhandle(2) As Long
Dim Serverhandle(1) As Long

Private Sub chkGroupActive_Click()
If chkGroupActive = 1 Then
GroupObj.IsActive = 1
Else
GroupObj.IsActive = 0
End If
End Sub
Private Sub Command_Start_Click()
Dim OutText As String

On Error GoTo ErrorHandler

Command_Start.Enabled = False
Command_Read.Enabled = True
Command_Write.Enabled = True
Command_Exit.Enabled = True
chkGroupActive.Enabled = True

OutText = "连接OPC服务器"
Set ServerObj = New OPCServer
ServerObj.Connect ("OPCServer.WinCC")

OutText = "添加组"
Set GroupObj = ServerObj.OPCGroups.Add("Root")


GroupObj.IsSubscribed = True

chkGroupActive_Click

OutText = "添加ITEM"
Set ItemObj1 = GroupObj.OPCItems.AddItem("OPCtest", 1) '在WinCC里建立一个实数变量OPCTest
'Set ItemObj2 = GroupObj.OPCItems.AddItem("Date", 1)

Serverhandle(1) = ItemObj1.Serverhandle
'Serverhandle(2) = ItemObj2.Serverhandle
Exit Sub

ErrorHandler:
MsgBox Err.Des cription + Chr(13) + _
OutText, vbCritical, "ERROR"

End Sub
Private Sub Command_Read_Click() '异步读
Dim OutText As String
Dim myValue As Variant
Dim myQuality As Variant
Dim myTimeStamp As Variant
Dim ClientID As Long
Dim ServerID As Long
Dim ErrorNr() As Long
Dim ErrorString As String

On Error GoTo ErrorHandler
OutText = "读值"
ClientID = READASYNC_ID

GroupObj.AsyncRead 1, Serverhandle, ErrorNr, ClientID, ServerID
If ErrorNr(1) <> 0 Then
ErrorString = ServerObj.GetErrorString(ErrorNr(1))
MsgBox ErrorString, vbCritical, "Error AsyncRead()"
End If

Erase ErrorNr
Exit Sub

ErrorHandler:
MsgBox Err.Des cription + Chr(13) + _
OutText, vbCritical, "ERROR"

End Sub
Private Sub Command_Write_Click() '异步写

Dim OutText As String
Dim Serverhandles(1) As Long
Dim MyValues(1) As Variant
Dim ErrorNr() As Long
Dim ErrorString As String
Dim Cancel_id As Long

OutText = "Writing Value"
On Error GoTo ErrorHandler


MyValues(1) = Val(Text4.Text)
'MyValues(1) = Text4.Text

GroupObj.AsyncWrite 1, Serverhandle, MyValues, ErrorNr, WRITEASYNC_ID, Cancel_id

If ErrorNr(1) <> 0 Then
ErrorString = ServerObj.GetErrorString(ErrorNr(1))
MsgBox ErrorString, vbCritical, "Error AsyncRead()"
End If

Erase ErrorNr
Exit Sub

ErrorHandler:
MsgBox Err.Des cription + Chr(13) + _
OutText, vbCritical, "ERROR"
End Sub

Private Sub Command_Exit_Click() '停止
Dim OutText As String

On Error GoTo ErrorHandler
Command_Start.Enabled = True
Command_Read.Enabled = False
Command_Write.Enabled = False
Command_Exit.Enabled = False
chkGroupActive.Enabled = False

OutText = "Removing Objects"
Set ItemObj1 = Nothing
'Set ItemObj2 = Nothing
ServerObj.OPCGroups.RemoveAll
Set GroupObj = Nothing
ServerObj.Disconnect
Set ServerObj = Nothing

Exit Sub

ErrorHandler:
MsgBox Err.Des cription + Chr(13) + _
OutText, vbCritical, "ERROR"

End Sub


Private Sub Form_Load()
Text4.Text = 25.9
End Sub

'异步读回调
Private Sub GroupObj_AsyncReadComplete(ByVal TransactionID As Long, _
ByVal NumItems As Long, ClientHandles() As Long, _
ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date, Errors() As Long)

Dim ErrorString As String

If (TransactionID = READASYNC_ID) Then
If Errors(1) = 0 Then
Text1.Text = ItemValues(1)
Text2.Text = GetQualityText(Qualities(1))
Text3.Text = TimeStamps(1)
Else
ErrorString = ServerObj.GetErrorString(Errors(1))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
End If
End Sub
'异步写回调
Private Sub GroupObj_AsyncWriteComplete(ByVal TransactionID As Long, _
ByVal NumItems As Long, ClientHandles() As Long, _
Errors() As Long)
Dim ErrorString As String
Dim Edit_WriteRes As Variant

If (TransactionID = WRITEASYNC_ID) Then
If Errors(1) = 0 Then
Edit_WriteRes = ServerObj.GetErrorString(Errors(1))
Text5.Text = Edit_WriteRes
Else
ErrorString = ServerObj.GetErrorString(Errors(1))
MsgBox ErrorString, vbCritical, "Error AsyncWriteComplete()"
End If
End If
End Sub
'回调
Private Sub GroupObj_DataChange(ByVal TransactionID As Long, _
ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, _
Qualities() As Long, TimeStamps() As Date)
Dim i As Long
'For i = 1 To NumItems
'Edit_OnDataVal(i - 1) = ItemValues(i)
'Edit_OnDataQu(i - 1) = GetQualityText(Qualities(i))
'Edit_OnDataTS(i - 1) = TimeStamps(i)
Text6(0).Text = ItemValues(1)
Text7(0).Text = GetQualityText(Qualities(1))
Text8(0).Text = TimeStamps(1)
'Debug.Print TransactionID, NumItems, ClientHandles(1), ItemValues(1), Qualities(1), TimeStamps(1)
'Next i
End Sub

Private Function GetQualityText(Quality) As String
Select Case Quality
Case 0: GetQualityText = "BAD"
Case 64: GetQualityText = "UNCERTAIN"
Case 192: GetQualityText = "GOOD"
Case 8: GetQualityText = "NOT_CONNECTED"
Case 13: GetQualityText = "DEVICE_FAILURE"
Case 16: GetQualityText = "SENSOR_FAILURE"
Case 20: GetQualityText = "LAST_KNOWN"
Case 24: GetQualityText = "COMM_FAILURE"
Case 28: GetQualityText = "OUT_OF_SERVICE"
Case 132: GetQualityText = "LAST_USABLE"
Case 144: GetQualityText = "SENSOR_CAL"
Case 148: GetQualityText = "EGU_EXCEEDED"
Case 152: GetQualityText = "SUB_NORMAL"
Case 216: GetQualityText = "LOCAL_OVERRIDE"

Case Else: GetQualityText = "UNKNOWN ERROR"
End Select
End Function

不知道干什么用的！

对应的OPC怎么设置呢?

太不清晰了,我收集过这样的文章,贴出来:)

一、OPC的连接

先在“引用”将近 Siemens OPC DAAutomation 2.0加入，然后开始定义全局变量。在本程序中，我使用了两个OPC组进行OPC访问，所以定义了全局变量。我们要首先定义OPC服务类型与计算机结点名。定义OPC组与OPC标签组。并定义OPC的标签数组与值数，注意，值数组一定要设为Variant。

'OPC处理：只对WINCC

Const ServerName = "OPCServer.WinCC" ‘OPC的类型

Const NodeName = "GUK" ‘结点名，即计算机名

‘Dim NodeName As String

Dim WithEvents MyOPCServer As OPCServer ‘OPC服务

Dim MyOPCGroupColl As OPCGroups ‘

Dim WithEvents MyOPCGroupOut As OPCGroup ‘OPC组，本程序用两个组进行OPC连接

Dim WithEvents MyOPCGroupIn As OPCGroup

Dim MyOPCItemCollIn As OPCItems ‘OPC标签组

Dim MyOPCItemCollOut As OPCItems

Dim ServerHandlesIn() As Long ‘句柄

Dim ServerHandlesOut() As Long

Dim ErrorsIn() As Long ‘错误句柄

Dim ErrorsOut() As Long

Dim WatchDataReadItem(100) As String '记录OPC的标签

Dim WatchDataReadValue(100) As Variant '存放OPC的值

Dim WatchDataWriteItem(100) As String '记录OPC的标签

Dim WatchDataWriteValue(100) As Variant '存放OPC的值

在定义所有变量后，我们就要进行OPC连接了，要进行OPC连接之前,先要配置要访问的OPC标签名，我们WatchDataReadItem、WatchDataWriteItem中加入相应的标签名，注意：这两个数组必须由1开始，不能由0开始。

配置好标签后就要进行OPC连接了。如下面子程序：

1、 ClientHandles1先配置名柄索引，这将在读取OPC标签的值时可要用到

2、 生成OPC对象，

3、 进行OPC标签连接

至此：OPC连接就成功了，我们可以对OPC进行读与写的操作了。

'---------------------------------------------------------------------

' Sub StartClient()

' 目的：连接至OPC_server，创建组和添加条目

'---------------------------------------------------------------------

Private Sub StartClient()

Dim ItemNum As Integer

Dim TarnscationID As Long

Dim CanceID As Long

Dim ClientHandles1(100) As Long

Dim ii As Integer



On Error GoTo HANDLEeRROR

For ii = 0 To 100

ClientHandles1(ii) = ii 先配置名柄索引，这将在读取OPC标签的值时可要用到

Next ii


TarnscationID = 1

‘ NodeName = xProfile.GetValue("SYSTEM", "NodeName")

‘生成OPC对象，

Set MyOPCServer = New OPCServer

MyOPCServer.Connect ServerName, NodeName

Set MyOPCGroupColl = MyOPCServer.OPCGroups

MyOPCGroupColl.DefaultGroupIsActive = True

Set MyOPCGroupIn = MyOPCGroupColl.Add("MYGROUPIN")

Set MyOPCGroupOut = MyOPCGroupColl.Add("MYGROUPOUT")

Set MyOPCItemCollIn = MyOPCGroupIn.OPCItems

Set MyOPCItemCollOut = MyOPCGroupOut.OPCItems

‘进行OPC标签连接

If WriteItemIdex > 0 Then

MyOPCItemCollOut.AddItems WriteItemIdex, WatchDataWriteItem, ClientHandles1, ServerHandlesOut, ErrorsOut '初始化OCP连接

MyOPCGroupOut.IsSubscribed = True

End If

If ReadItemIdex > 0 Then

MyOPCItemCollIn.AddItems ReadItemIdex, WatchDataReadItem, ClientHandles1, ServerHandlesIn, ErrorsIn '初始化OCP连接

MyOPCGroupIn.IsSubscribed = True

End If

Exit Sub

HANDLEeRROR:

needOPCRestart = True

xLog1.log "OPCl连接发生错误"

End Sub

二、OPC的标签读写

对OPC标签的读可以通过MyOPCGroupIn组与MyOPCGroupOut的DataChange事件来读取。该事件有多个参数：其中NumItems是指标签改变值的个数，ClientHandles是改变值的标签索引，ItemValues为改变值的数据，具体的意思是ClientHandles（1）的值是其对应的标签数组的索引，其所指的OPC标签的值在ItemValues(1)中。一般来说，刚连接上时，该事件会把全部所要求访问的OPC标签值全部读取过来（顺序不一，要通过ClientHandles索引），此后只有数据发生变化时才会触发该事件。也只会传输发生了变化的数据，没有变化的数据不会出现在本事件的ItemValues中。

Private Sub MyOPCGroupOut_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)

'产生要通知下一级的数据变化，根椐不再的控件有不同的处理

For ii = 1 To NumItems

WatchDataWriteValue(ClientHandles(ii) - 1) = ItemValues(ii) '对改变的值读入本数组

Next ii

End Sub

对OPC的写可以有同步与异步之分，对于大量的数据传输，异步是更佳的选择，但对少量的数据传输，同步表现得更好。

要进行数据传输，先要将值数据进行赋值，注意：值数据要由0开始，也就是说，值数组与标签数据不是一、一对应，值要比标签前一位，这一点，在WINCC说明中没有，但在我的实际的使用中一直要这样，不然数据就产生错位，看下面程序。

这是一个拔号完毕后返回的数据进行OPC传递的程序。包含解包过程，

Private Sub showSuccess(msg As String)

Dim location As String

Dim nowTime As String

Dim logStr As String

Dim Value() As String

Dim ii, temp As Integer

Dim isPack As Boolean

Dim sHead, sDelimited, sTail As String

location = xProfile.GetValue(WatchPoint(nowRunID), "LOCATION")

nowTime = Now

logStr = "拔" & location & "取数成功" & msg

xLog1.log logStr

logStr = " " & msg

xLog2.log logStr '记录数据

'数据上传

'如果有包结构,则显示包结构,

isPack = xProfile.GetValue(WatchPoint(nowRunID), "ISRECHEAD")

If WatchPointRBegin(nowRunID) < 0 Then Exit Sub

If isPack Then

sHead = xProfile.GetValue(WatchPoint(nowRunID), "RECHEAD")

sDelimited = xProfile.GetValue(WatchPoint(nowRunID), "RECDELIMITER")

sTail = xProfile.GetValue(WatchPoint(nowRunID), "RECEND")

Value = Split(msg, sDelimited)

For ii = 0 To UBound(Value) - 1

temp = WatchPointRBegin(nowRunID) + ii

If temp > WatchPointREnd(nowRunID) Then Exit For

WatchDataReadValue(temp - 1) = Value(ii + 1) 'VALUE要从0开始，比ITEM少1,所以减一。 有包头,占去一位,向后延一

Next ii

Else

WatchDataReadValue(WatchPointREnd(nowRunID) - 1) = msg

End If

MyOPCGroupIn.SyncWrite ReadItemIdex, ServerHandlesIn, WatchDataReadValue, ErrorsIn '数据上传

'记录上次成功执行的时间

xProfile.SetValue WatchPoint(nowRunID), "LASTTIME", nowTime

End Sub

三、OPC连接断开。

OPC客户端连接后要占用服务器资源，所以如果不需要使用OPC时，必须进行OPC连接断开。

断开的程序相当简单，释放资源即可。如下，

Sub StopClient()

On Error Resume Next

'----------- 释放组和服务器对象
MyOPCGroupColl.RemoveAll
'----------- 与服务器断开连接并且清除

MyOPCServer.Disconnect
Set MyOPCItemCollIn = Nothing
Set MyOPCItemCollOut = Nothing
Set MyOPCGroupIn = Nothing
Set MyOPCGroupOut = Nothing
Set MyOPCGroupColl = Nothing
Set MyOPCServer = Nothing

End Sub

但在实际的使用中发现，频繁的连接与断开，将使服务器的资源被大量的消耗，最终让服务器出错。所以尽量减少无谓的OPC连接与断开。

结语：
OPC的使用是作为一个DCOM在使用，所以OPC客户端可以网络上任一计算机运行，但你必须配置DCOM的访问权限，如果你不想费神，把服务器与客户端都用相同的用户名与密码登录就成了。如果想配置DCOM，请参看DCOM的配置。

标记学习。
最好是流程，而不是一堆看得懂而不好看的代码

事实再次证明，
当你说道理的时候有人直接喜欢代码。
当你贴代码的时候有人喜欢讲道理。

呵呵，有同感！