Hallo Dr. OPC
danke für die Antwort. Nachdem ich dein Antwort gelesen habe, habe ich nachgeschaut ob die Itemname richtig ist. Der Name ist richtig, nur es sieht danach aus als ob ich über die DCOM Verbindung nicht die FMS Protokollierung abrufen kann. Ich habe den Simulations Programm auf dem Server laufen (FMS:[Demo]100), dort funktioniert es. Mit S7 geht die DCOM Verbindung. Muss den Client auf dem Server Rechner laufen lassen oder eine andere Protokolierung aufbauen. Hier der fertige VBA Code:
Option Explicit
Option Base 1
'deklaration eines private OPC-Objekts mit diesem Modul
Private MyOPCServer As OPCServer
Private WithEvents MyOPCGroup As OPCGroup
'deklaration der private OPC-Variablen
Private MyItemIDs() As String
Private MyServerHandles() As Long
Private MyNumItems As Long
Private Sub CheckBox1_Click()
If CheckBox1.Value Then
'Ermöglichen Ereigniss (OnDataChange)
MyOPCGroup.IsActive = True
MyOPCGroup.IsSubscribed = True
Else
'entferne alle Ereignisse aus der Gruppe Gruppe
MyOPCGroup.IsActive = False
MyOPCGroup.IsSubscribed = False
End If
End Sub
'Button connect (verbinden mit Server)
Private Sub CommandButton1_Click()
'SERVER ************************************************
On Error GoTo errorconnect
'Erstelle Server Objekt
Set MyOPCServer = New OPCServer
'connect server
Call MyOPCServer.Connect(Cells(7, 2), Cells(9, 2))
'GROUP ************************************************
On Error GoTo errorgroup
'set fastest update rate for all groups
MyOPCServer.OPCGroups.DefaultGroupUpdateRate = 200
'create group
Set MyOPCGroup = MyOPCServer.OPCGroups.Add(Cells(11, 2))
'disable all events of the group
MyOPCGroup.IsActive = False
MyOPCGroup.IsSubscribed = False
'ITEMS *************************************************
On Error GoTo erroritems
MyNumItems = 17
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(14 + i, 1)
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
CommandButton1.Enabled = True
CommandButton3.Enabled = True
CommandButton2.Enabled = True
CommandButton4.Enabled = True
CheckBox1.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
'read Item
Private Sub CommandButton2_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(14 + i, 2) = Values(i)
Cells(14 + i, 6) = Qualities(i)
Cells(14 + 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
'disconnect server (vom Server trennen)
Private Sub CommandButton3_Click()
On Error GoTo errorhandler
'remove the items
Dim Errors() As Long
Call MyOPCGroup.OPCItems.Remove(MyNumItems, MyServerHandles, Errors)
Erase Errors()
CheckBox1.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
CommandButton1.Enabled = True
CommandButton3.Enabled = False
CommandButton2.Enabled = False
CommandButton4.Enabled = False
CheckBox1.Enabled = False
Exit Sub
errorhandler:
Call MsgBox(Err.Description, vbCritical)
End Sub
Private Sub CommandButton4_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(14 + i, 3) <> "" Then
ReDim Preserve Values(NumWriteItems + 1)
ReDim Preserve HServer(NumWriteItems + 1)
HServer(NumWriteItems + 1) = MyServerHandles(i)
Values(NumWriteItems + 1) = Cells(14 + i, 3)
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 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
'Werte in die richtigen Zellen füllen
For i = 1 To NumItems
Cells(14 + ClientHandles(i), 4) = ItemValues(i)
Cells(14 + ClientHandles(i), 5) = TimeStamps(i)
Next
Tabelle1.Range("D15").Copy Tabelle3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 'B1\
Tabelle1.Range("D16").Copy Tabelle3.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) 'B2 \
Tabelle1.Range("D17").Copy Tabelle3.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) 'B3 Laufstreifen Code
Tabelle1.Range("D18").Copy Tabelle3.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) 'B4 /
Tabelle1.Range("D19").Copy Tabelle3.Range("E" & Rows.Count).End(xlUp).Offset(1, 0) 'B5/
Tabelle1.Range("D20").Copy Tabelle2.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) 'Gewicht Soll
Tabelle1.Range("D21").Copy Tabelle2.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) 'Gewicht Ist
Tabelle1.Range("D22").Copy Tabelle2.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) 'Gewicht OTG
Tabelle1.Range("D23").Copy Tabelle2.Range("E" & Rows.Count).End(xlUp).Offset(1, 0) 'Gewicht UTG
Tabelle1.Range("D24").Copy Tabelle2.Range("F" & Rows.Count).End(xlUp).Offset(1, 0) 'Länge Soll
Tabelle1.Range("D25").Copy Tabelle2.Range("G" & Rows.Count).End(xlUp).Offset(1, 0) 'Länge Ist
Tabelle1.Range("D26").Copy Tabelle2.Range("H" & Rows.Count).End(xlUp).Offset(1, 0) 'Länge OTG
Tabelle1.Range("D27").Copy Tabelle2.Range("I" & Rows.Count).End(xlUp).Offset(1, 0) 'Länge UTG
Tabelle1.Range("D28").Copy Tabelle2.Range("J" & Rows.Count).End(xlUp).Offset(1, 0) 'Cap
Tabelle1.Range("D29").Copy Tabelle2.Range("K" & Rows.Count).End(xlUp).Offset(1, 0) 'Base
Tabelle1.Range("D30").Copy Tabelle2.Range("L" & Rows.Count).End(xlUp).Offset(1, 0) 'Wing
Tabelle1.Range("D31").Copy Tabelle2.Range("M" & Rows.Count).End(xlUp).Offset(1, 0) 'Metall
Tabelle1.Range("E21").Copy Tabelle3.Range("Q" & Rows.Count).End(xlUp).Offset(1, 0) 'TimeStamp (Datum, Uhrzeit)
End Sub
bin jetzt so weit das beim öffnen des Excel-Client die Verbindung selbst zum Server aufbaut und die Daten die sich in der SPS ändern liest und untereinander in Tabelle 2 schreibt (Simulation). Nur ich habe jetzt das Problem mit dem speichern. Ich bekomme ungefähr 16000 Datensätze pro Tag. Diese Daten müssen gespeichert werden. Die Speicherung soll nur den geschehen wenn gerade nichts in die Tabelle 2 geschrieben wird. Es gibt so kleine varierende Zeitfenster wo nichts geschrieben wird, genau in dieser Zeit soll die Speicherung erfolgen. Nur wie mach ich das mit einem VBA code????. Alle 24 Std. soll dann die Datenmenge (06:00 - 06:00) extern in einem neuem Arbeitsmappe gespeichert werden und die Datensätze in Tabelle 2 gelöscht werden?!? Kannst du mir da weiter helfen. Hat zwar wenig mit SPS zu tun aber wer weiß
danke für deine Bemühungen.