Visual FoxPro.NET - Programa de VB a VFOX con activeX

   
Vista:

Programa de VB a VFOX con activeX

Publicado por xqr kmiloq@gmail.com (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,

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 = 1
Const READASYNC_ID = 2
Const 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 Then
        GroupObj.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 OPCServer
    ServerObj.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_ID
    GroupObj.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 = Nothing
    ServerObj.OPCGroups.RemoveAll
    Set GroupObj = Nothing
    ServerObj.Disconnect
    Set ServerObj = Nothing
 
    Exit 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 NumItems
    Edit_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
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder