////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// OPC client library.                                                        //
// Of course, user may write OPC clients using _OPC definitions directly,     //
// but it will be very uneasy. Client library may be used in more easy way.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20051017 - Creation (A.K.), testing                                        //
// 20060221 - Bug fixed in SetConnected (add SetStdHandle(xxx,0))             //
// 20100831 - Bug fixed in OnCancelComplete header; HostID,ProgID,ClassID     //
// 20230826 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_opcc; // OPC client library

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}
{$WARN 5028 off : Local $1 "$2" is not used}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF WINDOWS} comobj, activex, variants, varutils, {$ENDIF}
 sysutils, classes,
 _crw_alloc, _crw_dynar, _crw_str, _crw_fio, _crw_opc;

{$IFDEF WINDOWS}
 //
 // Classes for easy OPC client creation.
 //
type
 EOpcError = class(Exception);
 //
 // Forward declarations needed due to cross references.
 //
 TOpcClientItem = class;
 TOpcClientGroup = class;
 TOpcCustomClient = class;
 //
 // OPC Client Item
 // Uses as member of TOpcClientGroup only.
 //
 TOpcClientItem = class(TMasterObject)
 private
  myOwner     : TOpcClientGroup; // Group for which Item belong to
  myItemID    : LongString;      // Item identifier (name)
  myhServer   : OPCHANDLE;       // Item server handle for OPC calls
  myDataType  : TVarType;        // Data canonocal type
  myTimeStamp : TFileTime;       // UTC time when data was actual
  myDataValue : OleVariant;      // Current data value
  myQuality   : Word;            // Current data quality
  myDataError : HResult;         // Error code from I/O calls
  myActive    : BOOL;            // Is item active
  myTags      : array[0..3] of OleVariant;   // Custom tags associated with Item
  function    GetOwner:TOpcClientGroup;
  function    GetItemID:LongString;
  function    GetFullName:LongString;
  procedure   SetReport(const msg:LongString);
  function    GethClient:OPCHANDLE;
  function    GethServer:OPCHANDLE;
  function    GetDataType:TVarType;
  function    GetTimeStamp:TFileTime;
  function    GetDataValue:OleVariant;
  function    GetQuality:Word;
  function    GetGoodQuality:Boolean;
  function    GetDataError:HResult;
  function    GetActive:Boolean;
  function    GetTag(i:Integer):OleVariant;
  procedure   SetTag(i:Integer; aTag:OleVariant);
 public
  // Construction/destrunction
  constructor Create(aOwner:TOpcClientGroup; const aItemID:LongString; aActive:Boolean);
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  // Properties
  property    Owner            : TOpcClientGroup read   GetOwner;
  property    ItemID           : LongString      read   GetItemID;
  property    FullName         : LongString      read   GetFullName;
  property    Report           : LongString      write  SetReport;
  property    hClient          : OPCHANDLE       read   GethClient;
  property    hServer          : OPCHANDLE       read   GethServer;
  property    DataType         : TVarType        read   GetDataType;
  property    TimeStamp        : TFileTime       read   GetTimeStamp;
  property    DataValue        : OleVariant      read   GetDataValue;
  property    Quality          : Word            read   GetQuality;
  property    GoodQuality      : Boolean         read   GetGoodQuality;
  property    DataError        : HResult         read   GetDataError;
  property    Active           : Boolean         read   GetActive;
  property    Tag[i:Integer]   : OleVariant      read   GetTag write SetTag;
 public
  // Synchronous read/write (single item)
  function    SyncRead(dwSource:Word=OPC_DS_CACHE):HResult;
  function    SyncWrite(ItemValue:OleVariant):HResult;
 end;
 //
 // Opc Client Item List
 //
 TOpcClientItemList = class(TObjectStorage)
 private
  function GetOpcClientItem(i:Integer):TOpcClientItem;
 public
  property OpcClientItem[i:Integer]:TOpcClientItem read GetOpcClientItem; default;
 end;
 //
 // OPC Client group
 // Uses as member of TOpcCustomClient only.
 //
 TOpcClientGroup = class(TMasterObject)
 private
  myOwner           : TOpcCustomClient;    // OPC client for which group belong to
  myGroupIf         : IOPCItemMgt;         // Group interface
  myGroupID         : LongString;          // Group identifier (name)
  myhServer         : OPCHANDLE;           // Group server handle for OPC calls
  myOpcItems        : TOpcClientItemList;  // List of OPC items belong to this group
  myActive          : BOOL;                // Is group active
  myUpdateRate      : DWORD;               // In milliseconds
  myPercentDeadBand : Single;              // Dead band for this group
  myConnection1     : LongWord;            // IDataObject   connection -> IAdviseSink
  myConnection2     : LongWord;            // IDataCallback connection -> OnDataChange
  myTransaction1    : DWORD;               // Transaction ID for Refresh1
  myTransaction2    : DWORD;               // Transaction ID for Refresh2
  myTags            : array[0..3] of OleVariant;   // Extra data associated with Group
  function    GetOwner:TOpcCustomClient;
  function    GetGroupID:LongString;
  function    GetFullName:LongString;
  procedure   SetReport(const msg:LongString);
  function    GethClient:OPCHANDLE;
  function    GethServer:OPCHANDLE;
  function    GetOpcItems:TOpcClientItemList;
  function    GetLastItem:TOpcClientItem;
  function    GetActive:Boolean;
  function    GetUpdateRate:DWORD;
  function    GetPercentDeadBand:Single;
  function    GetConnection1:LongInt;
  function    GetConnection2:LongInt;
  function    GetTransaction1:DWORD;
  function    GetTransaction2:DWORD;
  function    Advise1(aFormat:Integer=0):HResult;
  function    UnAdvise1:HResult;
  function    Advise2:HResult;
  function    Unadvise2:HResult;
  function    Refresh1(dwSource:Word=OPC_DS_CACHE):HResult;
  function    Refresh2(dwSource:Word=OPC_DS_CACHE):HResult;
  function    GetTag(i:Integer):OleVariant;
  procedure   SetTag(i:Integer; aTag:OleVariant);
 public
  // Construction/destrunction
  constructor Create(aOwner:TOpcCustomClient; const aGroupID:LongString; aActive:Boolean);
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  // Properties
  function    GroupIf          : IOPCItemMgt;
  property    Owner            : TOpcCustomClient   read  GetOwner;
  property    GroupID          : LongString         read  GetGroupID;
  property    FullName         : LongString         read  GetFullName;
  property    Report           : LongString         write SetReport;
  property    hClient          : OPCHANDLE          read  GethClient;
  property    hServer          : OPCHANDLE          read  GethServer;
  property    OpcItems         : TOpcClientItemList read  GetOpcItems;
  property    LastItem         : TOpcClientItem     read  GetLastItem;
  property    Active           : Boolean            read  GetActive;
  property    UpdateRate       : DWORD              read  GetUpdateRate;
  property    PercentDeadBand  : Single             read  GetPercentDeadBand;
  property    Connection1      : LongInt            read  GetConnection1;
  property    Connection2      : LongInt            read  GetConnection2;
  property    Transaction1     : DWORD              read  GetTransaction1;
  property    Transaction2     : DWORD              read  GetTransaction2;
  property    Tag[i:Integer]   : OleVariant         read  GetTag   write SetTag;
 public
  // Utility
  function    AddItem(aItemID   : LongString;
                      aActive   : Boolean  = true;
                      aDataType : TVarType = VT_EMPTY
                              ) : HResult;
 public
  // Asyncronous I/O; aMode is 1=AdviseSink, 2=DataCallback
  function    Advise(aMode:Integer=0;aFormat:Integer=0):HResult;
  procedure   UnAdvise(aMode:Integer=0);
  function    Refresh(aMode:Integer=0;dwSource:Word=OPC_DS_CACHE):HResult;
 end;
 //
 // OPC Client Group List
 //
 TOpcClientGroupList = class(TObjectStorage)
 private
  function GetOpcClientGroup(i:Integer):TOpcClientGroup;
 public
  property OpcClientGroup[i:Integer]:TOpcClientGroup read GetOpcClientGroup; default;
 end;
 //
 // OPC client adise sink, for internal use only.
 //
 TOpcClientAdviseSink = class(TInterfacedObject, IAdviseSink)
 private
  myOwner   : TOpcCustomClient;
  function    GetOwner:TOpcCustomClient;
  procedure   SetReport(const msg:LongString);
 public
  // Construction/destrunction
  constructor Create(aOwner:TOpcCustomClient);
  destructor  Destroy; override;
 public
  // Properties
  property    Owner  : TOpcCustomClient read  GetOwner;
  property    Report : LongString       write SetReport;
 public
  // IAdviseSink methods
  procedure OnDataChange(const formatetc:TFormatEtc; const stgmed:TStgMedium); stdcall;
  procedure OnViewChange(dwAspect:Longword; lindex:Longint); stdcall;
  procedure OnRename(const mk: IMoniker); stdcall;
  procedure OnSave; stdcall;
  procedure OnClose; stdcall;
 end;
 //
 // OPC client DataCallback, for internal use only.
 //
 TOpcClientDataCallback = class(TInterfacedObject, IOPCDataCallback)
 private
  myOwner : TOpcCustomClient;
  function    GetOwner:TOpcCustomClient;
  procedure   SetReport(const msg:LongString);
 public
  // Construction/destrunction
  constructor Create(aOwner:TOpcCustomClient);
  destructor  Destroy; override;
 public
  // Properties
  property    Owner  : TOpcCustomClient read  GetOwner;
  property    Report : LongString       write SetReport;
 public
  // IOPCDataCallback methods
  function    OnDataChange(
               dwTransid       : DWORD;
               hGroup          : OPCHANDLE;
               hrMasterquality : HResult;
               hrMastererror   : HResult;
               dwCount         : DWORD;
               phClientItems   : POPCHANDLEARRAY;
               pvValues        : POleVariantArray;
               pwQualities     : PWordArray;
               pftTimeStamps   : PFileTimeArray;
               pErrors         : PResultList
                             ) : HResult; stdcall;
  function    OnReadComplete(
               dwTransid       : DWORD;
               hGroup          : OPCHANDLE;
               hrMasterquality : HResult;
               hrMastererror   : HResult;
               dwCount         : DWORD;
               phClientItems   : POPCHANDLEARRAY;
               pvValues        : POleVariantArray;
               pwQualities     : PWordArray;
               pftTimeStamps   : PFileTimeArray;
               pErrors         : PResultList
                             ) : HResult; stdcall;
  function    OnWriteComplete(
               dwTransid      : DWORD;
               hGroup         : OPCHANDLE;
               hrMastererr    : HResult;
               dwCount        : DWORD;
               pClienthandles : POPCHANDLEARRAY;
               pErrors        : PResultList
                            ) : HResult; stdcall;
  function    OnCancelComplete(
               dwTransid : DWORD;
               hGroup    : OPCHANDLE
                       ) : HResult; stdcall;
 end;
 //
 // OPC client
 //
 TOpcCustomClient = class(TMasterObject)
 private
  myHostID         : LongString;
  myProgID         : LongString;
  myClassID        : LongString;
  myServerID       : LongString;
  myServerIf       : IOPCServer;
  myDataCallbackIf : IOPCDataCallback;
  myAdviseSinkIf   : IAdviseSink;
  myOpcGroups      : TOpcClientGroupList;
  function    GetHostID:LongString;
  function    GetProgID:LongString;
  function    GetClassID:LongString;
  function    GetServerID:LongString;
  procedure   SetReport(const msg:LongString);
  function    GetOpcGroups:TOpcClientGroupList;
  function    GetConnected:Boolean;
  procedure   SetConnected(aConnected:Boolean);
  function    GetLastGroup:TOpcClientGroup;
 public
  // Construction/destrunction
  // ServerID may be ProgID,ClassID,\\HostID\ProgID or \\HostID\ClassID
  // Examples: Matrikon.OPC.Simulation.1
  //           {F8582CF2-88FB-11D0-B850-00C0F0104305}
  //           \\localhost\Matrikon.OPC.Simulation.1
  //           \\localhost\{F8582CF2-88FB-11D0-B850-00C0F0104305}
  //           \\remotesrv\{F8582CF2-88FB-11D0-B850-00C0F0104305}
  constructor Create(const aServerID         : LongString;
                           aInitDComSecurity : Boolean = false;
                           aConnect          : Boolean = false);
  destructor  Destroy; override;
 public
  // Properties
  function    ServerIf       : IOPCServer;
  function    AdviseSinkIf   : IAdviseSink;
  function    DataCallbackIf : IOPCDataCallback;
  property    Connected      : Boolean             read  GetConnected write SetConnected;
  property    HostID         : LongString          read  GetHostID;
  property    ProgID         : LongString          read  GetProgID;
  property    ClassID        : LongString          read  GetClassID;
  property    ServerID       : LongString          read  GetServerID;
  property    Report         : LongString          write SetReport;
  property    OpcGroups      : TOpcClientGroupList read  GetOpcGroups;
  property    LastGroup      : TOpcClientGroup     read  GetLastGroup;
 public
  // Utility functions
  function    AddGroup(aGroupID         : LongString;
                       aActive          : BOOL   = True;
                       aUpdateRate      : DWORD  = 1000;
                       aPercentDeadBand : Single = 0):HResult;
  function    AdviseAll(aMode:Integer=0;aFormat:Integer=0):Integer;
  procedure   UnAdviseAll(aMode:Integer=0);
  function    RefreshAll(aMode:Integer=0;dwSource:Word=OPC_DS_CACHE):Integer;
 public
  // Virtual methods to override in descendants
  procedure   OnReport(const msg:LongString); virtual;
  function    OnDataChange(
                     dwTransid       : DWORD;
               const OpcGroup        : TOpcClientGroup;
                     hrMasterQuality : HResult;
                     hrMasterError   : HResult;
               const OpcItems        : array of TOpcClientItem
                                   ) : HResult; virtual;
  function    OnReadComplete(
                     dwTransid       : DWORD;
               const OpcGroup        : TOpcClientGroup;
                     hrMasterQuality : HResult;
                     hrMasterError   : HResult;
               const OpcItems        : array of TOpcClientItem
                                ) : HResult; virtual;
  function    OnWriteComplete(
                     dwTransid       : DWORD;
               const OpcGroup        : TOpcClientGroup;
                     hrMasterError   : HResult;
               const OpcItems        : array of TOpcClientItem
                                   ) : HResult; virtual;
  function    OnCancelComplete(
                     dwTransid  : DWORD;
               const Group      : TOpcClientGroup
                              ) : HResult; virtual;
  procedure   OnViewChange(dwAspect:Longint; lindex:Longint); virtual;
  procedure   OnRename(const mk: IMoniker); virtual;
  procedure   OnSave; virtual;
  procedure   OnClose; virtual;
 end;

type
 TOpcReport = (
  rp_OpcException,rp_OpcInitDComSecurity,rp_OpcConnect,rp_OpcDisconnect,
  rp_OpcItemKill,rp_OpcItemAdd,rp_OpcItemWrite,rp_OpcItemRead,
  rp_OpcGroupKill,rp_OpcGroupAdd,rp_OpcGroupAdvise,rp_OpcGroupUnadvise,
  rp_OpcGroupRefresh
  );

const
 OpcReportSet : set of TOpcReport = [
  rp_OpcException,rp_OpcInitDComSecurity,rp_OpcConnect,rp_OpcDisconnect,
  rp_OpcItemKill,rp_OpcItemAdd,
  rp_OpcGroupKill,rp_OpcGroupAdd,rp_OpcGroupAdvise,rp_OpcGroupUnadvise
  ];

 ///////////////////
 // Utility routines
 ///////////////////

procedure Kill(var TheObject:TOpcClientItem); overload;
procedure Kill(var TheObject:TOpcClientGroup); overload;

 // Standard DCOM security initialization with default parameters.
function StdDComInitSecurity:HResult;

 // Get executable file path by given ServerID. Works only for localhost servers.
function GetComServerExecutable(const ServerID:LongString):LongString;

{$ENDIF ~WINDOWS}

implementation

{$IFDEF WINDOWS}

 ////////////////////
 // Utility functions
 ////////////////////

function IsLocalHost(const HostID:LongString):Boolean;
begin
 Result:=IsEmptyStr(HostID)
      or IsSameText(HostID,'.')
      or IsSameText(HostID,'localhost')
      or IsSameText(HostID,'127.0.0.1')
      or IsSameText(HostID,HostName(0))
      or IsSameText(HostID,HostName(1))
      or IsSameText(HostID,GetIpAddress)
      or IsSameText(HostID,ComputerName);
end;

 // Example: {F8582CF3-88FB-11D0-B850-00C0F0104305} for Matrikon.OPC.Simulation.1
function IsClassID(S:LongString):Boolean;
var G:TGUID;
begin
 Result:=False;
 try
  S:=Trim(S);
  if Pos('{',S)<>1 then Exit;
  if Pos('}',S)<>Length(S) then Exit;
  if Length(S)<>SizeOf(TGUID)*2+6 then Exit;
  if not IsSameText(Copy(S,10,1),'-') then Exit;
  if not IsSameText(Copy(S,15,1),'-') then Exit;
  if not IsSameText(Copy(S,20,1),'-') then Exit;
  if not IsSameText(Copy(S,25,1),'-') then Exit;
  G:=StringToGUID(S);
  if (G.ToString<>'')
  then Result:=True;
 except
  on E:Exception do Result:=False;
 end;
end;

procedure InterpretServerID(OpcClient:TOpcCustomClient; var ServerID,HostID,ProgID,ClassID:LongString);
var i:Integer;
 procedure AssignHidCidPid(const HID,PID:LongString);
 begin
  HostID:=HID;
  if IsClassID(PID) then begin
   ClassID:=PID; ProgID:=ClassIDToProgID(StringToGUID(PID));
  end else begin
   ProgID:=PID; ClassID:=GUIDToString(ProgIDToClassID(PID));
  end;
 end;
 procedure Report(const s:LongString);
 begin
  if Assigned(OpcClient) then OpcClient.Report:=s else Echo(s);
 end;
begin
 try
  HostID:='?';
  ProgID:='?'; 
  ClassID:='?';
  ServerID:=Trim(ServerID);
  if IsSameText(Copy(ServerID,1,2),'\\') then begin
   i:=Pos('\',Copy(ServerID,3,Length(ServerID)-2))+2;
   if (Length(ServerID)>4) and (i>3) and (i<Length(ServerID))
   then AssignHidCidPid(Copy(ServerID,3,i-3),Copy(ServerID,i+1,Length(ServerID)-i+1))
   else AssignHidCidPid('',ServerID);
  end else AssignHidCidPid('',ServerID);
  if IsLocalHost(HostID) then HostID:='localhost';
 except
  on E:Exception do Report(Format('%s: %s',[E.ClassName,E.Message]));
 end;
end;

function Var2Str(OpcClient:TOpcCustomClient; data:OleVariant):String;
var i,lo,hi:Integer;
 procedure Report(const s:LongString);
 begin
  if Assigned(OpcClient) then OpcClient.Report:=s else Echo(s);
 end;
begin
 Result:='';
 try
  if VarIsNull(data) then Result:='NULL' else
  if VarIsEmpty(data) then Result:='EMPTY' else
  if not VarIsArray(data) then Result:=VarToStr(data) else begin
   lo:=VarArrayLowBound(data,1);
   hi:=VarArrayHighBound(data,1);
   for i:=lo to hi do begin
    if i>lo then Result:=Result+',';
    Result:=Result+Var2Str(OpcClient,data[i]);
   end;
   Result:='('+Result+')';
  end;
 except
  on E:Exception do begin Report(Format('%s: %s',[E.ClassName,E.Message])); Result:='?'; end;
 end;
end;

 ////////////////////////////////
 // TOpcClientItem implementation
 ////////////////////////////////
constructor TOpcClientItem.Create(aOwner:TOpcClientGroup; const aItemID:LongString; aActive:Boolean);
begin
 inherited Create;
 myOwner:=aOwner;
 myActive:=aActive;
 myItemID:=Trim(aItemID);
end;

destructor TOpcClientItem.Destroy;
var
 i      : Integer;
 HR     : HResult;
 Errors : PResultList;
begin
 if hServer<>0 then
 if Owner.myGroupIf <> nil then begin
  HR:=Owner.myGroupIf.RemoveItems(1, @myhServer, Errors);
  if Succeeded(HR) then begin
   HR:=Errors[0];
   CoTaskMemFree(Errors);
  end;
  if rp_OpcItemKill in OpcReportSet then
  if Succeeded(HR)
  then Report:=Format('Kill OPC item %s',[FullName])
  else Report:=Format('Unable to kill OPC item %s, ErrorCode=$%8.8x',[FullName,HR]);
 end;
 for i:=Low(myTags) to High(myTags) do VarClear(myTags[i]);
 VarClear(myDataValue);
 Finalize(myItemID);
 inherited;
end;

procedure TOpcClientItem.AfterConstruction;
begin
 inherited;
 Owner.OpcItems.Add(Self);
end;

procedure TOpcClientItem.BeforeDestruction;
var
 Owns  : Boolean;
 Index : Integer;
begin
 Owner.OpcItems.Lock;
 try
  Index:=Owner.OpcItems.IndexOf(Self);
  if Index>=0 then begin
   Owns:=Owner.OpcItems.OwnsObjects;
   Owner.OpcItems.OwnsObjects:=false;
   Owner.OpcItems.Delete(Index);
   Owner.OpcItems.OwnsObjects:=Owns;
  end;
 finally
  Owner.OpcItems.UnLock;
 end;
 inherited;
end;

function TOpcClientItem.GetOwner:TOpcClientGroup;
begin
 if Assigned(Self)
 then Result:=myOwner
 else Result:=nil;
end;

function TOpcClientItem.GetItemID:LongString;
begin
 if Assigned(Self)
 then Result:=myItemID
 else Result:='';
end;

function TOpcClientItem.GetFullName:LongString;
begin
 if Assigned(Self)
 then Result:=Format('%s:%s',[Owner.FullName,ItemID])
 else Result:='';
end;

procedure TOpcClientItem.SetReport(const msg:LongString);
begin
 Owner.Report:=msg;
end;

function TOpcClientItem.GethClient:OPCHANDLE;
begin
 if Assigned(Self)
 then Result:=OPCHANDLE(Self.Ref)
 else Result:=0;
end;

function TOpcClientItem.GethServer:OPCHANDLE;
begin
 if Assigned(Self)
 then Result:=myhServer
 else Result:=0;
end;

function TOpcClientItem.GetDataType:TVarType;
begin
 if Assigned(Self)
 then Result:=myDataType
 else Result:=VT_EMPTY;
end;

function TOpcClientItem.GetTimeStamp:TFileTime;
const
 Zero : Int64 = 0;
begin
 if Assigned(Self)
 then Result:=myTimeStamp
 else Result:=TFileTime(Zero);
end;

function TOpcClientItem.GetDataValue:OleVariant;
begin
 if Assigned(Self)
 then Result:=myDataValue
 else Result:=Unassigned;
end;

function TOpcClientItem.GetQuality:Word;
begin
 if Assigned(Self)
 then Result:=myQuality
 else Result:=OPC_QUALITY_BAD;
end;

function TOpcClientItem.GetGoodQuality:Boolean;
begin
 if Assigned(Self)
 then Result:=((myQuality and OPC_QUALITY_MASK)=OPC_QUALITY_GOOD)
 else Result:=false;
end;

function TOpcClientItem.GetDataError:HResult;
begin
 if Assigned(Self)
 then Result:=myDataError
 else Result:=E_FAIL;
end;

function TOpcClientItem.GetActive:Boolean;
begin
 if Assigned(Self)
 then Result:=myActive
 else Result:=False;
end;

function TOpcClientItem.GetTag(i:Integer):OleVariant;
begin
 if Assigned(Self) and (i>=Low(myTags)) and (i<=High(myTags))
 then Result:=myTags[i]
 else Result:=Unassigned;
end;

procedure TOpcClientItem.SetTag(i:Integer; aTag:OleVariant);
begin
 if Assigned(Self) and (i>=Low(myTags)) and (i<=High(myTags))
 then myTags[i]:=aTag;
end;

function TOpcClientItem.SyncWrite(ItemValue:OleVariant):HResult;
var
 Errors   : PResultList;
 SyncIOIf : IOPCSyncIO;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if Owner.myGroupIf <> nil then
 try
  try
   SyncIOIf:=Owner.myGroupIf as IOPCSyncIO;
  except
   on E:Exception do begin
    SyncIOIf:=nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if SyncIOIf <> nil then begin
   Result:=SyncIOIf.Write(1, @myhServer, @ItemValue, Errors);
   if Succeeded(Result) then begin
    Result:=Errors[0];
    CoTaskMemFree(Errors);
   end;
   if Succeeded(Result) then begin
    myDataValue:=ItemValue;
    myQuality:=OPC_QUALITY_GOOD;
    GetSystemTimeAsFileTime(myTimeStamp);
    myDataError:=Result;
   end;
  end;
  if rp_OpcItemWrite in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Write OPC item %s = %s',[FullName,Var2Str(Owner.Owner,ItemValue)])
  else Report:=Format('Unable to write OPC item %s = %s, ErrorCode=$%8.8x',[FullName,Var2Str(Owner.Owner,ItemValue),Result]);
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientItem.SyncRead(dwSource:Word):HResult;
var
 SyncIOIf   : IOPCSyncIO;
 Errors     : PResultList;
 ItemValues : POPCITEMSTATEARRAY;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if Owner.myGroupIf <> nil then
 try
  try
   SyncIOIf := Owner.myGroupIf as IOPCSyncIO;
  except
   on E:Exception do begin
    SyncIOIf := nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if SyncIOIf <> nil then begin
   Result := SyncIOIf.Read(dwSource, 1, @myhServer, ItemValues, Errors);
   if Succeeded(Result) then begin
    Result := Errors[0];
    myDataValue := ItemValues[0].vDataValue;
    myQuality := ItemValues[0].wQuality;
    myTimeStamp := ItemValues[0].ftTimeStamp;
    myDataError := Result;
    ItemValues[0].vDataValue:=Unassigned;
    CoTaskMemFree(ItemValues);
    CoTaskMemFree(Errors);
   end;
  end;
  if rp_OpcItemRead in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Read OPC item %s = %s, Quality=%d.',[FullName,Var2Str(Owner.Owner,DataValue),Quality])
  else Report:=Format('Unable to read OPC item %s, ErrorCode=$%8.8x',[FullName,Result]);
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

 ////////////////////////////////////
 // TOpcClientItemList implementation
 ////////////////////////////////////
function TOpcClientItemList.GetOpcClientItem(i:Integer):TOpcClientItem;
begin
 TObject(Result):=Items[i];
 if not (TObject(Result) is TOpcClientItem) then Result:=nil;
end;

 /////////////////////////////////
 // TOpcClientGroup implementation
 /////////////////////////////////
constructor TOpcClientGroup.Create(aOwner:TOpcCustomClient; const aGroupID:LongString; aActive:Boolean);
begin
 inherited Create;
 myOwner:=aOwner;
 myActive:=aActive;
 myGroupID:=Trim(aGroupID);
 myOpcItems:=TOpcClientItemList.Create;
 myOpcItems.Master:=@myOpcItems;
end;

destructor TOpcClientGroup.Destroy;
var
 i  : Integer;
 HR : HResult;
begin
 Unadvise;
 OpcItems.Free;
 if hServer<>0 then
 if Owner.myServerIf <> nil then begin
  HR:=Owner.myServerIf.RemoveGroup(hServer,False);
  if rp_OpcGroupKill in OpcReportSet then
  if Succeeded(HR)
  then Report:=Format('Kill OPC group %s',[FullName])
  else Report:=Format('Unable to kill OPC group %s, ErrorCode=$%8.8x',[FullName,HR]);
 end;
 for i:=Low(myTags) to High(myTags) do VarClear(myTags[i]);
 Finalize(myGroupID);
 myGroupIf:=nil;
 inherited;
end;

procedure TOpcClientGroup.AfterConstruction;
begin
 inherited;
 Owner.OpcGroups.Add(Self);
end;

procedure TOpcClientGroup.BeforeDestruction;
var
 Owns  : Boolean;
 Index : Integer;
begin
 Owner.OpcGroups.Lock;
 try
  Index:=Owner.OpcGroups.IndexOf(Self);
  if Index>=0 then begin
   Owns:=Owner.OpcGroups.OwnsObjects;
   Owner.OpcGroups.OwnsObjects:=false;
   Owner.OpcGroups.Delete(Index);
   Owner.OpcGroups.OwnsObjects:=Owns;
  end;
 finally
  Owner.OpcGroups.UnLock;
 end;
 inherited;
end;

function TOpcClientGroup.GetOwner:TOpcCustomClient;
begin
 if Assigned(Self)
 then Result:=myOwner
 else Result:=nil;
end;

function TOpcClientGroup.GroupIf:IOPCItemMgt;
begin
 if Assigned(Self)
 then Result:=myGroupIf
 else Result:=nil;
end;

function TOpcClientGroup.GetGroupID:LongString;
begin
 if Assigned(Self)
 then Result:=myGroupID
 else Result:='';
end;

function TOpcClientGroup.GetFullName:LongString;
begin
 if Assigned(Self)
 then Result:=Format('%s:%s',[Owner.ServerID,GroupID])
 else Result:='';
end;

procedure TOpcClientGroup.SetReport(const msg:LongString);
begin
 Owner.Report:=msg;
end;

function TOpcClientGroup.GethClient:OPCHANDLE;
begin
 if Assigned(Self)
 then Result:=OPCHANDLE(Self.Ref)
 else Result:=0;
end;

function TOpcClientGroup.GethServer:OPCHANDLE;
begin
 if Assigned(Self)
 then Result:=myhServer
 else Result:=0;
end;

function TOpcClientGroup.GetOpcItems:TOpcClientItemList;
begin
 if Assigned(Self)
 then Result:=myOpcItems
 else Result:=nil;
end;

function TOpcClientGroup.GetLastItem:TOpcClientItem;
begin
 if Assigned(Self)
 then Result:=OpcItems[OpcItems.Count-1]
 else Result:=nil;
end;

function TOpcClientGroup.GetActive:Boolean;
begin
 if Assigned(Self)
 then Result:=myActive
 else Result:=False;
end;

function TOpcClientGroup.GetUpdateRate:DWORD;
begin
 if Assigned(Self)
 then Result:=myUpdateRate
 else Result:=0;
end;

function TOpcClientGroup.GetPercentDeadBand:Single;
begin
 if Assigned(Self)
 then Result:=myPercentDeadBand
 else Result:=0;
end;

function TOpcClientGroup.GetConnection1:LongInt;
begin
 if Assigned(Self)
 then Result:=myConnection1
 else Result:=0;
end;

function TOpcClientGroup.GetConnection2:LongInt;
begin
 if Assigned(Self)
 then Result:=myConnection2
 else Result:=0;
end;

function TOpcClientGroup.GetTransaction1:DWORD;
begin
 if Assigned(Self)
 then Result:=myTransaction1
 else Result:=0;
end;

function TOpcClientGroup.GetTransaction2:DWORD;
begin
 if Assigned(Self)
 then Result:=myTransaction2
 else Result:=0;
end;

function TOpcClientGroup.GetTag(i:Integer):OleVariant;
begin
 if Assigned(Self) and (i>=Low(myTags)) and (i<=High(myTags))
 then Result:=myTags[i]
 else Result:=Unassigned;
end;

procedure TOpcClientGroup.SetTag(i:Integer; aTag:OleVariant);
begin
 if Assigned(Self) and (i>=Low(myTags)) and (i<=High(myTags))
 then myTags[i]:=aTag;
end;

function TOpcClientGroup.AddItem(aItemID:LongString; aActive:Boolean; aDataType:TVarType):HResult;
var
 Item    : TOpcClientItem;
 ItemDef : OPCITEMDEF;
 Results : POPCITEMRESULTARRAY;
 Errors  : PResultList;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myGroupIf <> nil then
 try
  Item:=TOpcClientItem.Create(Self,aItemID,aActive);
  try
   with ItemDef do begin
    szAccessPath := '';
    szItemID := PWideChar(WideString(Item.ItemID));
    bActive := Item.Active;
    hClient := Item.hClient;
    dwBlobSize := 0;
    pBlob := nil;
    vtRequestedDataType := aDataType;
   end;
   Result := myGroupIf.AddItems(1, @ItemDef, Results, Errors);
   if Succeeded(Result) then begin
    Result := Errors[0];
    try
     if Succeeded(Result) then begin
      Item.myhServer:=Results[0].hServer;
      Item.myDataType:=Results[0].vtCanonicalDataType;
      Item:=nil; // Mark that item should not free
     end;
    finally
     CoTaskMemFree(Results[0].pBlob);
     CoTaskMemFree(Results);
     CoTaskMemFree(Errors);
    end;
   end;
   if rp_OpcItemAdd in OpcReportSet then
   if Succeeded(Result)
   then Report:=Format('Add OPC item %s:%s',[FullName,aItemID])
   else Report:=Format('Unable to add OPC item %s:%s, ErrorCode=$%8.8x',[FullName,aItemID,Result]);
  finally
   Item.Free;
  end;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientGroup.Advise1(aFormat:Integer): HResult;
var
 Fmt    : TFormatEtc;
 DataIf : IDataObject;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myGroupIf <> nil then
 if myConnection1 = 0 then
 if Owner.myAdviseSinkIf <> nil then
 try
  try
   DataIf:=myGroupIf as IDataObject;
  except
   on E:Exception do begin
    DataIf:=nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if DataIf <> nil then begin
   with Fmt do begin
    case  aFormat of
     1:   cfFormat := OPCSTMFORMATDATA;
     2:   cfFormat := OPCSTMFORMATDATATIME;
     3:   cfFormat := OPCSTMFORMATWRITECOMPLETE;
     else cfFormat := OPCSTMFORMATDATATIME;
    end;
    dwAspect := DVASPECT_CONTENT;
    ptd := nil;
    tymed := TYMED_HGLOBAL;
    lindex := -1;
   end;
   Result := DataIf.DAdvise(Fmt, ADVF_PRIMEFIRST, Owner.myAdviseSinkIf, myConnection1);
  end;
  if rp_OpcGroupAdvise in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Advise1 group %s, connection %d',[GroupID,Connection1])
  else Report:=Format('Unable to advise1 group %s, ErrorCode=$%8.8x',[GroupID,Result]);
  if Failed(Result) then myConnection1:=0;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientGroup.UnAdvise1:HResult;
var
  DataIf: IDataObject;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myGroupIf <> nil then
 if myConnection1 <> 0 then
 try
  try
   DataIf:=myGroupIf as IDataObject;
  except
   on E:Exception do begin
    DataIf:=nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if DataIf <> nil then Result:=DataIf.DUnadvise(Connection1);
  if rp_OpcGroupUnadvise in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Unadvise1 group %s, connection %d',[GroupID,Connection1])
  else Report:=Format('Unable to unadvise1 group %s, connection %d, ErrorCode=$%8.8x',[GroupID,Connection1,Result]);
  myConnection1:=0;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientGroup.Advise2:HResult;
var
 ConnectionPoint          : IConnectionPoint;
 ConnectionPointContainer : IConnectionPointContainer;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myGroupIf <> nil then
 if myConnection2 = 0 then
 if Owner.myDataCallbackIf <> nil then
 try
  try
   ConnectionPointContainer := myGroupIf as IConnectionPointContainer;
  except
   on E:Exception do begin
    ConnectionPointContainer := nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if ConnectionPointContainer <> nil then begin
   Result := ConnectionPointContainer.FindConnectionPoint(IID_IOPCDataCallback,
                                                          ConnectionPoint);
   if Succeeded(Result) and (ConnectionPoint <> nil)
   then Result := ConnectionPoint.Advise(Owner.myDataCallbackIf as IUnknown,
                                         myConnection2);
  end;
  if rp_OpcGroupAdvise in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Advise2 group %s, connection %d',[GroupID,Connection2])
  else Report:=Format('Unable to advise2 group %s, ErrorCode=$%8.8x',[GroupID,Result]);
  if Failed(Result) then myConnection2:=0;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientGroup.Unadvise2:HResult;
var
 ConnectionPoint          : IConnectionPoint;
 ConnectionPointContainer : IConnectionPointContainer;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myGroupIf <> nil then
 if myConnection2 <> 0 then
 try
  try
   ConnectionPointContainer := myGroupIf as IConnectionPointContainer;
  except
   on E:Exception do begin
    ConnectionPointContainer := nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if ConnectionPointContainer <> nil then begin
   Result := ConnectionPointContainer.FindConnectionPoint(IID_IOPCDataCallback,
                                                          ConnectionPoint);
   if Succeeded(Result) and (ConnectionPoint <> nil)
   then Result := ConnectionPoint.Unadvise(Connection2);
  end;
  if rp_OpcGroupUnadvise in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Unadvise2 group %s, connection %d',[GroupID,Connection2])
  else Report:=Format('Unable to unadvise2 group %s, connection %d, ErrorCode=$%8.8x',[GroupID,Connection2,Result]);
  myConnection2:=0;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientGroup.Advise(aMode:Integer; aFormat:Integer):HResult;
begin
 case aMode of
  1: Result:=Advise1(aFormat);
  2: Result:=Advise2;
  else begin
   Result:=Advise2;
   if Failed(Result) then Result:=Advise1(aFormat);
  end;
 end;
end;

procedure TOpcClientGroup.UnAdvise(aMode:Integer);
begin
 case aMode of
  1: Unadvise1;
  2: Unadvise2;
  else begin
   Unadvise1;
   Unadvise2;
  end;
 end;
end;

function TOpcClientGroup.Refresh1(dwSource:Word):HResult;
var
 AsyncIOIf : IOPCAsyncIO;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myGroupIf <> nil then
 if myConnection1 <> 0 then
 if Owner.myAdviseSinkIf <> nil then
 try
  try
   AsyncIOIf:=myGroupIf as IOPCAsyncIO;
  except
   on E:Exception do begin
    AsyncIOIf:=nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if AsyncIOIf <> nil then begin
   Result := AsyncIOIf.Refresh(Connection1, dwSource, myTransaction1);
  end;
  if rp_OpcGroupRefresh in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Refresh1 group %s, transaction %d',[GroupID,Transaction1])
  else Report:=Format('Unable to refresh1 group %s, ErrorCode=$%8.8x',[GroupID,Result]);
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientGroup.Refresh2(dwSource:Word):HResult;
var
 AsyncIO2If      : IOPCAsyncIO2;
 pdwCancelID     : DWORD;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myGroupIf <> nil then
 if myConnection2 <> 0 then
 if Owner.myDataCallbackIf <> nil then
 try
  try
   AsyncIO2If:=myGroupIf as IOPCAsyncIO2;
  except
   on E:Exception do begin
    AsyncIO2If:=nil;
    if rp_OpcException in OpcReportSet
    then Report:=Format('%s: %s',[ClassName,E.Message]);
   end;
  end;
  if AsyncIO2If <> nil then begin
   Inc(myTransaction2);
   if myTransaction2 = 0 then Inc(myTransaction2); // avoid zero ID
   Result := AsyncIO2If.Refresh2(dwSource, myTransaction2, pdwCancelID);
  end;
  if rp_OpcGroupRefresh in OpcReportSet then
  if Succeeded(Result)
  then Report:=Format('Refresh2 group %s',[GroupID])
  else Report:=Format('Unable to refresh2 group %s, ErrorCode=$%8.8x',[GroupID,Result]);
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientGroup.Refresh(aMode:Integer; dwSource:Word):HResult;
begin
 case aMode of
  1: Result:=Refresh1(dwSource);
  2: Result:=Refresh2(dwSource);
  else begin
   Result:=Refresh1(dwSource);
   if Failed(Result) then Result:=Refresh2(dwSource);
  end;
 end;
end;

 /////////////////////////////////////
 // TOpcClientGroupList implementation
 /////////////////////////////////////
function TOpcClientGroupList.GetOpcClientGroup(i:Integer):TOpcClientGroup;
begin
 TObject(Result):=Items[i];
 if not (TObject(Result) is TOpcClientGroup) then Result:=nil;
end;

 //////////////////////////////////////
 // TOpcClientAdviseSink implementation
 //////////////////////////////////////
constructor TOpcClientAdviseSink.Create(aOwner:TOpcCustomClient);
begin
 inherited Create;
 myOwner:=aOwner;
end;

destructor TOpcClientAdviseSink.Destroy;
begin
 inherited;
end;

function TOpcClientAdviseSink.GetOwner:TOpcCustomClient;
begin
 if Assigned(Self)
 then Result:=myOwner
 else Result:=nil;
end;

procedure TOpcClientAdviseSink.SetReport(const msg:LongString);
begin
 Owner.Report:=msg;
end;

procedure TOpcClientAdviseSink.OnDataChange(const formatetc:TFormatEtc; const stgmed:TStgMedium);
var
 i        : Integer;
 pGroup   : POPCGROUPHEADER;
 pItem1   : POPCITEMHEADER1ARRAY;
 pItem2   : POPCITEMHEADER2ARRAY;
 pValue   : POleVariant;
 hClient  : OPCHANDLE;
 wQuality : Word;
 UseTime  : Boolean;
 TimeStmp : TFileTime;
 Clients  : array of TOpcClientItem;
begin
 if Assigned(Self) then
 try
  //
  // the rest of this method assumes that the item header array uses
  // OPCITEMHEADER1 or OPCITEMHEADER2 records, so check this first to be defensive
  //
  if formatetc.cfFormat = OPCSTMFORMATDATA     then UseTime:=False else
  if formatetc.cfFormat = OPCSTMFORMATDATATIME then UseTime:=True  else Exit;
  pGroup:=GlobalLock(stgmed.hGlobal);
  if Assigned(pGroup) then
  try
   Clients:=nil;
   // we will only use one of these two values, according to whether UseTime is set:
   pItem1 := Pointer(PChar(pGroup) + SizeOf(OPCGROUPHEADER));
   pItem2 := Pointer(PChar(pGroup) + SizeOf(OPCGROUPHEADER));
   if Succeeded(pGroup.hrStatus) then begin
    SetLength(Clients,pGroup.dwItemCount);
    try
     if pGroup.dwItemCount>0 then
     for i:=0 to pGroup.dwItemCount-1 do begin
      if UseTime then begin
       hClient  := pItem1[i].hClient;
       pValue   := POleVariant(PChar(pGroup) + pItem1[i].dwValueOffset);
       wQuality := pItem1[i].wQuality;
       TimeStmp := pItem1[i].ftTimeStampItem;
      end else begin
       hClient  := pItem2[i].hClient;
       pValue   := POleVariant(PChar(pGroup) + pItem2[i].dwValueOffset);
       wQuality := pItem2[i].wQuality;
       GetSystemTimeAsFileTime(TimeStmp);
      end;
      Clients[i]:=ObjectRegistry[hClient] as TOpcClientItem;
      with Clients[i] do begin
       if TVarData(pValue^).VType <> VT_BSTR
       then myDataValue:=pValue^
       else begin
        // for BSTR data, the BSTR image follows immediately in the data
        // stream after the variant union;  the BSTR begins with a DWORD
        // character count, which we skip over as the BSTR is also
        // NULL-terminated
        myDataValue:=WideString(PWideChar(PChar(pValue)+SizeOf(OleVariant)+4));
       end;
       myQuality:=wQuality;
       myTimeStamp:=TimeStmp;
       myDataError:=pGroup.hrStatus;
      end;
     end;
     Owner.OnDataChange(pGroup.dwTransactionID,ObjectRegistry[pGroup.hClientGroup] as TOpcClientGroup,
                        pGroup.hrStatus,pGroup.hrStatus,Clients);
    finally
     Finalize(Clients);
    end;
   end;
  finally
   GlobalUnlock(stgmed.hGlobal);
  end;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

procedure TOpcClientAdviseSink.OnViewChange(dwAspect: LongWord; lindex: Longint);
begin
 try
  Owner.OnViewChange(dwAspect,lindex);
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

procedure TOpcClientAdviseSink.OnRename(const mk: IMoniker);
begin
 try
  Owner.OnRename(mk);
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

procedure TOpcClientAdviseSink.OnSave;
begin
 try
  Owner.OnSave;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

procedure TOpcClientAdviseSink.OnClose;
begin
 try
  Owner.OnClose;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

 ////////////////////////////////////////
 // TOpcClientDataCallback implementation
 ////////////////////////////////////////
constructor TOpcClientDataCallback.Create(aOwner:TOpcCustomClient);
begin
 inherited Create;
 myOwner:=aOwner;
end;

destructor TOpcClientDataCallback.Destroy;
begin
 inherited;
end;

function TOpcClientDataCallback.GetOwner:TOpcCustomClient;
begin
 if Assigned(Self)
 then Result:=myOwner
 else Result:=nil;
end;

procedure TOpcClientDataCallback.SetReport(const msg:LongString);
begin
 Owner.Report:=msg;
end;

function TOpcClientDataCallback.OnDataChange(dwTransid: DWORD; hGroup: OPCHANDLE;
  hrMasterquality: HResult; hrMastererror: HResult; dwCount: DWORD;
  phClientItems: POPCHANDLEARRAY; pvValues: POleVariantArray;
  pwQualities: PWordArray; pftTimeStamps: PFileTimeArray;
  pErrors: PResultList): HResult;
var
 i       : Integer;
 Clients : array of TOpcClientItem;
begin
 Result:=E_FAIL;
 if Assigned(Self) then
 try
  Clients:=nil;
  SetLength(Clients,dwCount);
  try
   if dwCount>0 then
   for i:=0 to dwCount-1 do begin
    Clients[i]:=ObjectRegistry[phClientItems[i]] as TOpcClientItem;
    with Clients[i] do begin
     myDataValue:=pvValues[i];
     myQuality:=pwQualities[i];
     myTimeStamp:=pftTimeStamps[i];
     myDataError:=pErrors[i];
    end;
   end;
   Result:=Owner.OnDataChange(dwTransid,ObjectRegistry[hGroup] as TOpcClientGroup,
                              hrMasterQuality,hrMasterError,Clients);
  finally
   Finalize(Clients);
  end;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientDataCallback.OnReadComplete(dwTransid: DWORD; hGroup: OPCHANDLE;
  hrMasterquality: HResult; hrMastererror: HResult; dwCount: DWORD;
  phClientItems: POPCHANDLEARRAY; pvValues: POleVariantArray;
  pwQualities: PWordArray; pftTimeStamps: PFileTimeArray;
  pErrors: PResultList): HResult;
var
 i       : Integer;
 Clients : array of TOpcClientItem;
begin
 Result:=E_FAIL;
 if Assigned(Self) then
 try
  Clients:=nil;
  SetLength(Clients,dwCount);
  try
   if dwCount>0 then
   for i:=0 to dwCount-1 do begin
    Clients[i]:=ObjectRegistry[phClientItems[i]] as TOpcClientItem;
    with Clients[i] do begin
     myDataValue:=pvValues[i];
     myQuality:=pwQualities[i];
     myTimeStamp:=pftTimeStamps[i];
     myDataError:=pErrors[i];
    end;
   end;
   Result:=Owner.OnReadComplete(dwTransid,ObjectRegistry[hGroup] as TOpcClientGroup,
                                hrMasterQuality,hrMasterError,Clients);
  finally
   Finalize(Clients);
  end;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientDataCallback.OnWriteComplete(dwTransid: DWORD; hGroup: OPCHANDLE;
  hrMastererr: HResult; dwCount: DWORD; pClienthandles: POPCHANDLEARRAY;
  pErrors: PResultList): HResult;
var
 i       : Integer;
 Clients : array of TOpcClientItem;
begin
 Result:=E_FAIL;
 if Assigned(Self) then
 try
  Clients:=nil;
  SetLength(Clients,dwCount);
  try
   if dwCount>0 then
   for i:=0 to dwCount-1 do begin
    Clients[i]:=ObjectRegistry[pClienthandles[i]] as TOpcClientItem;
    Clients[i].myDataError:=pErrors[i];
   end;
   Result:=Owner.OnWriteComplete(dwTransid,ObjectRegistry[hGroup] as TOpcClientGroup,
                                 hrMastererr,Clients);
  finally
   Finalize(Clients);
  end;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcClientDataCallback.OnCancelComplete(dwTransid: DWORD;
  hGroup: OPCHANDLE): HResult;
begin
 Result:=E_FAIL;
 if Assigned(Self) then
 try
  Result:=Owner.OnCancelComplete(dwTransid,ObjectRegistry[hGroup] as TOpcClientGroup);
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

 //////////////////////////////////
 // TOpcCustomClient implementation
 //////////////////////////////////
constructor TOpcCustomClient.Create(const aServerID:LongString;
                                    aInitDComSecurity:Boolean;
                                    aConnect:Boolean);
var
 HR : HResult;
begin
 inherited Create;
 myOpcGroups:=TOpcClientGroupList.Create;
 myOpcGroups.Master:=@myOpcGroups;
 if aInitDComSecurity then begin
  HR:=StdDComInitSecurity;
  if rp_OpcInitDComSecurity in OpcReportSet then
  if Succeeded(HR)
  then Report:='Init DCOM security'
  else Report:=Format('Unable to init DCOM security, ErrorCode=$%8.8x',[HR]);
 end;
 myServerID:=Trim(aServerID);
 InterpretServerID(Self,myServerID,myHostID,myProgID,myClassID);
 if aConnect then Connected:=(Length(ServerID)>0);
end;

destructor TOpcCustomClient.Destroy;
begin
 OpcGroups.Free;
 Connected:=false;
 Finalize(myServerID);
 inherited;
end;

function TOpcCustomClient.GetHostID:LongString;
begin
 if Assigned(Self)
 then Result:=myHostID
 else Result:='';
end;

function TOpcCustomClient.GetProgID:LongString;
begin
 if Assigned(Self)
 then Result:=myProgID
 else Result:='';
end;

function TOpcCustomClient.GetClassID:LongString;
begin
 if Assigned(Self)
 then Result:=myClassID
 else Result:='';
end;

function TOpcCustomClient.GetServerID:LongString;
begin
 if Assigned(Self)
 then Result:=myServerID
 else Result:='';
end;

procedure TOpcCustomClient.SetReport(const msg:LongString);
begin
 if Assigned(Self) then OnReport(msg);
end;

function TOpcCustomClient.ServerIf:IOPCServer;
begin
 if Assigned(Self)
 then Result:=myServerIf
 else Result:=nil;
end;

function TOpcCustomClient.DataCallbackIf:IOPCDataCallback;
begin
 if Assigned(Self)
 then Result:=myDataCallbackIf
 else Result:=nil;
end;

function TOpcCustomClient.AdviseSinkIf:IAdviseSink;
begin
 if Assigned(Self)
 then Result:=myAdviseSinkIf
 else Result:=nil;
end;

function TOpcCustomClient.GetOpcGroups:TOpcClientGroupList;
begin
 if Assigned(Self)
 then Result:=myOpcGroups
 else Result:=nil;
end;

function TOpcCustomClient.GetLastGroup:TOpcClientGroup;
begin
 if Assigned(Self)
 then Result:=OpcGroups[OpcGroups.Count-1]
 else Result:=nil;
end;

procedure TOpcCustomClient.OnReport(const msg:LongString);
begin
end;

function TOpcCustomClient.GetConnected:Boolean;
begin
 if Assigned(Self)
 then Result:=(myServerIf <> nil)
 else Result:=False;
end;

procedure TOpcCustomClient.SetConnected(aConnected:Boolean);
var
 hInp : THandle;
 hOut : THandle;
 hErr : THandle;
begin
 if Assigned(Self) then
 try
  if aConnected then begin
   if myServerIf = nil then begin
    // we will use the custom OPC interfaces, and OPCProxy.dll will handle
    // marshaling for us automatically (if registered)
    try
     hInp:=GetStdHandle(STD_INPUT_HANDLE);
     hOut:=GetStdHandle(STD_OUTPUT_HANDLE);
     hErr:=GetStdHandle(STD_ERROR_HANDLE);
     try
      SetStdHandle(STD_INPUT_HANDLE,0);
      SetStdHandle(STD_OUTPUT_HANDLE,0);
      SetStdHandle(STD_ERROR_HANDLE,0);
      if IsLocalHost(HostID)
      then myServerIf:=CreateComObject(StringToGUID(ClassID)) as IOPCServer
      else myServerIf:=CreateRemoteComObject(StrToWide(HostID),StringToGUID(ClassID)) as IOPCServer;
     finally
      SetStdHandle(STD_INPUT_HANDLE,hInp);
      SetStdHandle(STD_OUTPUT_HANDLE,hOut);
      SetStdHandle(STD_ERROR_HANDLE,hErr);
     end;
    except
     on E:Exception do begin
      myServerIf := nil;
      if rp_OpcException in OpcReportSet
      then Report:=Format('%s: %s',[ClassName,E.Message]);
     end;
    end;
    if rp_OpcConnect in OpcReportSet then
    if myServerIF <> nil
    then Report:=Format('Connected to OPC server %s',[ServerID])
    else Report:=Format('Unable to connect to OPC server %s',[ServerID]);
   end;
   if myServerIf <>nil then begin
    if myAdviseSinkIf = nil
    then myAdviseSinkIf:=TOpcClientAdviseSink.Create(Self);
    if myDataCallbackIf = nil
    then myDataCallbackIf:=TOpcClientDataCallback.Create(Self);
   end;
  end else begin
   OpcGroups.Clear;
   myAdviseSinkIf:=nil;
   myDataCallbackIf:=nil;
   if myServerIf <> nil then begin
    if rp_OpcDisconnect in OpcReportSet then
    Report:=Format('Disconnect OPC server %s',[ServerId]);
    myServerIf:=nil;
   end;
  end;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcCustomClient.AddGroup(aGroupID:LongString; aActive:BOOL; aUpdateRate:DWORD;
                                   aPercentDeadBand:Single):HResult;
var
 Group : TOpcClientGroup;
begin
 Result := E_FAIL;
 if Assigned(Self) then
 if myServerIf <> nil then
 try
  Group:=TOpcClientGroup.Create(Self,aGroupID,aActive);
  try
   Group.myPercentDeadBand:=aPercentDeadBand;
   Result:=myServerIf.AddGroup(PWideChar(WideString(Group.GroupID)), Group.Active,
                               aUpdateRate, Group.hClient, nil, @Group.myPercentDeadBand, 0,
                               Group.myhServer, Group.myUpdateRate, IOPCItemMgt,
                               IUnknown(Group.myGroupIf));
   if rp_OpcGroupAdd in OpcReportSet then
   if Succeeded(Result)
   then Report:=Format('Add OPC group %s',[Group.FullName])
   else Report:=Format('Unable to add OPC group %s, ErrorCode=$%8.8x',[Group.FullName,Result]);
   if Succeeded(Result) then Group:=nil; // Mark that group shoult not free
  finally
   Group.Free;
  end;
 except
  on E:Exception do
  if rp_OpcException in OpcReportSet
  then Report:=Format('%s: %s',[ClassName,E.Message]);
 end;
end;

function TOpcCustomClient.AdviseAll(aMode:Integer;aFormat:Integer):Integer;
var
 i:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 for i:=0 to OpcGroups.Count-1 do
 if Succeeded(OpcGroups[i].Advise(aMode,aFormat)) then Inc(Result);
end;

procedure TOpcCustomClient.UnAdviseAll(aMode:Integer);
var
 i:Integer;
begin
 if Assigned(Self) then
 for i:=0 to OpcGroups.Count-1 do OpcGroups[i].UnAdvise(aMode);
end;

function TOpcCustomClient.RefreshAll(aMode:Integer;dwSource:Word):Integer;
var
 i:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 for i:=0 to OpcGroups.Count-1 do
 if Succeeded(OpcGroups[i].Refresh(aMode,dwSource)) then Inc(Result);
end;

function TOpcCustomClient.OnDataChange;
begin
 Result:=S_OK;
end;

function TOpcCustomClient.OnReadComplete;
begin
 Result:=S_OK;
end;

function TOpcCustomClient.OnWriteComplete;
begin
 Result:=S_OK;
end;

function TOpcCustomClient.OnCancelComplete;
begin
 Result:=S_OK;
end;

procedure TOpcCustomClient.OnViewChange(dwAspect: Longint; lindex: Longint);
begin
end;

procedure TOpcCustomClient.OnRename(const mk: IMoniker);
begin
end;

procedure TOpcCustomClient.OnSave;
begin
end;

procedure TOpcCustomClient.OnClose;
begin
end;

 ////////////////////
 // Utility functions
 ////////////////////

procedure Kill(var TheObject:TOpcClientItem); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do Echo(E.Message);
 end; 
end;

procedure Kill(var TheObject:TOpcClientGroup); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do Echo(E.Message);
 end; 
end;

 // Standard DCOM security initialization with default parameters.
function StdDComInitSecurity:HResult;
const
 RPC_C_AUTHN_LEVEL_NONE      = 1;
 RPC_C_IMP_LEVEL_DEFAULT     = 0;
 RPC_C_IMP_LEVEL_ANONYMOUS   = 1;
 RPC_C_IMP_LEVEL_IDENTIFY    = 2;
 RPC_C_IMP_LEVEL_IMPERSONATE = 3;
 RPC_C_IMP_LEVEL_DELEGATE    = 4;
 EOAC_NONE                   = 0;
begin
 Result:=CoInitializeSecurity(
  nil,                         // points to security descriptor
  -1,                          // count of entries in asAuthSvc
  nil,                         // array of names to register
  nil,                         // reserved for future use
  RPC_C_AUTHN_LEVEL_NONE,      // the default authentication level for proxies
  RPC_C_IMP_LEVEL_IMPERSONATE, // the default impersonation level for proxies
  nil,                         // used only on Windows 2000
  EOAC_NONE,                   // additional client or server-side capabilities
  nil                          // reserved for future use
    );
end;

 // Get executable file path by given server ID
function GetComServerExecutable(const ServerID:LongString):LongString;
var hid,pid,cid:LongString;
begin
 try
  Result:=ServerID;
  hid:=''; pid:=''; cid:='';
  InterpretServerID(nil,Result,hid,pid,cid);
  Result:='';
  if IsLocalHost(hid)
  then Result:=RemoveBrackets(GetRegStringValue(Format('CLSID\%s\LocalServer32',[cid]),''),'""')
  else Result:='';
 except
  on E:Exception do Result:='';
 end;
end;
{$ENDIF ~WINDOWS}

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_opcc;
begin
end;

procedure Free_crw_opcc;
begin
end;

initialization

 Init_crw_opcc;

finalization

 Free_crw_opcc;

end.

//////////////
// END OF FILE
//////////////

