Programa de VB a VFOX con activeX
Publicado por xqr (1 intervención) el 02/04/2013 08:50:27
Hola buenos dias,
Recurro a vosotros para ver si me podeis ayudar. Tengo un código funcionando en VBasic 6 y tengo que pasarlo a Visual Fox.
Se trata de un ActiveX en un formulario que lo que hace es leer y escribir contra un PLC.
Os dejo el código a ver que se puede hacer... muchisimas gracias de antemano,
Recurro a vosotros para ver si me podeis ayudar. Tengo un código funcionando en VBasic 6 y tengo que pasarlo a Visual Fox.
Se trata de un ActiveX en un formulario que lo que hace es leer y escribir contra un PLC.
Os dejo el código a ver que se puede hacer... muchisimas gracias de antemano,
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
'----------------------------------------------------------------------------
' OPC Automation 2.0 Sample
' Asynchronous IO
' (c) Siemens AG 2000
'
'----------------------------------------------------------------------------
Option Explicit
Option Base 1 '** Arrays in OPC always start at index 1
'(see SPEC Chapter 2.6)
Const WRITEASYNC_ID = 1Const READASYNC_ID = 2Const REFRESHASYNC_ID = 3'----------------------------------------------------------------------------
' Interface Objects
'----------------------------------------------------------------------------
Public WithEvents ServerObj As OPCServer
Public WithEvents GroupObj As OPCGroup
'Dim ItemObj0 As OPCItem
Dim ItemObj1 As OPCItem
Dim ItemObj2 As OPCItem
Dim ItemObj3 As OPCItem
Dim ItemObj4 As OPCItem
Dim ItemObj5 As OPCItem
Dim ItemObj6 As OPCItem
Dim ItemObj7 As OPCItem
Dim ItemObj8 As OPCItem
Dim Serverhandle(8) As Long
Private Sub chkGroupActive_Click()
If chkGroupActive = 1 ThenGroupObj.IsActive = True
Else
GroupObj.IsActive = False
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 = "Connecting to OPC-Server"
Set ServerObj = New OPCServerServerObj.Connect ("OPC.SimaticNET")
OutText = "Adding a Group to OPC-Server"
Set GroupObj = ServerObj.OPCGroups.Add("MyOPCGroup")
' Important for Activating Callbacks
GroupObj.IsSubscribed = True
'Set active State like CheckBox State
chkGroupActive_Click
OutText = "Adding Items to the group"
Set ItemObj1 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X0.0", 1)
Set ItemObj2 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X0.1", 2)
Set ItemObj3 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X0.2", 3)
Set ItemObj4 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X0.7", 4)
Set ItemObj5 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X1.0", 5)
Set ItemObj6 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X1.1", 6)
Set ItemObj7 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X1.2", 7)
Set ItemObj8 = GroupObj.OPCItems.AddItem("S7:[plast7]DB320,X1.7", 8)
Serverhandle(1) = ItemObj1.Serverhandle
Serverhandle(2) = ItemObj2.Serverhandle
Serverhandle(3) = ItemObj3.Serverhandle
Serverhandle(4) = ItemObj4.Serverhandle
Serverhandle(5) = ItemObj5.Serverhandle
Serverhandle(6) = ItemObj6.Serverhandle
Serverhandle(7) = ItemObj7.Serverhandle
Serverhandle(8) = ItemObj8.Serverhandle
Exit Sub
ErrorHandler:MsgBox Err.Description + 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 = "Reading Value of Item"
ClientID = READASYNC_IDGroupObj.AsyncRead 8, 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.Description + Chr(13) + _
OutText, vbCritical, "ERROR"
End Sub
Private Sub Command_Write_Click()
Dim OutText As String
Dim Serverhandles(1) As Long
Dim MyValues(5) As Variant
Dim ErrorNr() As Long
Dim ErrorString As String
Dim Cancel_id As Long
OutText = "Writing Value"
On Error GoTo ErrorHandler
' Use Multiple Call to get Write Results
' Ueberfluessig, weil bereits in Command_Start_Click() initialisiert !!
'Serverhandles(1) = ItemObj1.Serverhandle
MyValues(1) = Edit_WriteVal(0)
MyValues(2) = Edit_WriteVal(1)
MyValues(3) = Edit_WriteVal(2)
MyValues(4) = Edit_WriteVal(3)
MyValues(5) = Edit_WriteVal(4)
GroupObj.AsyncWrite 5, 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.Description + 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 = NothingServerObj.OPCGroups.RemoveAll
Set GroupObj = Nothing ServerObj.Disconnect Set ServerObj = NothingExit Sub
ErrorHandler:MsgBox Err.Description + Chr(13) + _
OutText, vbCritical, "ERROR"
End Sub
Private Sub Form_Load()
'----------------------------------------------------------------------------
' Sub GroupObj_AsyncReadComplete
' Purpose: Event for the completion of the read process
'----------------------------------------------------------------------------
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(0) = 0 Then
' Edit_ReadVal(0) = ItemValues(0)
' Edit_ReadQu(0) = GetQualityText(Qualities(0))
' Edit_ReadTS(0) = TimeStamps(0)
' Else
' ErrorString = ServerObj.GetErrorString(Errors(0))
' MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
' End If
If Errors(1) = 0 Then
Edit_ReadVal(1) = ItemValues(1)
Edit_ReadQu(1) = GetQualityText(Qualities(1))
Edit_ReadTS(1) = TimeStamps(1)
' Si entra tablero cambiamos el color a VERDE
If Edit_ReadVal(1) = True Then
Edit_ReadVal(1).BackColor = vbGreen
S1.BackColor = vbGreen
Else
Edit_ReadVal(1).BackColor = vbWhite
S1.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(1))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
If Errors(2) = 0 Then
Edit_ReadVal(2) = ItemValues(2)
Edit_ReadQu(2) = GetQualityText(Qualities(2))
Edit_ReadTS(2) = TimeStamps(2)
' Si gira el volteador 1 cambiamos el color a Verde
If Edit_ReadVal(2) = True Then
Edit_ReadVal(2).BackColor = vbGreen
S2.BackColor = vbGreen
Else
Edit_ReadVal(2).BackColor = vbWhite
S2.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(2))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
If Errors(3) = 0 Then
Edit_ReadVal(3) = ItemValues(3)
Edit_ReadQu(3) = GetQualityText(Qualities(3))
Edit_ReadTS(3) = TimeStamps(3)
' Salida del volteador 1 cambiamos el color a Verde
If Edit_ReadVal(3) = True Then
Edit_ReadVal(3).BackColor = vbGreen
S3.BackColor = vbGreen
Else
Edit_ReadVal(3).BackColor = vbWhite
S3.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(3))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
If Errors(4) = 0 Then
Edit_ReadVal(4) = ItemValues(4)
Edit_ReadQu(4) = GetQualityText(Qualities(4))
Edit_ReadTS(4) = TimeStamps(4)
' Paso de Mesa 1 ----> Mesa 2 color a Verde
If Edit_ReadVal(4) = True Then
Edit_ReadVal(4).BackColor = vbGreen
S4.BackColor = vbGreen
Else
Edit_ReadVal(4).BackColor = vbWhite
S4.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(4))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
If Errors(5) = 0 Then
Edit_ReadVal(5) = ItemValues(5)
Edit_ReadQu(5) = GetQualityText(Qualities(5))
Edit_ReadTS(5) = TimeStamps(5)
' Entrada en volteador 2 color a Verde
If Edit_ReadVal(5) = True Then
Edit_ReadVal(5).BackColor = vbGreen
S5.BackColor = vbGreen
Else
Edit_ReadVal(5).BackColor = vbWhite
S5.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(5))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
If Errors(6) = 0 Then
Edit_ReadVal(6) = ItemValues(6)
Edit_ReadQu(6) = GetQualityText(Qualities(6))
Edit_ReadTS(6) = TimeStamps(6)
' GIRO volteador 2 color a Verde
If Edit_ReadVal(6) = True Then
Edit_ReadVal(6).BackColor = vbGreen
S6.BackColor = vbGreen
Else
Edit_ReadVal(6).BackColor = vbWhite
S6.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(6))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
If Errors(7) = 0 Then
Edit_ReadVal(7) = ItemValues(7)
Edit_ReadQu(7) = GetQualityText(Qualities(7))
Edit_ReadTS(7) = TimeStamps(7)
' BORRAMOS variables y salimos de la linea color a Verde
If Edit_ReadVal(7) = True Then
Edit_ReadVal(7).BackColor = vbGreen
S7.BackColor = vbGreen
Else
Edit_ReadVal(7).BackColor = vbWhite
S7.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(7))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
End If
If Errors(8) = 0 Then
Edit_ReadVal(8) = ItemValues(8)
Edit_ReadQu(8) = GetQualityText(Qualities(8))
Edit_ReadTS(8) = TimeStamps(8)
' BORRAMOS variables y salimos de la linea color a Verde
If Edit_ReadVal(8) = True Then
Edit_ReadVal(8).BackColor = vbGreen
S8.BackColor = vbGreen
Else
Edit_ReadVal(8).BackColor = vbWhite
S8.BackColor = vbWhite
End If
Else
ErrorString = ServerObj.GetErrorString(Errors(8))
MsgBox ErrorString, vbCritical, "Error AsyncReadComplete()"
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 NumItemsEdit_OnDataVal(i - 1) = ItemValues(i)
Edit_OnDataQu(i - 1) = GetQualityText(Qualities(i))
Edit_OnDataTS(i - 1) = TimeStamps(i)
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
Valora esta pregunta
0