PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

OPC interface for PB as open source

https://www.purebasic.fr/english/viewtopic.php?t=66106

Page 1 of 1

OPC interface for PB as open source

Posted: Sat Jul 09, 2016 8:38 am
by mk-soft
I just decided my work at the opc interface as a DLL to be published for purebasic.
Thus, one can even without the DLL small OPC clients create.

What is OPC. OPC is a standardized interface to communicate with various controls in industry.

Here is the link to the orginal post:
http://www.purebasic.fr/english/viewtop ... 27&t=37452

Part 1: Defination of interface
Part 2: Program code include file / DLL
License agreement

Using of the code
This code can be used for free.
I can´t give any warranty for the functionality and the correctness of the
results. I can´t take any responsibility for any damage of hardware and
software. You will use this code on your own risk.

Re: OPC interface for PB as open source

Posted: Sat Jul 09, 2016 8:38 am
by mk-soft
Part 1: OpcDefineV22

Code: Select all

;- TOP

; Komment   : OPC Define 
; Version   : v2.102
; Erstellt  : 02.12.2004
; Geändert  : 01.10.2007
; Author    : Michael Kastner (mk-soft)

; Compiler  : Unicode

; *********************************************************************************************************

;- Konstanten CLSCTX

#CLSCTX_INPROC_SERVER  = $1 
#CLSCTX_INPROC_HANDLER = $2 
#CLSCTX_LOCAL_SERVER   = $4 
#CLSCTX_REMOTE_SERVER  = $10 
#CLSCTX_ALL = $17 ;#CLSCTX_INPROC_SERVER|#CLSCTX_INPROC_HANDLER|#CLSCTX_LOCAL_SERVER|#CLSCTX_REMOTE_SERVER

;- Konstanten OPC

#OPC_DS_CACHE = 1
#OPC_DS_DEVICE = 2

#OPC_READABLE = 1
#OPC_WRITEABLE = 2

#OPC_E_INVALIDHANDLE = ($C0040001)
#OPC_E_BADTYPE = ($C0040004)
#OPC_E_PUBLIC = ($C0040005)
#OPC_E_BADRIGHTS = ($C0040006)
#OPC_E_UNKNOWNITEMID = ($C0040007)
#OPC_E_INVALIDITEMID = ($C0040008)
#OPC_E_INVALIDFILTER = ($C0040009)
#OPC_E_UNKNOWNPATH = ($C004000A)
#OPC_E_RANGE = ($C004000B)
#OPC_E_DUPLICATENAME = ($C004000C)
#OPC_S_UNSUPPORTEDRATE = ($0004000D)
#OPC_S_CLAMP = ($0004000E)
#OPC_S_INUSE = ($0004000F)
#OPC_E_INVALIDCONFIGFILE = ($C0040010)
#OPC_E_NOTFOUND = ($C0040011)
#OPC_E_INVALID_PID = ($C0040203)

#OPC_QUALITY_MASK = $C0
#OPC_STATUS_MASK = $FC
#OPC_LIMIT_MASK = $03
#OPC_QUALITY_BAD = $00
#OPC_QUALITY_UNCERTAIN = $40
#OPC_QUALITY_GOOD = $C0
#OPC_QUALITY_CONFIG_ERROR = $04
#OPC_QUALITY_NOT_CONNECTED = $08
#OPC_QUALITY_DEVICE_FAILURE = $0c
#OPC_QUALITY_SENSOR_FAILURE = $10
#OPC_QUALITY_LAST_KNOWN = $14
#OPC_QUALITY_COMM_FAILURE = $18
#OPC_QUALITY_OUT_OF_SERVICE = $1C
#OPC_QUALITY_LAST_USABLE = $44
#OPC_QUALITY_SENSOR_CAL = $50
#OPC_QUALITY_EGU_EXCEEDED = $54
#OPC_QUALITY_SUB_NORMAL = $58
#OPC_QUALITY_LOCAL_OVERRIDE = $D8
#OPC_LIMIT_OK = $00
#OPC_LIMIT_LOW = $01
#OPC_LIMIT_HIGH = $02
#OPC_LIMIT_CONST = $03

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

;- Structure MULTI_QI

Structure MULTI_QI
    *pIID.IID;
    *pItf.l;
    hr.l;
EndStructure

;- Structure COSERVERINFO

Structure COSERVERINFO
    dwReserved1.l;
    *pwszName.i;
    *pAuthInfo.i;
    dwReserved2.l;
EndStructure

;- Structure SAFEARRAYBOUND

