-> Hier kostenlos registrieren
Hallo erstmal,
ein Studienkollege und ich sitzen zur Zeit an unserer Studienarbeit. Haben nun ein Problem. Wir wollen mit Hilfe von Excel als Client Werte aus der SPS lesen und übertragen. Soweit so gut. Haben das ganze in VBA im entsprechenden Excel Programm erstellt. Anbei der Code:
Option Explicit
Option Base 1
' declaration of private OPC-objects within this modul
Private MyOPCServer As OPCServer
Private WithEvents MyOPCGroup As OPCGroup
' declaration of private OPC-variables
Private MyItemIDs() As String
Private MyServerHandles() As Long
Private MyNumItems As Long
'*****************************************************************
Public Sub cmdConnect_Click()
'** SERVER *************************************
On Error GoTo errorconnect
' create server object
Set MyOPCServer = New OPCServer
On Error GoTo errorgroup
' connect server
Call MyOPCServer.Connect(Cells(4, 2))
'** GROUP **************************************
On Error GoTo errorgroup
' set fastest update rate for all groups
MyOPCServer.OPCGroups.DefaultGroupUpdateRate = 0
' create group
'Set MyOPCGroup = MyOPCServer.OPCGroups.Add(Cells(7, 2))
Set MyOPCGroup = MyOPCServer.OPCGroups.Add("TEST")
' disable all events of the group
MyOPCGroup.IsActive = False
MyOPCGroup.IsSubscribed = False
'** ITEMS *************************************************
On Error GoTo erroritems
MyNumItems = 3
ReDim MyItemIDs(MyNumItems)
ReDim MyClientHandles(MyNumItems) As Long
Dim i As Long
Dim Errors() As Long
' get the ItemIDs
For i = 1 To MyNumItems
MyItemIDs(i) = Cells(9 + i, 2)
MyClientHandles(i) = i
Next
' add items to the group
Call MyOPCGroup.OPCItems.AddItems(MyNumItems, MyItemIDs, MyClientHandles, MyServerHandles, Errors)
For i = 1 To MyNumItems
If Errors(i) <> 0 Then
Call MsgBox(MyItemIDs(i) & Chr(13) & MyOPCServer.GetErrorString(Errors(i)), vbCritical)
End If
Next
'**********Settings**********
' setting the buttons
cmdConnect.Enabled = False
cmdDisconnect.Enabled = True
cmdSyncRead.Enabled = True
cmdSyncWrite.Enabled = True
chkActivate.Enabled = True
Exit Sub
errorconnect:
Call MsgBox("Error Connect:" & Chr(13) & Err.Description, vbCritical)
Exit Sub
errorgroup:
Call MsgBox("Error AddGroup:" & Chr(13) & Err.Description, vbCritical)
Exit Sub
erroritems:
Call MsgBox("Error AddItems:" & Chr(13) & Err.Description, vbCritical)
End Sub
'**********************************************************************
Public Sub cmdDisconnect_Click()
On Error GoTo errorhandler
' remove the items
Dim Errors() As Long
Call MyOPCGroup.OPCItems.Remove(MyNumItems, MyServerHandles, Errors)
Erase Errors()
chkActivate.Value = 0
' remove the group
Call MyOPCServer.OPCGroups.RemoveAll
' free the object
Set MyOPCGroup = Nothing
' disconnect from server
Call MyOPCServer.Disconnect
' free the object
Set MyOPCServer = Nothing
' setting the buttons
cmdConnect.Enabled = True
cmdDisconnect.Enabled = False
cmdSyncRead.Enabled = False
cmdSyncWrite.Enabled = False
chkActivate.Enabled = False
Exit Sub
errorhandler:
Call MsgBox(Err.Description, vbCritical)
End Sub
'*********************************************************
Private Sub cmdSyncRead_Click()
On Error GoTo errorhandler
Dim Values() As Variant
Dim Errors() As Long
Dim Qualities() As Integer
Dim TimeStamps() As Date
Dim i As Long
' read the values
Call MyOPCGroup.SyncRead(OPCDevice, MyNumItems, MyServerHandles, Values, Errors, Qualities, TimeStamps)
' fill values into the cells
For i = 1 To MyNumItems
If Errors(i) = 0 Then
Cells(9 + i, 3) = Values(i)
'Cells(9 + i, 4) = Qualities(i)
'Cells(9 + i, 5) = TimeStamps(i)
End If
Next
'free server allocated memory
Erase Values()
Erase Errors()
Erase Qualities()
Erase TimeStamps()
Exit Sub
errorhandler:
Call MsgBox(Err.Description, vbCritical)
End Sub
'*********************************************************
Public Sub cmdSyncWrite_Click()
On Error GoTo errorhandler
Dim Values() As Variant
Dim HServer() As Long
Dim NumWriteItems As Long
Dim Errors() As Long
Dim i As Long
NumWriteItems = 0
' fill values and serverhandles
For i = 1 To MyNumItems
' check for valid entry
If Cells(9 + i, 6) <> "" Then
ReDim Preserve Values(NumWriteItems + 1)
ReDim Preserve HServer(NumWriteItems + 1)
HServer(NumWriteItems + 1) = MyServerHandles(i)
Values(NumWriteItems + 1) = Cells(9 + i, 6)
NumWriteItems = NumWriteItems + 1
End If
Next
' write only where valid values found
Call MyOPCGroup.SyncWrite(NumWriteItems, HServer, Values, Errors)
'free server allocated memory
Erase Errors()
Exit Sub
errorhandler:
Call MsgBox(Err.Description, vbCritical)
End Sub
'*********************************************************
Private Sub chkActivate_Click()
If chkActivate.Value Then
' enable event (OnDataChange)
MyOPCGroup.IsActive = True
MyOPCGroup.IsSubscribed = True
Else
' disable all events of the group
MyOPCGroup.IsActive = False
MyOPCGroup.IsSubscribed = False
End If
End Sub
'*********************************************************
Private Sub MyOPCGroup_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)
Dim i As Integer
' fill the values in the correct cells
For i = 1 To NumItems
Cells(9 + ClientHandles(i), 7) = ItemValues(i)
Next
End Sub
nun bekommen wir immer die fehlermeldung: objekterstellung durch activex komponente nicht möglich bzw blockvariable oder with blockvariable nicht festgelegt.
haben schon versucht den computernamen für die verbindung direkt vorzugeben und sie variabel abrufen zu lassen. keine änderung.
stehen jetzt auf der leitung.....
wäre super wenn jemand ne idee hat an was es liegen könnte!
Betriebssystem ist windows 7, officeversion 2010. unter diesen beiden sollte das programm zum schluss auch laufen!
und bevor wirs vergessen, soll mit codesys v3.5 kompatibel sein
als kleines schmankerl
danke schonmal im voraus!!!!
viele grüße
sebastian
ein Studienkollege und ich sitzen zur Zeit an unserer Studienarbeit. Haben nun ein Problem. Wir wollen mit Hilfe von Excel als Client Werte aus der SPS lesen und übertragen. Soweit so gut. Haben das ganze in VBA im entsprechenden Excel Programm erstellt. Anbei der Code:
Option Explicit
Option Base 1
' declaration of private OPC-objects within this modul
Private MyOPCServer As OPCServer
Private WithEvents MyOPCGroup As OPCGroup
' declaration of private OPC-variables
Private MyItemIDs() As String
Private MyServerHandles() As Long
Private MyNumItems As Long
'*****************************************************************
Public Sub cmdConnect_Click()
'** SERVER *************************************
On Error GoTo errorconnect
' create server object
Set MyOPCServer = New OPCServer
On Error GoTo errorgroup
' connect server
Call MyOPCServer.Connect(Cells(4, 2))
'** GROUP **************************************
On Error GoTo errorgroup
' set fastest update rate for all groups
MyOPCServer.OPCGroups.DefaultGroupUpdateRate = 0
' create group
'Set MyOPCGroup = MyOPCServer.OPCGroups.Add(Cells(7, 2))
Set MyOPCGroup = MyOPCServer.OPCGroups.Add("TEST")
' disable all events of the group
MyOPCGroup.IsActive = False
MyOPCGroup.IsSubscribed = False
'** ITEMS *************************************************
On Error GoTo erroritems
MyNumItems = 3
ReDim MyItemIDs(MyNumItems)
ReDim MyClientHandles(MyNumItems) As Long
Dim i As Long
Dim Errors() As Long
' get the ItemIDs
For i = 1 To MyNumItems
MyItemIDs(i) = Cells(9 + i, 2)
MyClientHandles(i) = i
Next
' add items to the group
Call MyOPCGroup.OPCItems.AddItems(MyNumItems, MyItemIDs, MyClientHandles, MyServerHandles, Errors)
For i = 1 To MyNumItems
If Errors(i) <> 0 Then
Call MsgBox(MyItemIDs(i) & Chr(13) & MyOPCServer.GetErrorString(Errors(i)), vbCritical)
End If
Next
'**********Settings**********
' setting the buttons
cmdConnect.Enabled = False
cmdDisconnect.Enabled = True
cmdSyncRead.Enabled = True
cmdSyncWrite.Enabled = True
chkActivate.Enabled = True
Exit Sub
errorconnect:
Call MsgBox("Error Connect:" & Chr(13) & Err.Description, vbCritical)
Exit Sub
errorgroup:
Call MsgBox("Error AddGroup:" & Chr(13) & Err.Description, vbCritical)
Exit Sub
erroritems:
Call MsgBox("Error AddItems:" & Chr(13) & Err.Description, vbCritical)
End Sub
'**********************************************************************
Public Sub cmdDisconnect_Click()
On Error GoTo errorhandler
' remove the items
Dim Errors() As Long
Call MyOPCGroup.OPCItems.Remove(MyNumItems, MyServerHandles, Errors)
Erase Errors()
chkActivate.Value = 0
' remove the group
Call MyOPCServer.OPCGroups.RemoveAll
' free the object
Set MyOPCGroup = Nothing
' disconnect from server
Call MyOPCServer.Disconnect
' free the object
Set MyOPCServer = Nothing
' setting the buttons
cmdConnect.Enabled = True
cmdDisconnect.Enabled = False
cmdSyncRead.Enabled = False
cmdSyncWrite.Enabled = False
chkActivate.Enabled = False
Exit Sub
errorhandler:
Call MsgBox(Err.Description, vbCritical)
End Sub
'*********************************************************
Private Sub cmdSyncRead_Click()
On Error GoTo errorhandler
Dim Values() As Variant
Dim Errors() As Long
Dim Qualities() As Integer
Dim TimeStamps() As Date
Dim i As Long
' read the values
Call MyOPCGroup.SyncRead(OPCDevice, MyNumItems, MyServerHandles, Values, Errors, Qualities, TimeStamps)
' fill values into the cells
For i = 1 To MyNumItems
If Errors(i) = 0 Then
Cells(9 + i, 3) = Values(i)
'Cells(9 + i, 4) = Qualities(i)
'Cells(9 + i, 5) = TimeStamps(i)
End If
Next
'free server allocated memory
Erase Values()
Erase Errors()
Erase Qualities()
Erase TimeStamps()
Exit Sub
errorhandler:
Call MsgBox(Err.Description, vbCritical)
End Sub
'*********************************************************
Public Sub cmdSyncWrite_Click()
On Error GoTo errorhandler
Dim Values() As Variant
Dim HServer() As Long
Dim NumWriteItems As Long
Dim Errors() As Long
Dim i As Long
NumWriteItems = 0
' fill values and serverhandles
For i = 1 To MyNumItems
' check for valid entry
If Cells(9 + i, 6) <> "" Then
ReDim Preserve Values(NumWriteItems + 1)
ReDim Preserve HServer(NumWriteItems + 1)
HServer(NumWriteItems + 1) = MyServerHandles(i)
Values(NumWriteItems + 1) = Cells(9 + i, 6)
NumWriteItems = NumWriteItems + 1
End If
Next
' write only where valid values found
Call MyOPCGroup.SyncWrite(NumWriteItems, HServer, Values, Errors)
'free server allocated memory
Erase Errors()
Exit Sub
errorhandler:
Call MsgBox(Err.Description, vbCritical)
End Sub
'*********************************************************
Private Sub chkActivate_Click()
If chkActivate.Value Then
' enable event (OnDataChange)
MyOPCGroup.IsActive = True
MyOPCGroup.IsSubscribed = True
Else
' disable all events of the group
MyOPCGroup.IsActive = False
MyOPCGroup.IsSubscribed = False
End If
End Sub
'*********************************************************
Private Sub MyOPCGroup_DataChange(ByVal TransactionID As Long, ByVal NumItems As Long, ClientHandles() As Long, ItemValues() As Variant, Qualities() As Long, TimeStamps() As Date)
Dim i As Integer
' fill the values in the correct cells
For i = 1 To NumItems
Cells(9 + ClientHandles(i), 7) = ItemValues(i)
Next
End Sub
nun bekommen wir immer die fehlermeldung: objekterstellung durch activex komponente nicht möglich bzw blockvariable oder with blockvariable nicht festgelegt.
haben schon versucht den computernamen für die verbindung direkt vorzugeben und sie variabel abrufen zu lassen. keine änderung.
stehen jetzt auf der leitung.....
wäre super wenn jemand ne idee hat an was es liegen könnte!
Betriebssystem ist windows 7, officeversion 2010. unter diesen beiden sollte das programm zum schluss auch laufen!
und bevor wirs vergessen, soll mit codesys v3.5 kompatibel sein
als kleines schmankerldanke schonmal im voraus!!!!
viele grüße
sebastian
Zuletzt bearbeitet:
