umain.pas

OPC 开发工具包2.0.OPC工具包是用来简化OPC规范服务器开发的工具包

unit uMain;

interface

uses
  ShareMem, Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, ExtCtrls, Menus, StdCtrls,ActiveX;

type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    F1: TMenuItem;
    A1: TMenuItem;
    X1: TMenuItem;
    TreeView1: TTreeView;
    Splitter1: TSplitter;
    Timer1: TTimer;
    mnFileRegister: TMenuItem;
    FileUnregister: TMenuItem;
    N1: TMenuItem;
    Panel1: TPanel;
    ListView1: TListView;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure TreeView1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure X1Click(Sender: TObject);
    procedure A1Click(Sender: TObject);
    procedure mnFileRegisterClick(Sender: TObject);
    procedure FileUnregisterClick(Sender: TObject);
  private
    InitOK: Boolean;
    FSeed: Integer;
    procedure AddTags;
    procedure CreateOPCServer;
    procedure FreeOPCServer;
    procedure Simulate;
  public
    procedure AddLog(log: string);
  end;

type
  TTag=record
    ID: string;
    Handle: THandle;
    vType: TVarType;
    Value: OleVariant;
    Quality: WORD;
    timestamp: TFileTime;
  end;

  function  FileTimeToString(AFileTime: TFileTime): string;
  function  DateTimeToFileTime(const Time: TDateTIme): TFileTime;
  function  VarTypeToString(AVarType: TVarType): string;
var
  SvrClsID : string= '{619E12F5-1A98-4DE6-BEBA-9826E45CC6C2}';
  SvrName : string='OPC.ASDPDEMO.1';
  SvrDesc : string='OPC ASDPDEMO 1';
  ServerCount: Integer=0;
  TagList: array[0..31] of TTag;

var
  Form1: TForm1;

implementation

uses DASVRSDK, math, uAbout;

{$R *.dfm}

function DateTimeToFileTime(const Time: TDateTIme): TFileTime;
var
  STime: TSystemTime;
begin
  DateTimeToSystemTime(Time, STime);
  SystemTimeToFileTime(STime, Result);
//  FileTimeToLocalFileTime(Result, result);
end;

function FileTimeToString(AFileTime: TFileTime): string;
var
  ft: TFileTime;
  st: TSystemTime;
  dt: TDatetime;
  Year, Month, Day, Hour, Min, Sec, MSec: Word;
begin
//  FileTimeToLocalFileTime(AFiletime, ft);
  FileTimeToSystemTime(AFiletime, st);
  dt := SystemTimeToDateTime(st);
  DecodeDate(dt, Year, Month, Day);
  DecodeTime(dt, Hour, Min, Sec, MSec);
  Result := Format('%.4d-%.2d-%.2d %.2d:%.2d:%.2d.%.3d', [Year, Month, Day, Hour, Min, Sec, MSec]);
end;

function VarTypeToString(AVarType: TVarType): string;
begin
  result:= 'Unknown';
  case AVarType of
    VT_I2: result:= 'VT_I2';
    VT_I4: result:= 'VT_I4';
    VT_I8: result:= 'VT_I8';
    VT_R4: result:= 'VT_R4';
    VT_R8: result:= 'VT_R8';
    VT_CY: result:= 'VT_CY';
    VT_DATE: result:= 'VT_DATE';
    VT_BSTR: result:= 'VT_BSTR';
    VT_BOOL: result:= 'VT_BOOL';
  end;
end;

procedure ReadCallback(hTag: DWORD; vValue: PVARIANT; wQuality: PWORD;
    pTimeStamp: PFILETIME; pError: PLongInt); stdcall;
var
  I: Integer;
begin
  pError^:= -1;
  for I:=0 to 31 do
  begin
    if TagList[I].Handle=hTag then
    begin
      try
        Varclear(vValue^);
        vValue^:= TagList[I].Value;
        wQuality^:=TagList[I].Quality;
        LocalFileTimeToFileTime(TagList[I].TimeStamp,pTimeStamp^);
//        pTimeStamp^:= TagList[I].TimeStamp;
        pError^:= 0;
        break;
      except
        on E:EVariantError do ;
      end;
    end;
  end;
end;

procedure WriteCallback(hTag: DWORD; pNewValue: VARIANT; pError: PLongInt);
    stdcall;
var
  I: Integer;
begin
  pError^:= -1;
  for I:=0 to 31 do
  begin
    if TagList[I].Handle=hTag then
    begin
      try
        TagList[I].Value:= pNewValue;
        TagList[I].Quality:= 192;
        TagList[I].TimeStamp:= DateTimeToFileTime(now);
        UpdateTag(hTag, pNewValue, 192);
        pError^:= 0;
        break;
      except
        on E:EVariantError do ;
      end;
    end;
  end;
end;

procedure ServerNotify(hServer: DWORD; wOperateType: WORD); stdcall;
begin
  case wOperateType of
    0:begin
        Inc(ServerCount);
      end;
    1:begin
        Dec(ServerCount);
      end;
  end;
  if ServerCount=0 then
    Form1.Close;
end;

procedure OpcLog(uMsg: LPCSTR); stdcall;
begin
  Form1.AddLog(uMsg);
end;

{ TForm1 }
procedure TForm1.AddTags;
var
  I: Integer;
  rNode: TTreeNode;
  dt: TDateTime;
  Handle: THandle;
begin
  dt:= Now;

  SetTagQualifier('.');
  rNode:= TreeView1.Items.AddChildFirst(nil,'DPDEMO');
  TreeView1.Items.AddChild(rNode,'Integer');
  handle:= Regtag(0,'Integer',0,0,0);
  for I:=0 to 7 do
  begin
    TagList[I].ID:= 'TagInt'+IntToStr(I);
    TagList[I].vType:= varInteger;
    TagList[I].Value:=0;
    TagList[I].Quality:=192;
    TagList[I].timestamp:= DateTimeToFileTime(dt);
    TagList[I].Handle:= RegTagEx(handle,PChar(TagList[I].ID),varInteger,3);
    AddTagProperty(TagList[I].Handle,'test',5001,'test',5001);
  end;
  TreeView1.Items.AddChild(rNode,'String');
  handle:= Regtag(0,'String',0,0,0);
  for I:=8 to 15 do
  begin
    TagList[I].ID:= 'TagString'+IntToStr(I-8);
    TagList[I].vType:= varOleStr;
    TagList[I].Value:='0';
    TagList[I].Quality:=192;
    TagList[I].timestamp:= DateTimeToFileTime(dt);
    TagList[I].Handle:= RegTagEx(handle,PChar(TagList[I].ID),varOleStr,3);
  end;
  TreeView1.Items.AddChild(rNode,'Bool');
  handle:= Regtag(0,'Bool',0,0,0);
  for I:=16 to 23 do
  begin
    TagList[I].ID:= 'TagBool'+IntToStr(I-16);
    TagList[I].vType:= varBoolean;
    TagList[I].Value:=False;
    TagList[I].Quality:=192;
    TagList[I].timestamp:= DateTimeToFileTime(dt);
    TagList[I].Handle:= RegTagEx(handle,PChar(TagList[I].ID),varBoolean,3);
  end;
  TreeView1.Items.AddChild(rNode,'Float');
  handle:= Regtag(0,'Float',0,0,0);
  for I:=24 to 31 do
  begin
    TagList[I].ID:= 'TagFloat'+IntToStr(I-24);
    TagList[I].vType:= varDouble;
    TagList[I].Value:=0;
    TagList[I].Quality:=192;
    TagList[I].timestamp:= DateTimeToFileTime(dt);
    TagList[I].Handle:= RegTagEx(handle,PChar(TagList[I].ID),varDouble,3);
  end;
  rNode.Expand(true);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CreateOPCServer;
end;

procedure TForm1.CreateOPCServer;
begin
  if CreateServer(PChar(SvrClsID),1000) then
  begin
    SetServerNotify(@ServerNotify);
    SetWriteCallBack(@WriteCallback);
    SetReadCallBack(@ReadCallback);
    SetLogNotify(@OpcLog);
    SetServerState(1);
    AddTags;
    InitOk:= true;
    Timer1.Enabled:= true;
  end;
end;

procedure TForm1.FreeOPCServer;
begin
  if InitOk then
  begin
    SetServernotify(nil);
    SetWriteCallBack(nil);
    FreeServer;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FreeOPCServer;
end;

procedure TForm1.Simulate;
var
  I, J: Integer;
  ft: TFileTime;
begin
  Inc(FSeed);
  if FSeed>100 then
    FSeed:= 0;

  ft:= DateTimeToFileTime(now);
//  LocalFileTimeTo
  for I:=0 to 3 do
  begin
    for J := 0 to 3 do
    begin
      case TagList[I*8+J].vType of
        varInteger:
            TagList[I*8+J].Value:= TagList[I*8+J].Value+1;
        varOleStr:
          TagList[I*8+J].Value:= IntToStr(StrToInt(TagList[I*8+J].Value)+1);
        varBoolean:
          TagList[I*8+J].Value:=not TagList[I*8+J].Value;
        varDouble:
          TagList[I*8+J].Value:=(TagList[I*8+J].Value+1)*1.0002;
      end;
      TagList[I*8+J].Quality:= 192;
      TagList[I*8+J].timestamp:= ft;
      UpdateTag(TagList[I*8+J].Handle, TagList[I*8+J].Value, TagList[I*8+J].Quality);
    end;
  end;
  if TreeView1.Selected<>nil then
    TreeView1Click(nil);
end;

procedure TForm1.TreeView1Click(Sender: TObject);
var
  item: TListitem;
  I: Integer;
begin
  if TreeView1.Selected=nil then Exit;
  Listview1.Clear;
  if TreeView1.Selected.Text='Integer' then
  begin
    for I:=0 to 7 do
    begin
      item:= ListView1.Items.Add;
      item.Caption:= TagList[I].ID;
      item.SubItems.Add(IntTostr(TagList[I].Handle));
      item.SubItems.Add(VarTypeToString(TagList[I].vType));
      item.SubItems.Add(tagList[I].Value);
      item.SubItems.Add(InttoStr(TagList[I].Quality));
      item.SubItems.Add(FileTimeToString(TagList[I].timestamp));
    end;
  end;
  if TreeView1.Selected.Text='String' then
  begin
    for I:=8 to 15 do
    begin
      item:= ListView1.Items.Add;
      item.Caption:= TagList[I].ID;
      item.SubItems.Add(IntTostr(TagList[I].Handle));
      item.SubItems.Add(VarTypeToString(TagList[I].vType));
      item.SubItems.Add(tagList[I].Value);
      item.SubItems.Add(InttoStr(TagList[I].Quality));
      item.SubItems.Add(FileTimeToString(TagList[I].timestamp));
    end;
  end;
  if TreeView1.Selected.Text='Bool' then
  begin
    for I:=16 to 23 do
    begin
      item:= ListView1.Items.Add;
      item.Caption:= TagList[I].ID;
      item.SubItems.Add(IntTostr(TagList[I].Handle));
      item.SubItems.Add(VarTypeToString(TagList[I].vType));
      item.SubItems.Add(tagList[I].Value);
      item.SubItems.Add(InttoStr(TagList[I].Quality));
      item.SubItems.Add(FileTimeToString(TagList[I].timestamp));
    end;
  end;
  if TreeView1.Selected.Text='Float' then
  begin
    for I:=24 to 31 do
    begin
      item:= ListView1.Items.Add;
      item.Caption:= TagList[I].ID;
      item.SubItems.Add(IntTostr(TagList[I].Handle));
      item.SubItems.Add(VarTypeToString(TagList[I].vType));
      item.SubItems.Add(tagList[I].Value);
      item.SubItems.Add(InttoStr(TagList[I].Quality));
      item.SubItems.Add(FileTimeToString(TagList[I].timestamp));
    end;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if InitOK then
    Simulate;

end;

procedure TForm1.X1Click(Sender: TObject);
begin
  ShutDown;
  Close;
end;

procedure TForm1.A1Click(Sender: TObject);
begin
  About:= TAbout.Create(nil);
  About.ShowModal;
  About.Free;
end;

procedure TForm1.mnFileRegisterClick(Sender: TObject);
begin
  RegServer(PChar(SvrClsID),PChar(SvrName),PChar(SvrDesc),PChar(
    Application.ExeName));
end;

procedure TForm1.FileUnregisterClick(Sender: TObject);
begin
  UnregServer(PChar(SvrClsID),PChar(SvrName));
end;

procedure TForm1.AddLog(log: string);
begin
  Memo1.Lines.Add(Log);
end;

end.