CompilerIf Defined(SAFEARRAYBOUND, #PB_Structure) = 0
  Structure SAFEARRAYBOUND
    cElements.l
    lLbound.l
  EndStructure
CompilerEndIf

;- Structure SAFEARRAY

Structure pData
  StructureUnion  
    bVal.b[0]; AS BYTE            ' VT_UI1
    iVal.w[0]; AS INTEGER         ' VT_I2
    lVal.l[0]; AS LONG            ' VT_I4
    fltVal.f[0]; AS SINGLE        ' VT_R4
    dblVal.d[0]; AS DOUBLE        ' VT_R8
    boolVal.w[0]; AS INTEGER      ' VT_BOOL
    scode.l[0]; AS LONG           ' VT_ERROR
    cyVal.l[0]; AS LONG           ' VT_CY
    date.d[0]; AS DOUBLE          ' VT_DATE
    bstrVal.l[0]; AS LONG         ' VT_BSTR
    punkVal.l[0]; AS DWORD        ' VT_UNKNOWN
    pdispVal.l[0]; AS DWORD       ' VT_DISPATCH
    parray.l[0]; AS DWORD         ' VT_ARRAY|*
  EndStructureUnion
EndStructure
  
CompilerIf Defined(SAFEARRAY, #PB_Structure) = 0
  Structure SAFEARRAY
    cDims.w
    fFeatures.w
    cbElements.l
    cLocks.l
    *pvData.pData
    rgsabound.SAFEARRAYBOUND[1]
  EndStructure
CompilerEndIf

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

;- Structure OPC

;- Structure OPCGROUPHEADER

Structure OPCGROUPHEADER
  dwSize.l
  dwItemCount.l
  hClientGroup.l
  dwTransactionID.l
  hrStatus.l
EndStructure

;- Structure OPCITEMHEADER1

Structure OPCITEMHEADER1
  hClient.l
  dwValueOffset.l
  wQuality.w
  wReserved.w
  ftTimeStampItem.FILETIME
EndStructure

;- Structure OPCITEMHEADER2

Structure OPCITEMHEADER2
  hClient.l
  dwValueOffset.l
  wQuality.w
  wReserved.w
EndStructure

;- Structure OPCGROUPHEADERWRITE

Structure OPCGROUPHEADERWRITE
  dwItemCount.l
  hClientGroup.l
  dwTransactionID.l
  hrStatus.l
EndStructure

;- Structure OPCITEMHEADERWRITE

Structure OPCITEMHEADERWRITE
  hClient.l
  dwError.l
EndStructure

;- Structure OPCITEMSTATE

Structure OPCITEMSTATE
  hClient.l
  ftTimeStamp.FILETIME
  wQuality.w
  wReserved.w
  vDataValue.VARIANT
EndStructure

;- Structure OPCSERVERSTATUS

Structure OPCSERVERSTATUS
  ftStartTime.FILETIME
  ftCurrentTime.FILETIME
  ftLastUpdateTime.FILETIME
  dwServerState.l ;OPCSERVERSTATE
  dwGroupCount.l
  dwBandWidth.l
  wMajorVersion.w
  wMinorVersion.w
  wBuildNumber.w
  wReserved.w
EndStructure

;- Structure OPCITEMDEF

Structure OPCITEMDEF
  szAccessPath.s;
  szItemID.s;
  bActive.l;
  hClient.l;
  dwBlobSize.l;
  *pBlob.l;
  vtRequestedDataType.w;
  wReserved.w;
EndStructure

;- Structure OPCITEMATTRIBUTES

Structure OPCITEMATTRIBUTES
  szAccessPath.s;
  szItemID.s;
  bActive.l
  hClient.l
  hServer.l
  dwAccessRights.l
  dwBlobSize.l
  *pBlob.l;
  vtRequestedDataType.l
  vtCanonicalDataType.l
  dwEUType.l ;OPCEUTYPE
  vEUInfo.VARIANT
EndStructure

;- Structure OPCITEMRESULT

Structure OPCITEMRESULT
  hServer.l
  vtCanonicalDataType.w
  wReserved.w
  dwAccessRights.l
  dwBlobSize.l
  *pBlob.l;
EndStructure

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

;- OPC-Server Interfaces 
;-

;- IOPCServer interface definition

Interface IOPCServer
  QueryInterface(a, b)
  AddRef()
  Release()
  AddGroup(a, b, c, d, e, f, g, h, i, j, k)
  GetErrorString(a, b, c)
  GetGroupByName(a, b, c)
  GetStatus(a)
  RemoveGroup(a, b)
  CreateGroupEnumerator(a, b, c)
EndInterface

;- IOPCServerPublicGroups interface definition
;
Interface IOPCServerPublicGroups
  QueryInterface(a, b)
  AddRef()
  Release()
  GetPublicGroupByName(a, b, c)
  RemovePublicGroup(a, b)
EndInterface

;- IOPCBrowseServerAddressSpace interface definition
;
Interface IOPCBrowseServerAddressSpace
  QueryInterface(a, b)
  AddRef()
  Release()
  QueryOrganization(a)
  ChangeBrowsePosition(a, b)
  BrowseOPCItemIDs(a, b, c, d, e)
  GetItemID(a, b)
  BrowseAccessPaths(a, b)
EndInterface

;- IOPCGroupStateMgt interface definition
;
Interface IOPCGroupStateMgt
  QueryInterface(a, b)
  AddRef()
  Release()
  GetState(a, b, c, d, e, f, g, h)
  SetState(a, b, c, d, e, f, g)
  SetName(a)
  CloneGroup(a, b, c)
EndInterface

;- IOPCPublicGroupStateMgt interface definition
;
Interface IOPCPublicGroupStateMgt
  QueryInterface(a, b)
  AddRef()
  Release()
  GetState(a)
  MoveToPublic()
EndInterface

;- IOPCSyncIO interface definition
;
Interface IOPCSyncIO
  QueryInterface(a, b)
  AddRef()
  Release()
  Read(a, b, c, d, e)
  Write(a, b, c, d)
EndInterface

;- IOPCAsyncIO interface definition
;
Interface IOPCAsyncIO
  QueryInterface(a, b)
  AddRef()
  Release()
  Read(a, b, c, d, e, f)
  Write(a, b, c, d, e, f)
  Refresh(a, b, c)
  Cancel(a)
EndInterface

;- IOPCItemMgt interface definition
;
Interface IOPCItemMgt
  QueryInterface(a, b)
  AddRef()
  Release()
  AddItems(a, b, c, d)
  ValidateItems(a, b, c, d, e)
  RemoveItems(a, b, c)
  SetActiveState(a, b, c, d)
  SetClientHandles(a, b, c, d)
  SetDatatypes(a, b, c, d)
  CreateEnumerator(a, b)
EndInterface

;- IEnumOPCItemAttributes interface definition
;
Interface IEnumOPCItemAttributes
  QueryInterface(a, b)
  AddRef()
  Release()
  Next(a, b, c)
  Skip(a)
  Reset()
  Clone(a)
EndInterface

;- IOPCDataCallback interface definition
;
Interface IOPCDataCallback
  QueryInterface(a, b)
  AddRef()
  Release()
  OnDataChange(a, b, c, d, e, f, g, h, i, j)
  OnReadComplete(a, b, c, d, e, f, g, h, i, j)
  OnWriteComplete(a, b, c, d, e, f)
  OnCancelComplete(a, b)
EndInterface

;- IOPCAsyncIO2 interface definition
;
Interface IOPCAsyncIO2
  QueryInterface(a, b)
  AddRef()
  Release()
  Read(a, b, c, d, e)
  Write(a, b, c, d, e, f)
  Refresh2(a, b, c)
  Cancel2(a)
  SetEnable(a)
  GetEnable(a)
EndInterface

;- IOPCItemProperties interface definition
;
Interface IOPCItemProperties
  QueryInterface(a, b)
  AddRef()
  Release()
  QueryAvailableProperties(a, b, c, d, e)
  GetItemProperties(a, b, c, d, e)
  LookupItemIDs(a, b, c, d, e)
EndInterface



;- IOPCShutdown interface definition
;
Interface IOPCShutdown
  QueryInterface(a, b)
  AddRef()
  Release()
  ShutdownRequest(a)
EndInterface

;- IOPCCommon interface definition
;
Interface IOPCCommon
  QueryInterface(a, b)
  AddRef()
  Release()
  SetLocaleID(a)
  GetLocaleID(a)
  QueryAvailableLocaleIDs(a, b)
  GetErrorString(a, b)
  SetClientName(a)
EndInterface

;- IOPCEventServer interface definition
;
Interface IOPCEventServer
  QueryInterface(a, b)
  AddRef()
  Release()
  GetStatus(a)
  CreateEventSubscription(a, b, c, d, e, f, g, h)
  QueryAvailableFilters(a)
  QueryEventCategories(a, b, c, d)
  QueryConditionNames(a, b, c)
  QuerySubConditionNames(a, b, c)
  QuerySourceConditions(a, b, c)
  QueryEventAttributes(a, b, c, d, e)
  TranslateToItemIDs(a, b, c, d, e, f, g, h, i)
  GetConditionState(a, b, c, d, e)
  EnableConditionByArea(a, b)
  EnableConditionBySource(a, b)
  DisableConditionByArea(a, b)
  DisableConditionBySource(a, b)
  AckCondition(a, b, c, d, e, f, g, h)
  CreateAreaBrowser(a, b)
EndInterface

;- IOPCEventSubscriptionMgt interface definition
;
Interface IOPCEventSubscriptionMgt
  QueryInterface(a, b)
  AddRef()
  Release()
  SetFilter(a, b, c, d, e, f, g, h, i)
  GetFilter(a, b, c, d, e, f, g, h, i)
  SelectReturnedAttributes(a, b, c)
  GetReturnedAttributes(a, b, c)
  Refresh(a)
  CancelRefresh(a)
  GetState(a, b, c, d)
  SetState(a, b, c, d, e, f)
EndInterface

;- IOPCEventAreaBrowser interface definition
;
Interface IOPCEventAreaBrowser
  QueryInterface(a, b)
  AddRef()
  Release()
  ChangeBrowsePosition(a, b)
  BrowseOPCAreas(a, b, c)
  GetQualifiedAreaName(a, b)
  GetQualifiedSourceName(a, b)
EndInterface

;- IOPCEventSink interface definition
;
Interface IOPCEventSink
  QueryInterface(a, b)
  AddRef()
  Release()
  OnEvent(a, b, c, d, e)
EndInterface

;- OPCEventServerCATID interface definition
;
Interface OPCEventServerCATID
EndInterface

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

;- Opc-Enum Interfaces

Interface IOPCServerList2 Extends IUnknown
  EnumClassesOfCategories(a,b,c,d,e)
  GetClassDetails(a,b,c,d)
  CLSIDFromProgID(a,b)
EndInterface

Interface IOPCEnumGUID Extends IUnknown
  Next(a,b,c)
  Skip(a)
  Reset()
  Clone(a)
EndInterface

Interface IOPCServerList Extends IUnknown
  EnumClassesOfCategories(a,b,c,d,e)
  GetClassDetails(a,b,c)
  CLSIDFromProgID(a,b)
EndInterface

Interface CATID_OPCDAServer10 Extends IUnknown
EndInterface

Interface CATID_OPCDAServer20 Extends IUnknown
EndInterface

Interface CATID_OPCDAServer30 Extends IUnknown
EndInterface

Interface CATID_XMLDAServer10 Extends IUnknown
EndInterface

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

;- IID OPC-Server DataSection

DataSection

  IID_IOPCServer:
  Data.l $39c13a4d
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCServerPublicGroups:
  Data.l $39c13a4d
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCBrowseServerAddressSpace:
  Data.l $39c13a4f
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCGroupStateMgt:
  Data.l $39c13a50
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCPublicGroupStateMgt:
  Data.l $39c13a51
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCSyncIO:
  Data.l $39c13a52
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCAsyncIO:
  Data.l $39c13a53
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCItemMgt:
  Data.l $39c13a54
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IEnumOPCItemAttributes:
  Data.l $39c13a55
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCDataCallback:
  Data.l $39c13a70
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCAsyncIO2:
  Data.l $39c13a71
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  IID_IOPCItemProperties:
  Data.l $39c13a72
  Data.w $011e,$11d0
  Data.b $96,$75,$00,$20,$af,$d8,$ad,$b3

  LIBID_OPCDA:
  Data.l $B28EEDB2
  Data.w $AC6F,$11d1
  Data.b $84,$D5,$00,$60,$8C,$B8,$A7,$E9
  
EndDataSection

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

;- IID OPC Enum DataSection
  
DataSection
  
  LIBID_OPCCOMN: ; '{B28EEDB1-AC6F-11D1-84D5-00608CB8A7E9}'
  Data.l $B28EEDB1
  Data.w $AC6F,$11D1
  Data.b $84,$D5,$00,$60,$8C,$B8,$A7,$E9

  IID_IOPCCommon: ; '{F31DFDE2-07B6-11D2-B2D8-0060083BA1FB}'
  Data.l $F31DFDE2
  Data.w $07B6,$11D2
  Data.b $B2,$D8,$00,$60,$08,$3B,$A1,$FB
  
  IID_IOPCShutdown: ; '{F31DFDE1-07B6-11D2-B2D8-0060083BA1FB}'
  Data.l $F31DFDE1
  Data.w $07B6,$11D2
  Data.b $B2,$D8,$00,$60,$08,$3B,$A1,$FB
  
  IID_IOPCServerList: ; '{13486D50-4821-11D2-A494-3CB306C10000}'
  Data.l $13486D50
  Data.w $4821,$11D2
  Data.b $A4,$94,$3C,$B3,$06,$C1,$00,$00
  
  IID_IOPCEnumGUID: ; '{55C382C8-21C7-4e88-96C1-BECFB1E3F483}'
  Data.l $55C382C8
  Data.w $21C7,$4e88
  Data.b $96,$C1,$BE,$CF,$B1,$E3,$F4,$83
  
  IID_IOPCServerList2: ; '{9DD0B56C-AD9E-43ee-8305-487F3188BF7A}'
  Data.l $9DD0B56C
  Data.w $AD9E,$43ee
  Data.b $83,$05,$48,$7F,$31,$88,$BF,$7A
  
  CLSID_OPCServerList: ; '{13486D51-4821-11D2-A494-3CB306C10000}'
  Data.l $13486D51
  Data.w $4821,$11D2
  Data.b $A4,$94,$3C,$B3,$06,$C1,$00,$00
  
  IID_CATID_OPCDAServer10: ; {63D5F430-CFE4-11d1-B2C8-0060083BA1FB}
  Data.l $63D5F430
  Data.w $CFE4,$11d1
  Data.b $B2,$C8,$00,$60,$08,$3B,$A1,$FB
  
  IID_CATID_OPCDAServer20: ; {63D5F432-CFE4-11d1-B2C8-0060083BA1FB}
  Data.l $63D5F432
  Data.w $CFE4,$11d1
  Data.b $B2,$C8,$00,$60,$08,$3B,$A1,$FB
  
  IID_CATID_OPCDAServer30: ; {CC603642-66D7-48f1-B69A-B625E73652D7}
  Data.l $CC603642
  Data.w $66D7,$48f1
  Data.b $B6,$9A,$B6,$25,$E7,$36,$52,$D7
  
  IID_CATID_XMLDAServer10: ; {3098EDA4-A006-48b2-A27F-247453959408}
  Data.l $3098EDA4
  Data.w $A006,$48b2
  Data.b $A2,$7F,$24,$74,$53,$95,$94,$08

EndDataSection

Re: OPC interface for PB as open source

Posted: Sat Jul 09, 2016 8:38 am
by mk-soft
Part 2.1: OpcFunctionsV24.pb

Code: Select all

;- TOP

; Komment   : OPC Functionen PBOPC.DLL 
; Version   : v2.40
; Erstellt  : 12.05.2009
; Geändert  : 12.03.2010
; Author    : Michael Kastner (mk-soft)

; Compiler  : PB 4.31 / Unicode

EnableExplicit

; *********************************************************************************************************

;- OLE Automation

Import "oleaut32.lib"
 VarBstrFromDate(dblln.d, lcid.l, dwFlags.l, *pbstrOut)                                                 
 VarDateFromStr(strIn.p-unicode, lcid.l, dwFlags, *pdateOut)
 VariantChangeType(*pvargDesk, *pvargSrc, wFlags, vt.l)
EndImport

; *********************************************************************************************************

IncludeFile "OpcDefineV22.PB"

; *********************************************************************************************************

;Global OpcLastError.l
;Global OpcMutex

; *********************************************************************************************************

;- Structure vbString

Structure vbString
  len.l
  text.s
EndStructure

;- Structure Shutdown

Structure udtShutdown
  *VTable
  *Memory
  *Server
  Cookie.l
  ShutdownRef.l
  IsShutdown.l
  szReason.vbString
  *Callback
EndStructure

;- Structure Server

Structure udtServer
  ; Server
  *m_pIOPCServer.IOPCServer
  ServerName.s
  ServerNode.s
  ; Shutdown
  *ShutdownObject.udtShutdown  
EndStructure

;- Structure Group

Structure udtGroup
  *m_pIOPCItemMgt.IOPCItemMgt
  *m_pIOPCSyncIO.IOPCSyncIO
  *m_pIOPCServer.IOPCServer
  GrpSrvHandle.l
  GroupName.s
  TimBias.l
  PercentDeadband.f
  RevisedUpdateRate.l
EndStructure

;- Structure Item
Structure udtItem
  *pItemResults.OPCITEMRESULT
  *pItemValues.OPCITEMSTATE
  *pItemErrors.long
  *pErrors.long
  *GroupObject.udtGroup
  Item.OPCITEMDEF
  ItemName.s
  ItemData.l
EndStructure

;- Arrays

Structure udtItemArray
  *index.udtItem[0]
EndStructure

Structure udtVariantArray
  index.Variant[0]
EndStructure

Structure udtQualityArray
  index.l[0]
EndStructure

Structure udtErrorsArray
  index.l[0]
EndStructure

Structure udtItemValuesArray
  index.OPCITEMSTATE[0]
EndStructure

Structure udthServerArray
  index.l[0]
EndStructure

Structure udtArray
  index.l[0]
EndStructure

;- Stucture ServerList

Structure udtServerList
  ProgID.s
  UserType.s
  VerIndProgID.s
  CLSID.IID
EndStructure


;- Globale Listen

Global NewList ServerObject.udtServer()
Global NewList GroupObject.udtGroup()
Global NewList ItemObject.udtItem()

; *********************************************************************************************************

Declare OpcReleaseShutdown(*ServerOject.udtServer)

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

; This procedure is called once, when the program loads the library
; for the first time. All init stuffs can be done here (but not DirectX init)
;
ProcedureDLL AttachProcess(Instance)
  
  Global OpcLastError.l
  Global OpcMutex

  OpcMutex = CreateMutex()
  
EndProcedure


; Called when the program release (free) the DLL
;
ProcedureDLL DetachProcess(Instance)
  FreeMutex(OpcMutex)
EndProcedure


; Both are called when a thread in a program call or release (free) the DLL
;
ProcedureDLL AttachThread(Instance)
EndProcedure

ProcedureDLL DetachThread(Instance)
EndProcedure

Procedure OpcInit()

  OpcMutex = CreateMutex()
  
EndProcedure:OpcInit()

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

;- Memory Gabage

; Procedure VariantClear(*Var.variant)
;  
;   Protected hr
;  
;   If *Var\vt & #VT_ARRAY = #VT_ARRAY
;     hr =  SafeArrayDestroy_(*Var\parray)
;     If hr = #S_OK
;       *Var\parray = 0
;       *var\vt = #VT_EMPTY
;     EndIf
;     ProcedureReturn hr
;   Else
;     ProcedureReturn VariantClear(*Var)
;   EndIf
;  
; EndProcedure

Macro VariantClear
  VariantClear_
EndMacro

Macro CoTaskMemFree(mem)
  If mem : CoTaskMemFree_(mem) : mem = #Null : EndIf
EndMacro
; *********************************************************************************************************

Procedure ValidServerObject(*ServerObject)

  ForEach ServerObject()
    If ServerObject() = *ServerObject
      ProcedureReturn #S_OK
    EndIf
  Next
  
  ProcedureReturn #E_POINTER
  
EndProcedure

; *********************************************************************************************************

Procedure ValidGroupObject(*GroupObject)

  ForEach GroupObject()
    If GroupObject() = *GroupObject
      ProcedureReturn #S_OK
    EndIf
  Next
  
  ProcedureReturn #E_POINTER
  
EndProcedure

; *********************************************************************************************************

Procedure.s SqlDateStrFromDate(date.d)

  Protected result.s, datum.s, *pbstrOut
 
  If VarBstrFromDate(date, $0407, #LOCALE_NOUSEROVERRIDE, @*pbstrOut) <> #S_OK
    ProcedureReturn "0000-00-00-00:00:00"
  EndIf
 
  result = PeekS(*pbstrOut,#PB_Any, #PB_Unicode)
  SysFreeString_(*pbstrOut)
  If Len(result) <= 8
    ProcedureReturn "0000-00-00-00:00:00"
  EndIf
 
  datum = Mid(result, 7, 4) + "-"
  datum + Mid(result, 4, 2) + "-"
  datum + Mid(result, 0, 2) + "-"
  datum + Mid(result, 12, 8)
  If Len(datum) < 12
    datum + "00:00:00"
  EndIf
  ProcedureReturn datum
 
EndProcedure

; ***************************************************************************************

Procedure.s SqlDateStrFromDateStr(date.s)

  Protected datum.d, result.s

  VarDateFromStr(date, 0, #LOCALE_NOUSEROVERRIDE, @datum)
  result = SqlDateStrFromDate(Datum)
  ProcedureReturn result
 
EndProcedure

; ***************************************************************************************

ProcedureDLL.s FormatMessage(ErrorNumber.l)

  Protected *Buffer, len, result.s
  Static text.vbString
  
  len = FormatMessage_(#FORMAT_MESSAGE_ALLOCATE_BUFFER|#FORMAT_MESSAGE_FROM_SYSTEM,0,ErrorNumber,0,@*Buffer,0,0)
  If len
    result = PeekS(*Buffer, len - 2)
    LocalFree_(*Buffer)
    text\text = "[" + RSet(Hex(ErrorNumber, #PB_Long), 8, "0") + "] " + result
  Else
    text\text = "[" + RSet(Hex(ErrorNumber, #PB_Long), 8, "0") + "]"
  EndIf
  
  text\len = Len(text\text)
  ProcedureReturn text\text
  
EndProcedure

; *********************************************************************************************************


ProcedureDLL.l OpcGetQualityText(qnr.l)

  ;- OpcGetQualityText(qnr.l)
  ;-- Param1: Quality Number
  ;-- Result: Qualitytext as pString (Unicode)
  
  Static qstr.vbString
  
  Select qnr
    Case #OPC_QUALITY_BAD: 
               qstr\text = "BAD";
    Case #OPC_QUALITY_UNCERTAIN: 
               qstr\text = "UNCERTAIN";
    Case #OPC_QUALITY_GOOD: 
               qstr\text = "GOOD";
    Case #OPC_QUALITY_NOT_CONNECTED: 
               qstr\text = "NOT_CONNECTED";
    Case #OPC_QUALITY_DEVICE_FAILURE: 
               qstr\text = "DEVICE_FAILURE";
    Case #OPC_QUALITY_SENSOR_FAILURE: 
               qstr\text = "SENSOR_FAILURE";
    Case #OPC_QUALITY_LAST_KNOWN: 
               qstr\text = "LAST_KNOWN";
    Case #OPC_QUALITY_COMM_FAILURE: 
               qstr\text = "COMM_FAILURE";
    Case #OPC_QUALITY_OUT_OF_SERVICE: 
               qstr\text = "OUT_OF_SERVICE";
    Case #OPC_QUALITY_LAST_USABLE: 
               qstr\text = "LAST_USABLE";
    Case #OPC_QUALITY_SENSOR_CAL: 
               qstr\text = "SENSOR_CAL";
    Case #OPC_QUALITY_EGU_EXCEEDED: 
               qstr\text = "EGU_EXCEEDED";
    Case #OPC_QUALITY_SUB_NORMAL: 
               qstr\text = "SUB_NORMAL";
    Case #OPC_QUALITY_LOCAL_OVERRIDE: 
               qstr\text = "LOCAL_OVERRIDE";
    Default
               qstr\text = "UNKNOWN ERROR";
  EndSelect
  qstr\len = Len(qstr\text)
  ProcedureReturn @qstr\text;

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcGetErrorString(*ServerObject.udtServer, ErrorNumber.l)

  ;- OpcGetErrorString(*Server.ServerObject, ErrorNumber.l)
  ;-- Para 1: IOPCServer Object
  ;-- Para 2: Errorcode
  ;-- Result: Errortext as pString (Unicode) 
  
  Protected r1, *result
  Static vbText.vbString
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    vbText\text = FormatMessage(ErrorNumber)
    vbText\len = Len(vbText\text)
    UnlockMutex(OpcMutex)
    ProcedureReturn @vbText\text
  EndIf
  
  r1 = *Serverobject\m_pIOPCServer\GetErrorString(ErrorNumber, 0, @*result)
  If r1 = #S_OK
    vbText\text = "[" + RSet(Hex(ErrorNumber, #PB_Long), 8, "0") + "] " + PeekS(*result)
  Else
    vbText\text = FormatMessage(ErrorNumber)
  EndIf
  CoTaskMemFree(*result)
  
  vbText\len = Len(vbText\text)
  UnlockMutex(OpcMutex)
  ProcedureReturn @vbText\text
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcGetLastError()

  ProcedureReturn OpcLastError
  
EndProcedure

; *********************************************************************************************************
;------------------------------------------------

; *********************************************************************************************************

Procedure.s StringFromCLSID(*clsid.iid)

  ;-- Result LCSID String
  
  Protected result.s, i, b
  
  result = "{"
  result + RSet(Hex(*clsid\data1),8,"0")
  result + "-" + RSet(Hex(*clsid\data2),4,"0")
  result + "-" + RSet(Hex(*clsid\data3),4,"0")
  result + "-"
  b = *clsid\data4[0] & $FF
  result + RSet(Hex(b),2,"0")
  b = *clsid\data4[1] & $FF
  result + RSet(Hex(b),2,"0")
  result + "-"
  For i = 2 To 7 
    b = *clsid\data4[i] & $FF
    result + RSet(Hex(b),2,"0")
  Next
  result + "}"
  
  ProcedureReturn result
 
EndProcedure
 
; *********************************************************************************************************

Procedure.l OpcEnum_CLSIDFromProgID(ServerName.s, ServerNode.s, *CLSID.IID)

  ;-- Result: True or False

  Protected r1
  Protected mqi.MULTI_QI
  Protected serverInfo.COSERVERINFO
  Protected *OpcServerList2.IOPCServerList2
  
  If ServerNode = ""
    ServerNode = "localhost"
  EndIf
  
  serverInfo\dwReserved1 = 0
  serverInfo\pwszName = @ServerNode
  serverInfo\pAuthInfo = 0
  serverInfo\dwReserved2 = 0

  mqi\pIID = ?IID_IOPCServerList2;
  mqi\pItf = 0;
  mqi\hr = #S_OK;
  
  r1 = CoInitialize_(#Null);
  If (r1 <> #S_OK)
    If (r1 = #S_FALSE)
      OpcLastError = r1
    Else
      OpcLastError = r1
      ProcedureReturn 0
    EndIf
  EndIf
  
  r1 = CoCreateInstanceEx_(?CLSID_OPCServerList, #Null, #CLSCTX_REMOTE_SERVER, @serverInfo, 1,@mqi)
  If (r1 <> #S_OK) Or (mqi\hr <> #S_OK) 
    OpcLastError = r1
    ProcedureReturn #False
  EndIf
  
  *OpcServerList2 = mqi\pItf
  
  r1 = *OpcServerList2\CLSIDFromProgID(@ServerName, *clsid)
  OpcLastError = r1
  *OpcServerList2\Release()
  If r1 = #S_OK
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
  
EndProcedure

; *********************************************************************************************************

Procedure.l OpcEnum_ServerList(ServerNode.s, *IID_CATID.IID, List ServerList.udtServerList())

  ;-- Result: True or False

  Protected r1
  Protected mqi.MULTI_QI
  Protected serverInfo.COSERVERINFO
  Protected *OpcServerList2.IOPCServerList2
  
  Protected *OPCEnumGUID.IOPCEnumGUID
  Protected clsid.iid
  Protected fetched.l
  Protected *str1, *str2, *str3
  
  If ServerNode = ""
    ServerNode = "localhost"
  EndIf
  
  serverInfo\dwReserved1 = 0
  serverInfo\pwszName = @ServerNode
  serverInfo\pAuthInfo = 0
  serverInfo\dwReserved2 = 0

  mqi\pIID = ?IID_IOPCServerList2;
  mqi\pItf = 0;
  mqi\hr = #S_OK;
  
  r1 = CoInitialize_(#Null);
  If (r1 <> #S_OK)
    If (r1 = #S_FALSE)
      OpcLastError = r1
    Else
      OpcLastError = r1
      ProcedureReturn #False
    EndIf
  EndIf
  
  r1 = CoCreateInstanceEx_(?CLSID_OPCServerList, #Null, #CLSCTX_REMOTE_SERVER, @serverInfo, 1,@mqi)
  If (r1 <> #S_OK) Or (mqi\hr <> #S_OK) 
    OpcLastError = r1
    ProcedureReturn #False
  EndIf
  
  *OpcServerList2 = mqi\pItf
  
  r1 = *OPCServerList2\EnumClassesOfCategories (1, *IID_CATID, 0, 0, @*OPCEnumGUID);
  OpcLastError = r1
  If r1 <> #S_OK
    ProcedureReturn #False
  EndIf
    
  While *OPCEnumGUID\Next(1, @clsid, @fetched) = #S_OK
    r1 = *OPCServerList2\GetClassDetails(clsid, @*str1, @*str2, @*str3)
    OpcLastError = r1
    If r1 <> #S_OK
      Break
    Else
      AddElement(ServerList())
      Serverlist()\ProgID = PeekS(*str1)
      Serverlist()\UserType = PeekS(*str2)
      Serverlist()\VerIndProgID = PeekS(*str3)
      CopyMemory(CLSID, ServerList()\CLSID, SizeOf(IID))
    EndIf
  Wend
  
  *OPCEnumGUID\Release()
  *OpcServerList2\Release()
  
  If r1 = #S_OK
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
  
EndProcedure

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

ProcedureDLL.l OpcConnect(ServerName.s, ServerNode.s = "")

  ;- OpcConnect(ServerName.s, ServerNode.s)
  ;-- Param1: ServerName as String
  ;-- Param2: ServerNode as String (Optional)
  ;-- Result: IOPCServer as Pointer

  Protected r1
  Protected *m_pIOPCServer.IOPCServer
  Protected *ServerObject.udtServer
  Protected clsid.IID
  Protected mqi.MULTI_QI
  Protected serverInfo.COSERVERINFO
  
  LockMutex(OpcMutex)
  If AddElement(ServerObject()) = 0
    OpcLastError = #E_OUTOFMEMORY
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  *ServerObject = @ServerObject()
  
  If ServerNode
    ; Server über Netzwerk
    serverInfo\dwReserved1 = 0
    serverInfo\pwszName = @ServerNode
    serverInfo\pAuthInfo = 0
    serverInfo\dwReserved2 = 0
  
    mqi\pIID = ?IID_IOPCServer;
    mqi\pItf = 0;
    mqi\hr = #S_OK;
    
    
    r1 = CoInitialize_(#Null);
    If (r1 <> #S_OK)
      If (r1 = #S_FALSE)
        OpcLastError = r1
      Else
        OpcLastError = r1
        DeleteElement(ServerObject())
        UnlockMutex(OpcMutex)
        ProcedureReturn 0
      EndIf
    EndIf
    
    r1 = CLSIDFromProgID_(ServerName, @clsid)
    If (r1 <> #S_OK)
      If OpcEnum_CLSIDFromProgID(ServerName, ServerNode, @clsid) = #False
        OpcLastError = r1
        DeleteElement(ServerObject())
        UnlockMutex(OpcMutex)
        ProcedureReturn 0
      EndIf
    EndIf
    
    r1 = CoCreateInstanceEx_(@clsid, #Null, #CLSCTX_REMOTE_SERVER, @serverInfo, 1,@mqi)
    If (r1 <> #S_OK) Or (mqi\hr <> #S_OK) 
      OpcLastError = r1
      DeleteElement(ServerObject())
      UnlockMutex(OpcMutex)
      ProcedureReturn 0
    Else 
      OpcLastError = 0
      With *ServerObject
        \m_pIOPCServer = mqi\pItf
        \ServerName = ServerName
        \ServerNode = ServerNode
      EndWith
      UnlockMutex(OpcMutex)
      ProcedureReturn *ServerObject
    EndIf
  Else
    ; Server Local
    r1 = CoInitialize_(#Null);
    If (r1 <> #S_OK)
      If (r1 = #S_FALSE)
        OpcLastError = r1
      Else
        OpcLastError = r1
        DeleteElement(ServerObject())
        UnlockMutex(OpcMutex)
        ProcedureReturn 0
      EndIf
    EndIf
    
    r1 = CLSIDFromProgID_(ServerName, @clsid)
    
    If (r1 <> #S_OK)
      OpcLastError = r1
      ProcedureReturn 0
    EndIf
  
    r1 = CoCreateInstance_(@clsid, #Null, #CLSCTX_LOCAL_SERVER, ?IID_IOPCServer, @*m_pIOPCServer)
    If (r1 <> #S_OK)
      OpcLastError = r1
      DeleteElement(ServerObject())
      UnlockMutex(OpcMutex)
      ProcedureReturn 0
    Else 
      With *ServerObject
        \m_pIOPCServer = *m_pIOPCServer
        \ServerName = ServerName
        \ServerNode = ServerNode
      EndWith
      UnlockMutex(OpcMutex)
      ProcedureReturn *ServerObject
    EndIf
  
  EndIf
    
EndProcedure


; *********************************************************************************************************

Procedure.l OpcSyncIO(*m_pIOPCItemMgt.IOPCItemMgt)

  ;-- Param1: IOPCItemMgt
  ;-- Result: IOPCSyncIO

  Protected *m_pIOPCSyncIO.IOPCSyncIO
  Protected r1

  If *m_pIOPCItemMgt = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn 0
  EndIf
  
  r1 = *m_pIOPCItemMgt\QueryInterface(?IID_IOPCSyncIO, @*m_pIOPCSyncIO.IOPCSyncIO);
  If (r1 < 0)
    OpcLastError = r1
    ProcedureReturn 0
  EndIf
  
  OpcLastError = 0
  ProcedureReturn *m_pIOPCSyncIO.IOPCSyncIO
  
EndProcedure


; *********************************************************************************************************

ProcedureDLL.l OpcAddGroup(*ServerObject.udtServer, GroupName.s)

  ;- OpcAddGroup(*m_pIOPCServer.IOPCServer, GroupName.s)
  ;-- Param1: OPC Server Object as Pointer
  ;-- Param2: GroupName as String
  ;-- Param3: TimBias as int32 (Optional)
  ;-- Param4: PercentDeadband as Float (Optional)
  ;-- Result: Group Object as Pointer
  
  Protected r1
  Protected *m_pIOPCServer.IOPCServer
  Protected *m_pIOPCItemMgt.IOPCItemMgt
  Protected *m_pIOPCSyncIO.IOPCSyncIO
  Protected *GroupObject
  Protected RevisedUpdateRate.l
  Protected GrpSrvHandle.l
  Protected TimBias.l
  Protected PercentDeadband.f
  
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  *m_pIOPCServer = *ServerObject\m_pIOPCServer
  TimBias.l = 0
  PercentDeadband.f = 1.0
  
  r1 = *m_pIOPCServer\AddGroup(@GroupName,#True,500,1,@TimBias,@PercentDeadband,0,@GrpSrvHandle,@RevisedUpdateRate,?IID_IOPCItemMgt,@*m_pIOPCItemMgt);
  If (r1 <> #S_OK)
    OpcLastError = r1
    ProcedureReturn 0
  EndIf
  
  ;*m_pIOPCSyncIO = OpcSyncIO(*m_pIOPCItemMgt)
  r1 = *m_pIOPCItemMgt\QueryInterface(?IID_IOPCSyncIO, @*m_pIOPCSyncIO.IOPCSyncIO);
  If (r1 < 0)
    OpcLastError = r1
    ProcedureReturn 0
  EndIf
  OpcLastError = 0
  If *m_pIOPCSyncIO
    If AddElement(GroupObject())
      *GroupObject = @GroupObject()
      With GroupObject()
        \GroupName = GroupName
        \TimBias = TimBias
        \PercentDeadband = PercentDeadband
        \RevisedUpdateRate = RevisedUpdateRate
        \GrpSrvHandle = GrpSrvHandle
        \m_pIOPCServer = *m_pIOPCServer 
        \m_pIOPCItemMgt = *m_pIOPCItemMgt
        \m_pIOPCSyncIO = *m_pIOPCSyncIO
      EndWith
    Else
      *m_pIOPCSyncIO\Release()
      *m_pIOPCItemMgt\Release()
      *GroupObject = 0
      OpcLastError = #E_OUTOFMEMORY
    EndIf  
  Else
    *m_pIOPCItemMgt\Release()
    *GroupObject = 0
  EndIf
  
  UnlockMutex(OpcMutex)
  ProcedureReturn *GroupObject
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcRemoveGroup(*GroupObject)

  ;- OpcRemoveGroup(*GroupObject)
  ;-- Param1: Group Object as Pointer
  ;-- Result: hResult
  
  Protected r1, *OldGroup, c
  
  LockMutex(OpcMutex)
  r1 = ValidGroupObject(*GroupObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn r1
  EndIf
  
  *OldGroup = ChangeCurrentElement(GroupObject(), *GroupObject)
  With GroupObject()
    c = 10
    Repeat
      r1 = \m_pIOPCSyncIO\Release()
      c - 1
    Until r1 = 0 Or c = 0
    c = 10
    Repeat
      r1 = \m_pIOPCItemMgt\Release()
      c - 1
    Until r1 = 0 Or c = 0
    r1 = \m_pIOPCServer\RemoveGroup(\GrpSrvHandle, #True);
  EndWith
  OpcLastError = r1
  DeleteElement(GroupObject())
  ; Items löschen
  ForEach ItemObject()
    If ItemObject()\GroupObject = *GroupObject
      CoTaskMemFree(ItemObject()\pItemResults)
      CoTaskMemFree(ItemObject()\pItemErrors)
      DeleteElement(ItemObject())
      Continue
    EndIf
  Next
  UnlockMutex(OpcMutex)
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcRelease(*ServerObject.udtServer)

  ;- OpcRelease(*Server.IOPCServer)
  ;-- Param1: IOPCServer as Pointer
  ;-- Result: OPC Server Release or hResult
  
  Protected r1, c
  Protected *m_pIOPCServer.IOPCServer
  Protected *GroupObject
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn r1
  EndIf
  
  *m_pIOPCServer = *ServerObject\m_pIOPCServer
  
  ; Gruppen löschen
  ForEach GroupObject()
    If GroupObject()\m_pIOPCServer = *m_pIOPCServer
      *GroupObject = GroupObject()
      With GroupObject()
        c = 10
        Repeat
          r1 = \m_pIOPCSyncIO\Release()
          c - 1
        Until r1 = 0 Or c = 0
        c = 10
        Repeat
          r1 = \m_pIOPCItemMgt\Release()
          c - 1
        Until r1 = 0 Or c = 0
        r1 = \m_pIOPCServer\RemoveGroup(\GrpSrvHandle, #True);
      EndWith
      DeleteElement(GroupObject())
      ; Items löschen
      ForEach ItemObject()
        If ItemObject()\GroupObject = *GroupObject
          CoTaskMemFree(ItemObject()\pItemResults)
          CoTaskMemFree(ItemObject()\pItemErrors)
          DeleteElement(ItemObject())
          Continue
        EndIf
      Next
      Continue
    EndIf
  Next
  ; Shutdown löschen
  OpcReleaseShutdown(*ServerObject)
  
  r1 = *m_pIOPCServer\Release()
  ChangeCurrentElement(ServerObject(), *ServerObject)
  DeleteElement(ServerObject())
  UnlockMutex(OpcMutex)
  ProcedureReturn r1
  
EndProcedure

Re: OPC interface for PB as open source

Posted: Sat Jul 09, 2016 8:41 am
by mk-soft
Part 2.2: OpcFunctionsV24.pb

Code: Select all

; *********************************************************************************************************

ProcedureDLL.l OpcAddItem(*GroupObject.udtGroup, AccessPath.s, ItemID.s)

  ;- OpcAddItem(*GroupObject.udtGroup, AccessPath.s, ItemID.s)
  ;-- Param1: Group Object as Pointer
  ;-- Param2: AccessPath as String
  ;-- Param3: ItemID as String
  ;-- Result: ItemObject as Pointer

  Protected i
  Protected r1
  Protected MaxItems, *Item
  
  LockMutex(OpcMutex)
  r1 = ValidGroupObject(*GroupObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  *Item = AddElement(ItemObject())
  If *Item
    ItemObject()\GroupObject = *GroupObject
    ItemObject()\Item\szAccessPath = AccessPath
    ItemObject()\Item\szItemID = ItemID
    ItemObject()\Item\bActive = #True
    ItemObject()\Item\hClient = *Item
    ItemObject()\Item\dwBlobSize = 0
    ItemObject()\Item\pBlob = 0
    ItemObject()\Item\vtRequestedDataType = #VT_EMPTY
  Else
    OpcLastError = #E_OUTOFMEMORY
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  ; AddItems
  With ItemObject()
    r1 = \GroupObject\m_pIOPCItemMgt\AddItems(1, @\Item, @\pItemresults, @\pItemErrors);
    If r1 = #S_FALSE
      OpcLastError = \pItemErrors\l
      CoTaskMemFree(\pItemResults)
      CoTaskMemFree(\pItemErrors)
      DeleteElement(ItemObject())
      UnlockMutex(OpcMutex)
      ProcedureReturn 0
    ElseIf r1 <> #S_OK
      OpcLastError = r1
      CoTaskMemFree(\pItemResults)
      CoTaskMemFree(\pItemErrors)
      DeleteElement(ItemObject())
      UnlockMutex(OpcMutex)
      ProcedureReturn 0
    EndIf
  EndWith
  
  r1 = @ItemObject()
  UnlockMutex(OpcMutex)
  ProcedureReturn r1
  
EndProcedure


; *********************************************************************************************************

ProcedureDLL.l OpcValidateItem(*GroupObject.udtGroup, AccessPath.s, ItemID.s)

  ;- OpcAddItem(*GroupObject.udtGroup, AccessPath.s, ItemID.s)
  ;-- Param1: Group Object as Pointer
  ;-- Param2: AccessPath as String
  ;-- Param3: ItemID as String
  ;-- Result: hResult

  Protected i
  Protected r1
  Protected Item.OPCITEMDEF
  Protected *ppValidationResult.OPCITEMRESULT, *ppError.long
  
  LockMutex(OpcMutex)
  r1 = ValidGroupObject(*GroupObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn r1
  EndIf
  
  
  Item\szAccessPath = AccessPath
  Item\szItemID = ItemID
  Item\bActive = #False
  Item\hClient = 0
  Item\dwBlobSize = 0
  Item\pBlob = 0
  Item\vtRequestedDataType = #VT_EMPTY
  
  ; Validate Item
  r1 = *GroupObject\m_pIOPCItemMgt\ValidateItems(1, @Item, 0, @*ppValidationResult, @*ppError);
  If r1 = #S_FALSE
    r1 = *ppError\l
  ElseIf r1 <> #S_OK
  
  EndIf
  
  CoTaskMemFree(*ppValidationResult)
  CoTaskMemFree(*ppError)
    
  OpcLastError = r1
  UnlockMutex(OpcMutex)
  ProcedureReturn r1
  
EndProcedure


; *********************************************************************************************************

ProcedureDLL.l OpcRemoveItem(*ItemObject.udtItem)

  ;- OpcRemoveItem(*ItemObject.udtItem)
  ;-- Param1: ItemObject as Pointer
  ;-- Result: hResult
  
  Protected r1, r2, *OldItem
    
  If *ItemObject = 0
    r1 = #E_POINTER
    OpcLastError = r1
    ProcedureReturn r1
  EndIf
  
  LockMutex(OpcMutex)
  
  *OldItem = ChangeCurrentElement(ItemObject(), *ItemObject)
  With ItemObject()
    r1 = \GroupObject\m_pIOPCItemMgt\RemoveItems(1, @\pItemResults\hServer, @\pErrors);
    If r1 = #S_FALSE
      r2 = \pItemErrors\l
    Else
      r2 = r1
    EndIf
    CoTaskMemFree(\pItemResults)
    CoTaskMemFree(\pItemErrors)
    CoTaskMemFree(\pErrors)
  EndWith
  
  DeleteElement(ItemObject())
  OpcLastError = r2
  UnlockMutex(OpcMutex)
  ProcedureReturn r2
  
EndProcedure


; *********************************************************************************************************

;------------------------------------------------
;- Single Read/Write Data
;-

ProcedureDLL.l OpcReadBool(*ItemObject.udtItem, *pResult.long, *pQuality.long = 0)

  ;- OpcReadBool(*ItemObject.udtItem, *pResult.long, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as int32
  ;-- Param3: Pointer to pQuality as int32, can null
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      r1 = VariantChangeType(result, \pItemValues\vDataValue, 4, #VT_BOOL)
      If r1 = #S_OK
        If result\boolVal
        *pResult\l = #True
        Else
        *pResult\l = #False
        EndIf
      EndIf
      VariantClear(result)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure


; *********************************************************************************************************

ProcedureDLL.l OpcReadByte(*ItemObject.udtItem, *pResult.byte, *pQuality.long = 0)

  ;- OpcReadByte(*ItemObject.udtItem, *pResult.byte, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as Byte
  ;-- Param3: Pointer to pQuality as int32, can null
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      r1 = VariantChangeType(result, \pItemValues\vDataValue, 4, #VT_I1)
      If r1 = #S_OK
        *pResult\b = result\bVal
      EndIf
      VariantClear(result)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure


; *********************************************************************************************************

ProcedureDLL.l OpcReadWord(*ItemObject.udtItem, *pResult.word, *pQuality.long = 0)

  ;- OpcReadWord(*ItemObject.udtItem, *pResult.word, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as Word
  ;-- Param3: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      r1 = VariantChangeType(result, \pItemValues\vDataValue, 4, #VT_I2)
      If r1 = #S_OK
        *pResult\w = result\iVal
      EndIf
      VariantClear(result)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadLong(*ItemObject.udtItem, *pResult.long, *pQuality.long = 0)

  ;- OpcReadLong(*ItemObject.udtItem, *pResult.long, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as int32
  ;-- Param3: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      r1 = VariantChangeType(result, \pItemValues\vDataValue, 4, #VT_I4)
      If r1 = #S_OK
        *pResult\l = result\lVal
      EndIf
      VariantClear(result)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadFloat(*ItemObject.udtItem, *pResult.float, *pQuality.long = 0)

  ;- OpcReadFloat(*ItemObject.udtItem, *pResult.float, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as Float
  ;-- Param3: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      r1 = VariantChangeType(result, \pItemValues\vDataValue, 4, #VT_R4)
      If r1 = #S_OK
        *pResult\f = result\fltVal
      EndIf
      VariantClear(result)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadDouble(*ItemObject.udtItem, *pResult.double, *pQuality.long = 0)

  ;- OpcReadDouble(*ItemObject.udtItem, *pResult.double, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as Double
  ;-- Param3: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      r1 = VariantChangeType(result, \pItemValues\vDataValue, 4, #VT_R8)
      If r1 = #S_OK
        *pResult\d = result\dblVal
      EndIf
      VariantClear(result)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadDate(*ItemObject.udtItem, *pResult.double, *pQuality.long = 0)

  ;- OpcReadDate(*ItemObject.udtItem, *pResult.double, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as Date (Double)
  ;-- Param3: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected datum.d, temp.s 
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      If \pItemResults\vtCanonicalDataType = #VT_DATE
        *pResult\d = \pItemValues\vDataValue\dblVal
      ElseIf \pItemResults\vtCanonicalDataType = #VT_BSTR
        temp = PeekS(\pItemValues\vDataValue\bstrVal)
        temp = Left(temp,10) + " " + Mid(temp,12,8)
        r1 = VarDateFromStr(temp, 0, #LOCALE_NOUSEROVERRIDE, @datum)
        *pResult\d = datum
      Else
        r1 = #E_FAIL
        *pResult\d = 0.0
      EndIf
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadDateString(*ItemObject.udtItem, *pResult, Size.l, *pQuality.long = 0)

  ;- OpcReadDateString(*ItemObject.udtItem, *pResult, Size.l, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as String
  ;-- Param3: Size Of pResult as int32
  ;-- Param4: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  Protected temp.s, len
  Protected *pbstrOut
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG  
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      If \pItemResults\vtCanonicalDataType = #VT_DATE
        r1 = VarBstrFromDate(\pItemValues\vDataValue\dblVal, $0407, #LOCALE_NOUSEROVERRIDE, @*pbstrOut)
        If r1 = #S_OK
          temp = PeekS(*pbstrOut, #PB_Any, #PB_Unicode)
          SysFreeString_(*pbstrOut)
        EndIf
      ElseIf \pItemResults\vtCanonicalDataType = #VT_BSTR
        temp = PeekS(\pItemValues\vDataValue\bstrVal)
      Else
        r1 = #E_FAIL
        temp = ""
      EndIf
      len = Len(temp)
      If len <= size
        PokeS(*pResult, temp, len, #PB_Unicode)
        PokeL(*pResult - 4, len)
      Else
        PokeS(*pResult, temp, size, #PB_Unicode)
        PokeL(*pResult - 4, size)
      EndIf
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadString(*ItemObject.udtItem, *pResult, Size.l, *pQuality.long = 0)

  ;- OpcReadString(*ItemObject.udtItem, *pResult, Size.l, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as String
  ;-- Param3: Size Of pResult as int32
  ;-- Param4: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected result.Variant
  Protected temp.s,len
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn OpcLastError
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      r1 = VariantChangeType(result, \pItemValues\vDataValue, 4, #VT_BSTR)
      If r1 = #S_OK
        temp = PeekS(result\bstrVal)
        len = Len(temp)
        If len <= size
          PokeS(*pResult, temp, len, #PB_Unicode)
        Else
          PokeS(*pResult, temp, size, #PB_Unicode)
        EndIf
      EndIf
      VariantClear(result)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadVariant(*ItemObject.udtItem, *pResult.Variant, *pQuality.long = 0)

  ;- OpcReadVariant(*ItemObject.udtItem, *pResult.Variant, *pQuality.long = 0)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Pointer to pResult as Variant
  ;-- Param3: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn OpcLastError
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, 1, @\pItemResults\hServer, @\pItemValues, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
      If *pQuality
        *pQuality\l = 0
      EndIf
    ElseIf r1 = #S_OK
      If *pQuality
        *pQuality\l = \pItemValues\wQuality
      EndIf
      VariantClear(*pResult)
      r1 = VariantCopy_(*pResult, \pItemValues\vDataValue)
      VariantClear(\pItemValues\vDataValue)
    EndIf
    CoTaskMemFree(\pItemValues)
    CoTaskMemFree(\pErrors)
    
  EndWith    
  
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************


ProcedureDLL.l OpcWriteBool(*ItemObject.udtItem, value.l)

  ;- OpcWriteBool(*ItemObject.udtItem, value.l)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as int32
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  value1\vt = #VT_BOOL
  If value
    value1\boolVal = #VARIANT_TRUE
  Else
    value1\boolVal = #VARIANT_FALSE
  EndIf
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type <> #VT_BOOL
    r1 = VariantChangeType(value1, value1, #LOCALE_NOUSEROVERRIDE, type)
    If r1 <> #S_OK
      VariantClear(value1)
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteByte(*ItemObject.udtItem, value.b)

  ;- OpcWriteByte(*ItemObject.udtItem, value.b)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as Byte
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  value1\vt = #VT_I1
  value1\bVal = value
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type <> #VT_I1
    r1 = VariantChangeType(value1, value1, #LOCALE_NOUSEROVERRIDE, type)
    If r1 <> #S_OK
      VariantClear(value1)
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteWord(*ItemObject.udtItem, value.w)

  ;- OpcWriteWord(*ItemObject.udtItem, value.w)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as Word
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  value1\vt = #VT_I2
  value1\iVal = value
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type <> #VT_I2
    r1 = VariantChangeType(value1, value1, #LOCALE_NOUSEROVERRIDE, type)
    If r1 <> #S_OK
      VariantClear(value1)
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteLong(*ItemObject.udtItem, value.l)

  ;- OpcWriteLong(*ItemObject.udtItem, value.l)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as int32
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  value1\vt = #VT_I4
  value1\lVal = value
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type <> #VT_I4
    r1 = VariantChangeType(value1, value1, #LOCALE_NOUSEROVERRIDE, type)
    If r1 <> #S_OK
      VariantClear(value1)
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteFloat(*ItemObject.udtItem, value.f)

  ;- OpcWriteFloat(*ItemObject.udtItem, value.f)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as Float
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  value1\vt = #VT_R4
  value1\fltVal = value
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type <> #VT_R4
    r1 = VariantChangeType(value1, value1, #LOCALE_NOUSEROVERRIDE, type)
    If r1 <> #S_OK
      VariantClear(value1)
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteDouble(*ItemObject.udtItem, value.d)

  ;- OpcWriteDouble(*ItemObject.udtItem, value.d)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as Double
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  value1\vt = #VT_R8
  value1\dblVal = value
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type <> #VT_R8
    r1 = VariantChangeType(value1, value1, #LOCALE_NOUSEROVERRIDE, type)
    If r1 <> #S_OK
      VariantClear(value1)
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteDate(*ItemObject.udtItem, value.d)

  ;- OpcWriteDate(*ItemObject.udtItem, value.d)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as Date (Double)
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type, datum.s
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type = #VT_DATE
    value1\vt = #VT_DATE
    value1\dblVal = value
  ElseIf type = #VT_BSTR
    ; Inat OPC DateTime anpassung
    datum = SqlDateStrFromDate(value)
    value1\vt = #VT_BSTR
    value1\bstrVal = SysAllocString_(datum)
  Else
    OpcLastError = #E_INVALIDARG
    ProcedureReturn OpcLastError
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteDateString(*ItemObject.udtItem, value.s)

  ;- OpcWriteDateString(*ItemObject.udtItem, value.s)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as Date String
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant, type
  Protected datum.d
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *ItemObject\pItemResults\vtCanonicalDataType = #VT_DATE
    r1 = VarDateFromStr(value, 0, #LOCALE_NOUSEROVERRIDE, @datum)
    If r1 <> #S_OK
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
    value1\vt = #VT_DATE
    value1\dblVal = datum
  Else
    value1\vt = #VT_BSTR
    value1\bstrVal = SysAllocString_(value)
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteString(*ItemObject.udtItem, value.s)

  ;- OpcWriteString(*ItemObject.udtItem, value.s)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as String
  ;-- Result: hResult
  
  Protected r1
  Protected value1.variant
  Protected type
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  value1\vt = #VT_BSTR
  value1\bstrVal = SysAllocString_(value)
  type = *ItemObject\pItemResults\vtCanonicalDataType
  If type <> #VT_BSTR
    r1 = VariantChangeType(value1, value1, #LOCALE_NOUSEROVERRIDE, type)
    If r1 <> #S_OK
      VariantClear(value1)
      OpcLastError = r1
      ProcedureReturn r1
    EndIf
  EndIf
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, value1, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  VariantClear(value1)
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteVariant(*ItemObject.udtItem, *pValue.Variant)

  ;- OpcWriteVariant(*ItemObject.udtItem, *pValue.Variant)
  ;-- Param1: ItemObject as Pointer
  ;-- Param2: Value as Variant
  ;-- Result: hResult

  Protected r1
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pValue = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  With *ItemObject
    r1 = \GroupObject\m_pIOPCSyncIO\Write(1, @\pItemResults\hServer, *pValue, @\pErrors)
    If r1 = #S_FALSE
      r1 = \pErrors\l
    EndIf
    CoTaskMemFree(\pErrors)
  EndWith
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

ProcedureDLL.l OpcReadItems(ItemCount.l, *ItemObject.udtItemArray, *pResult.udtVariantArray, *pQuality.udtQualityArray, *pErrors.udtErrorsArray)

  ;- OpcReadItems(ItemCount.l, *ItemObject.udtItemArray, *pResult.udtVariantArray, *pQuality.udtQualityArray, *pErrors.udtErrorsArray)
  ;-- Param1: ItemCount as int32
  ;-- Param2: Pointer to ItemObject as int32
  ;-- Param3: Pointer to pResult as Variant
  ;-- Param4: Pointer to pQuality as int32
  ;-- Param5: Pointer to pQuality as int32
  ;-- Result: hResult
  
  Protected r1
  Protected *m_pIOPCSyncIO.IOPCSyncIO, *IOPCSyncIO
  Protected id
  Protected *pItemValues.udtItemValuesArray
  Protected *pItemErrors.udtErrorsArray
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pQuality = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pErrors = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn OpcLastError
  EndIf
  
  If *ItemObject\index[0] = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  ; hServer list zusammenstellen
  Dim hServer.l(ItemCount)
  ; SycronIO von ersten Item
  *m_pIOPCSyncIO = *ItemObject\index[0]\GroupObject\m_pIOPCSyncIO
  For id = 0 To ItemCount - 1
    If *ItemObject\index[id] = 0
      OpcLastError = #E_INVALIDARG
      ProcedureReturn #E_INVALIDARG
    EndIf
    *IOPCSyncIO = *ItemObject\index[id]\GroupObject\m_pIOPCSyncIO
    If *IOPCSyncIO = *m_pIOPCSyncIO
      hServer(id) = *ItemObject\index[id]\pItemResults\hServer
    Else
      OpcLastError = #OPC_E_INVALIDHANDLE
      ProcedureReturn #OPC_E_INVALIDHANDLE
    EndIf
  Next
  ; Items lesen
  r1 = *m_pIOPCSyncIO\Read(#OPC_DS_DEVICE, ItemCount, hServer(), @*pItemValues, @*pItemErrors)
  If r1 <> #S_OK And r1 <> #S_FALSE
    CoTaskMemFree(*pItemValues)
    CoTaskMemFree(*pItemErrors)
    OpcLastError = r1
    ProcedureReturn r1
  EndIf
  ; Values kopieren
  LockMutex(OpcMutex)
  For id = 0 To ItemCount - 1
    VariantClear(*pResult\index[id])
    VariantCopy_(*pResult\index[id], *pItemValues\index[id]\vDataValue)
    VariantClear(*pItemValues\index[id]\vDataValue)
    *pQuality\index[id] = *pItemValues\index[id]\wQuality
    *pErrors\index[id] = *pItemErrors\index[id]
  Next
  UnlockMutex(OpcMutex)
  ; Speicher freigeben
  CoTaskMemFree(*pItemValues)
  CoTaskMemFree(*pItemErrors)
    
  OpcLastError = r1
  ProcedureReturn r1

EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcReadItemArray(ItemCount.l, *ItemObject.variant, *pResult.variant, *pQuality.variant, *pErrors.variant)

  ;- OpcReadItemArray(ItemCount.l, ItemCount.l, *ItemObject.variant, *pResult.variant, *pQuality.variant, *pErrors.variant)
  ;-- Param1: ItemCount as int32
  ;-- Param2: ItemObject as Array of int32 (Object)
  ;-- Param3: pResult as Array of Variant (Object)
  ;-- Param4: pQuality as Array of int32 (Object)
  ;-- Param5: pErrors as Array of int32 (Object)
  ;-- Result: hResult as int32
  
  Protected *psa_ItemObject.safearray, *psa_pResult.safearray, *psa_pQuality.safearray, *psa_pErrors.safearray
  Protected r1
  
  ; Test Pointer auf Variant
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pQuality = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pErrors = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  ; Test auf Variant Type
  If *ItemObject\vt <> (#VT_ARRAY | #VT_I4)
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pResult\vt <> (#VT_ARRAY | #VT_VARIANT)
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pQuality\vt <> (#VT_ARRAY | #VT_I4)
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pErrors\vt <> (#VT_ARRAY | #VT_I4)
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  ; Safearray
  *psa_ItemObject = *itemObject\parray
  *psa_pResult = *pResult\parray
  *psa_pQuality = *pQuality\parray
  *psa_pErrors = *pErrors\parray
  
  If *psa_ItemObject\rgsabound[0]\cElements < ItemCount
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *psa_pResult\rgsabound[0]\cElements < ItemCount
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *psa_pQuality\rgsabound[0]\cElements < ItemCount
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *psa_pErrors\rgsabound[0]\cElements < ItemCount
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  r1 = OpcReadItems(ItemCount, *psa_ItemObject\pvdata, *psa_pResult\pvData, *psa_pQuality\pvData, *psa_pErrors\pvdata)
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteItems(ItemCount, *ItemObject.udtItemArray, *pValues.udtVariantArray, *pErrors.udtErrorsArray)

  ;- OpcWriteItems(ItemCount, *ItemObject.udtItemArray, *pValues.udtVariantArray, *pErrors.udtErrorsArray)
  ;-- Param1: ItemCount as int32
  ;-- Param2: ItemObject as Array of Pointer
  ;-- Param3: pValue as Array of Variant
  ;-- Param4: pErrors as Array of int32
  ;-- Result: hResult as int32

  Protected r1, id, type
  Protected *m_pIOPCSyncIO.IOPCSyncIO, *IOPCSyncIO
  Protected *pItemErrors.udtErrorsArray
  Protected datum.s
  
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pValues = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pErrors = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *ItemObject\index[0] = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  ; hServer list zusammenstellen
  Dim hServer.l(ItemCount)
  ; SycronIO von ersten Item
  *m_pIOPCSyncIO = *ItemObject\index[0]\GroupObject\m_pIOPCSyncIO
  For id = 0 To ItemCount - 1
    If *ItemObject\index[id] = 0
      OpcLastError = #E_INVALIDARG
      ProcedureReturn #E_INVALIDARG
    EndIf
    *IOPCSyncIO = *ItemObject\index[id]\GroupObject\m_pIOPCSyncIO
    If *IOPCSyncIO = *m_pIOPCSyncIO
      hServer(id) = *ItemObject\index[id]\pItemResults\hServer
    Else
      OpcLastError = #OPC_E_INVALIDHANDLE
      ProcedureReturn #OPC_E_INVALIDHANDLE
    EndIf
  Next
  
  ; Typenanpassung
  LockMutex(OpcMutex)
  Dim Values.Variant(ItemCount)
  For id = 0 To ItemCount - 1
    type = *ItemObject\index[id]\pItemResults\vtCanonicalDataType
    If *pValues\index[id]\vt & #VT_ARRAY = #VT_ARRAY
      r1 = VariantCopy_(Values(id), *pValues\index[id])
    Else
      If type <> *pValues\index[id]\vt
        If type = #VT_BSTR And *pValues\index[id]\vt = #VT_DATE
          ; Inat OPC DateTime anpassung
          datum = SqlDateStrFromDate(*pValues\index[id]\dblVal)
          Values(id)\vt = #VT_BSTR
          Values(id)\bstrVal = SysAllocString_(datum)
        Else
          r1 = VariantChangeType(Values(id), *pValues\index[id], #LOCALE_NOUSEROVERRIDE, type)
        EndIf
      Else
        r1 = VariantCopy_(Values(id), *pValues\index[id])
      EndIf
    EndIf
  Next
  UnlockMutex(OpcMutex)
    
  r1 = *m_pIOPCSyncIO\Write(ItemCount, hServer(), Values(), @*pItemErrors)
  If *pItemErrors
    CopyMemory(*pItemErrors, *pErrors, Itemcount * 4)
    CoTaskMemFree(*pItemErrors)
  EndIf
  ; Speicher freigeben
  For id = 0 To ItemCount - 1
    VariantClear(Values(id))
  Next
  
  OpcLastError = r1
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcWriteItemArray(ItemCount, *ItemObject.variant, *pValues.variant, *pErrors.variant)

  ;- OpcWriteItemArray(ItemCount, *ItemObject.variant, *pValues.variant, *pErrors.variant)
  ;-- Param1: ItemCount as int32
  ;-- Param2: ItemObject as Array of int32 (Object)
  ;-- Param3: pResult as Array of Variant (Object)
  ;-- Param4: pErrors as Array of int32 (Object)
  ;-- Result: hResult as int32
 
  Protected *psa_ItemObject.safearray, *psa_pValues.safearray, *psa_pErrors.safearray
  Protected r1
  
  ; Test Pointer auf Variant
  If *ItemObject = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pValues = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pErrors = 0
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  ; Test auf Variant Type
  If *ItemObject\vt <> (#VT_ARRAY | #VT_I4)
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pValues\vt <> (#VT_ARRAY | #VT_VARIANT)
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *pErrors\vt <> (#VT_ARRAY | #VT_I4)
    OpcLastError = #E_INVALIDARG
    ProcedureReturn OpcLastError
  EndIf
  
  ; Safearray
  *psa_ItemObject = *itemObject\parray
  *psa_pValues = *pValues\parray
  *psa_pErrors = *pErrors\parray
  
  If *psa_ItemObject\rgsabound[0]\cElements < ItemCount
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *psa_pValues\rgsabound[0]\cElements < ItemCount
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  If *psa_pErrors\rgsabound[0]\cElements < ItemCount
    OpcLastError = #E_INVALIDARG
    ProcedureReturn #E_INVALIDARG
  EndIf
  
  r1 = OpcWriteItems(ItemCount, *psa_ItemObject\pvdata, *psa_pValues\pvData, *psa_pErrors\pvdata)
  ProcedureReturn r1
  
EndProcedure

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

ProcedureDLL.l OpcGetItemUserData(*ItemObject.udtItem)

  ;-- Param1: ItemObject as Pointer
  ;-- Result: ItemData as int32

  If *ItemObject = 0
    ProcedureReturn 0
  Else
    ProcedureReturn *ItemObject\ItemData
  EndIf
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL.l OpcSetItemUserData(*ItemObject.udtItem, ItemData.l)

  ;-- Param1: ItemObject as Pointer
  ;-- Param2: ItemData as int32
  ;-- Result: Previous ItemData as int32

  Protected OldItemData.l
  
  If *ItemObject = 0
    ProcedureReturn 0
  Else
    OldItemData = *ItemObject\ItemData
    *ItemObject\ItemData = ItemData
    ProcedureReturn OldItemData
  EndIf
  
EndProcedure

; *********************************************************************************************************

;------------------------------------------------

; *********************************************************************************************************

ProcedureDLL.l OpcGetItemDataType(*ItemObject.udtItem)

  ;-- Param1: ItemObject as Pointer
  ;-- Result: vtCanonicalDataType as int32

  If *ItemObject = 0
    ProcedureReturn 0
  Else
    ProcedureReturn *ItemObject\pItemResults\vtCanonicalDataType
  EndIf
  
EndProcedure

; *********************************************************************************************************

; *********************************************************************************************************

;------------------------------------------------
;- Shutdown Functions
;-

; *********************************************************************************************************

Import "uuid.lib"
  IID_IUnknown
  IID_IConnectionPointContainer
EndImport

; *********************************************************************************************************


; *********************************************************************************************************

ProcedureDLL.l OpcInitShutdown(*ServerObject.udtServer)

  ;- OpcInitShutdown(*ServerObject)
  ;-- Param1: ServerObject as pointer
  ;-- Result: ServerObject as pointer or zero by fault
  
  Protected *m_pIOPCServer.IOPCServer
  Protected ShutdownCookie 
  Protected *object.udtShutdown
  Protected *ServerConnectionPointContainer.IConnectionPointContainer
  Protected *ServerConnectionPoint.IConnectionPoint
  Protected r1
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  *m_pIOPCServer = *ServerObject\m_pIOPCServer
  
  r1 = *m_pIOPCServer\QueryInterface(@IID_IConnectionPointContainer, @*ServerConnectionPointContainer)
  If r1 <> #S_OK
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  r1 = *ServerConnectionPointContainer\FindConnectionPoint(?IID_IOPCShutdown, @*ServerConnectionPoint)
  If r1 <> #S_OK
    *ServerConnectionPointContainer\Release()
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  ; Objekt anlegen
  *object = AllocateMemory(SizeOf(udtShutdown))
  With *object
    \VTable = ?Shutdown_Procedures
    \Memory = *object
    \Cookie = 0
    \ShutdownRef = 0
  EndWith
  r1 = *ServerConnectionPoint\Advise(*object, @ShutdownCookie)
  If r1 = #S_OK
    *object\Server = *m_pIOPCServer
    *object\Cookie = ShutdownCookie
  Else
    *ServerConnectionPoint\Release()
    *ServerConnectionPointContainer\Release()
    FreeMemory(*object)
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  OpcLastError = 0
  
  *ServerConnectionPoint\Release()
  *ServerConnectionPointContainer\Release()
  
  *ServerObject\ShutdownObject = *object
  UnlockMutex(OpcMutex)
  ProcedureReturn *ServerObject
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL OpcReleaseShutdown(*ServerObject.udtServer)

  ;- OpcReleaseShutdown(*ServerObject)
  ;-- Param1: ServerObject as pointer
  ;-- Result: Ok = 0 - Shutdown Object = Fail
  
  Protected *Object.udtShutdown
  Protected *ServerConnectionPointContainer.IConnectionPointContainer
  Protected *ServerConnectionPoint.IConnectionPoint
  Protected r1
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  *Object = *ServerObject\ShutdownObject
  If *object = 0
    OpcLastError = #E_POINTER
    UnlockMutex(OpcMutex)
    ProcedureReturn #E_POINTER
  EndIf
  
  r1 = *ServerObject\m_pIOPCServer\QueryInterface(@IID_IConnectionPointContainer, @*ServerConnectionPointContainer)
  If r1 <> #S_OK
    FreeMemory(*object\Memory)
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn r1
  EndIf
  
  r1 = *ServerConnectionPointContainer\FindConnectionPoint(?IID_IOPCShutdown, @*ServerConnectionPoint)
  If r1 <> #S_OK
    *ServerConnectionPointContainer\Release()
    FreeMemory(*object\Memory)
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn r1
  EndIf
  
  r1 = *ServerConnectionPoint\UnAdvise(*object\Cookie)
  If r1 <> #S_OK
    *ServerConnectionPoint\Release()
    *ServerConnectionPointContainer\Release()
    *object\szReason\text = ""
    *object\szReason\len = 0
    FreeMemory(*object\Memory)
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn r1
  EndIf
  
  OpcLastError = 0
  
  FreeMemory(*object\Memory)
  *ServerConnectionPoint\Release()
  *ServerConnectionPointContainer\Release()
  
  *ServerObject\ShutdownObject = 0
  UnlockMutex(OpcMutex)
  ProcedureReturn 0
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL OpcIsShutdown(*ServerObject.udtServer)

  ;- OpcIsShutdown(*ServerObject)
  ;-- Param1: Shutdown Object as pointer
  ;-- Result: True is shutdown request
  
  Protected r1
  Protected *Object.udtShutdown
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  *Object = *ServerObject\ShutdownObject
  If *object = 0
    OpcLastError = #E_POINTER
    UnlockMutex(OpcMutex)
    ProcedureReturn #E_POINTER
  EndIf
  
  UnlockMutex(OpcMutex)
  ProcedureReturn *object\IsShutdown
  
EndProcedure

; *********************************************************************************************************


  
ProcedureDLL.l OpcIsShutdownText(*ServerObject.udtServer)

  ;- OpcIsShutdownText(*ServerObject)
  ;-- Param1: Shutdown Object as pointer
  ;-- Result: Shutdown Text as String
  
  Static vbResult.vbString
  
  Protected r1
  Protected *Object.udtShutdown
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  *Object = *ServerObject\ShutdownObject
  If *object = 0
    OpcLastError = #E_POINTER
    UnlockMutex(OpcMutex)
    ProcedureReturn #E_POINTER
  EndIf
  
  vbResult\len = Len(vbResult\text)
  UnlockMutex(OpcMutex)
  ProcedureReturn @vbResult\text
  
EndProcedure

; *********************************************************************************************************

ProcedureDLL OpcSetShutdownCallBack(*ServerObject.udtServer, *Callback)
  
  ;- OpcSetShutdownCallBack(*ServerObject, *Callback)
  ;-- Param1: Shutdown Object as pointer
  ;-- Param2: Callback function adress (MyCallback(*szReason.s))
  ;-- Result: Old callback adress

  Protected OldCallback.i
  Protected r1
  Protected *Object.udtShutdown
  
  LockMutex(OpcMutex)
  r1 = ValidServerObject(*ServerObject)
  If r1
    OpcLastError = r1
    UnlockMutex(OpcMutex)
    ProcedureReturn 0
  EndIf
  
  *Object = *ServerObject\ShutdownObject
  If *object = 0
    OpcLastError = #E_POINTER
    UnlockMutex(OpcMutex)
    ProcedureReturn #E_POINTER
  EndIf
  
  OldCallback = *object\Callback
  *object\Callback = *Callback
  ProcedureReturn OldCallback
  
EndProcedure

; *********************************************************************************************************

Procedure IShutdown_QueryInterface(*this, *riid.iid, *addr)

  Protected *ppv.IUnknown
  
  *ppv.IUnknown = #Null
  If CompareMemory(*riid, @IID_IUnknown, SizeOf(iid)) Or CompareMemory(*riid, ?IID_IOPCShutdown, SizeOf(iid))
    *ppv = *this
    PokeL(*addr, *this) 
  EndIf
  
  If *ppv <> #Null
    *ppv\Addref()
    ;Debug "QueryInterface Ok"
    ProcedureReturn #S_OK; #NOERROR
  Else
    ;Debug "QueryInterface No Interface"
    ProcedureReturn #E_NOINTERFACE
  EndIf
EndProcedure

; ***************************************************************************************

Procedure IShutdown_Addref(*this)

  Protected *object.udtShutdown
  
  *object = *this
  *object\ShutdownRef + 1
  
  ;Debug "Addref: " + Str(*object\ShutdownRef) 
  
  ProcedureReturn *object\ShutdownRef
  
EndProcedure

; ***************************************************************************************

Procedure IShutdown_Release(*this)

  Protected *object.udtShutdown
  
  *object = *this
  
  If *object\ShutdownRef
    *object\ShutdownRef - 1
  EndIf
  
  ;Debug "Release: " + Str(*object\ShutdownRef)
  
  If *object\ShutdownRef <= 0
    *object\ShutdownRef = 0
  EndIf
  
  ProcedureReturn *object\ShutdownRef
  
EndProcedure

; ***************************************************************************************

Procedure IShutdown_Request(*this, *szReason)

  Protected *object.udtShutdown
  Protected result
  
  ;Debug "ShutdownRequest: " + PeekS(*szReason)
  
  *object = *this
  *object\IsShutdown = #True
  *object\szReason\text = PeekS(*szReason)
  *object\szReason\len = Len(*object\szReason\text)
  If *object\Callback <> 0
    CallFunctionFast(*Object\Callback, @*object\szReason\text)
  EndIf 
  ProcedureReturn #S_OK
  
EndProcedure

; ***************************************************************************************

DataSection
  Shutdown_Procedures:
  Data.l @IShutdown_QueryInterface()
  Data.l @IShutdown_Addref()
  Data.l @IShutdown_Release()
  Data.l @IShutdown_Request()
EndDataSection


; ***************************************************************************************

DisableExplicit

Re: OPC interface for PB as open source

Posted: Sat Jul 09, 2016 2:38 pm
by step11
Great code,thanks for sharing.

Re: OPC interface for PB as open source

Posted: Sat Jul 09, 2016 6:48 pm
by bbanelli
mk-soft, sorry for being Google lazy, but can you name several use cases for this interface? I guess it's not compatible with CAN bus and such in cars and similar machines, for example? What is its most common usage than?

Re: OPC interface for PB as open source

Posted: Sat Jul 09, 2016 10:51 pm
by Demivec
What version of PureBasic should it be compiled with and is it compatible with 64-bit or 32-bit? I'm guessing it would only be compatible with 32-bit.

I ask because I notice that it uses native types with the pointers found in structures and some of these are type '.i' and some '.l' . The pointers for functions are also stored in the data section as longs.

Re: OPC interface for PB as open source

Posted: Sun Jul 10, 2016 11:07 am
by mk-soft
The code is for that have to do with the industry.

Wiki: https://en.wikipedia.org/wiki/Open_Plat ... unications

So far I only know OPC server in 32bit mode as Siemens, Inat, Rockwell, etc.
Thus, the OPC client must also be compiled in 32 bit mode.

:wink:

Re: OPC interface for PB as open source

Posted: Sun Jul 24, 2016 10:43 pm
by QuimV
:D
Great code mk-soft,
Thanks a lot for sharing the source.
It runs like a charm!

:) Have you experience in ModBus (RTU / TCP) communication?
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited