1 unit frmMain;
2 
3 interface
4 
5 uses
6   Windows, Messages, SysUtils, Variants, Classes, Graphics,
7   Controls, Forms, Dialogs, ComCtrls, StdCtrls, VirtualTrees, Snap7,
8   ImgList, WinSock2, ExtCtrls, Menus, mORMotReport;
9 
10 type
11 
12   TClientTag = record
13     Client : integer;
14     OpRw   : integer;
15     HMITag : TS7Tag;
16   end;
17 
18   TLogLevel = (llBasic, llDetailed, llDebug);
19 
20   TNodeType = (ntRoot, ntClient, ntTag, ntResRoot, ntDB);
21 
22   TObjectNode = class(TObject)
23   protected
24     FCaption: string;
25     FSize: string;
26     FNodeType: TNodeType;
27     FImageIndex: integer;
28     FChanged: boolean;
29   public
30     constructor Create(NodeType : TNodeType);
31     property ImageIndex : integer read FImageIndex;
32     property NodeType : TNodeType read FNodeType;
33     property Caption : string read FCaption write FCaption;
34     property Size : string read FSize write FSize;
35     property Changed : boolean read FChanged;
36   end;
37 
38   TTagNode = class(TObjectNode)
39   private
40     FTagType: string;
41     FElements: string;
42     FAddress: string;
43     FAccess: string;
44     FUID: int64;
45     FOperation: integer;
46     FTag: TS7Tag;
47     FTagLimit: integer;
48     procedure SetFOperation(const Value: integer);
49     procedure SetFTag(const Value: TS7Tag);
50   public
51     property Access : string read FAccess write FAccess;
52     property Address : string read FAddress write FAddress;
53     property TagType : string read FTagType write FTagType;
54     property Elements : string read FElements write FElements;
55     property Operation : integer read FOperation write SetFOperation;
56     property UID : int64 read FUID write FUID;
57     property TagLimit : integer read FTagLimit;
58     property Tag : TS7Tag read FTag write SetFTag;
59   end;
60 
61   PTagTreeData = ^TTagTreeData;
62   TTagTreeData = record
63     Obj : TTagNode;
64   end;
65 
66   TResNode = class(TObjectNode)
67   private
68     FSizeNeeded: integer;
69     procedure SetFSizeNeeded(const Value: integer);
70   public
71     property SizeNeeded : integer read FSizeNeeded write SetFSizeNeeded;
72   end;
73 
74   PResTreeData = ^TResTreeData;
75   TResTreeData = record
76     Obj : TResNode;
77   end;
78 
79   TObjectsList = class(TList)
80   private
GetObjnull81     function GetObj(index: integer): TTagNode;
82   public
Findnull83     function Find(UID : int64) : TTagNode;
84     property Obj[index : integer] : TTagNode read GetObj; default;
85   end;
86 
87   TTagQueue = class(TObject)
88   private
89     IndexIn    : integer;   // <-- insert index
90     IndexOut   : integer;   // --> extract index
91     Max        : integer;   // Buffer upper bound [0..Max]
92     FCapacity  : integer;   // Queue capacity
93     Buffer     : PByteArray;
94     FBlockSize : integer;
95   public
96     constructor Create(const Capacity, BlockSize : integer);
97     destructor Destroy; override;
98     procedure Flush;
99     procedure Insert(lpdata : pointer);
Extractnull100     function Extract(lpdata : pointer) : boolean;
Emptynull101     function Empty : boolean;
102   end;
103 
104   TSrvForm = class(TForm)
105     VT: TVirtualStringTree;
106     Images: TImageList;
107     RT: TVirtualStringTree;
108     SB: TStatusBar;
109     Log: TMemo;
110     Splitter1: TSplitter;
111     Splitter2: TSplitter;
112     TimLog: TTimer;
113     MainMenu1: TMainMenu;
114     File1: TMenuItem;
115     Exit1: TMenuItem;
116     Log1: TMenuItem;
117     Detail1: TMenuItem;
118     BasicMItem: TMenuItem;
119     DetailedMItem: TMenuItem;
120     DebugMItem: TMenuItem;
121     Clear1: TMenuItem;
122     N1: TMenuItem;
123     FreezeMItem: TMenuItem;
124     FlushServerwueue1: TMenuItem;
125     N2: TMenuItem;
126     SettingMItem: TMenuItem;
127     TimTag: TTimer;
128     N3: TMenuItem;
129     StartMItem: TMenuItem;
130     Report1: TMenuItem;
131     ReportMItem: TMenuItem;
132     procedure VTGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
133       Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean;
134       var ImageIndex: Integer);
135     procedure FormCreate(Sender: TObject);
136     procedure VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
137       Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
138     procedure FormClose(Sender: TObject; var Action: TCloseAction);
139     procedure VTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
140     procedure TimLogTimer(Sender: TObject);
141     procedure FreezeMItemClick(Sender: TObject);
142     procedure TimTagTimer(Sender: TObject);
143     procedure BasicMItemClick(Sender: TObject);
144     procedure DetailedMItemClick(Sender: TObject);
145     procedure DebugMItemClick(Sender: TObject);
146     procedure Clear1Click(Sender: TObject);
147     procedure StartMItemClick(Sender: TObject);
148     procedure SettingMItemClick(Sender: TObject);
149     procedure RTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
150       Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
151     procedure RTGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
152       Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean;
153       var ImageIndex: Integer);
154     procedure RTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
155     procedure Exit1Click(Sender: TObject);
156     procedure ReportMItemClick(Sender: TObject);
157     procedure VTEdited(Sender: TBaseVirtualTree; Node: PVirtualNode;
158       Column: TColumnIndex);
159     procedure VTEditing(Sender: TBaseVirtualTree; Node: PVirtualNode;
160       Column: TColumnIndex; var Allowed: Boolean);
161     procedure VTNewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
162       Column: TColumnIndex; NewText: string);
163   private
164     { Private declarations }
165     Server : TS7Server;
166     Tags : TObjectsList;
167     TagRoot : PVirtualNode;
168     ResRoot : PVirtualNode;
169     DBList : TStringList;
170     Queue : TTagQueue;
171     Running : boolean;
172     FServerStatus: integer;
173     FClientsCount: integer;
174     FLogLevel: TLogLevel;
175     LocalAddress : string;
176     TagCount : integer;
TagUIDnull177     function TagUID(Tag : TS7Tag) : int64;
GetTagObjectnull178     function GetTagObject(Node : PVirtualNode) : TTagNode;
GetResObjectnull179     function GetResObject(Node : PVirtualNode) : TResNode;
FindClientNodenull180     function FindClientNode(IP : string) : PVirtualNode;
NewTagNamenull181     function NewTagName : string;
ClientIPnull182     function ClientIP(Address : integer) : string;
183     procedure NewTag(CliTag : TClientTag);
184     procedure InitTagTree;
185     procedure InitResTree;
186     procedure Clear;
187     procedure RunStop;
188     procedure UpdateDBList(Obj : TTagNode);
189     procedure SetFClientsCount(const Value: integer);
190     procedure SetFServerStatus(const Value: integer);
191     procedure SetFLogLevel(const Value: TLogLevel);
192     procedure CreateReport;
193   public
194     { Public declarations }
195     procedure TagIncoming(Client, Operation : integer; PTag : PS7Tag);
196     property ServerStatus : integer read FServerStatus write SetFServerStatus;
197     property ClientsCount : integer read FClientsCount write SetFClientsCount;
198     property LogLevel : TLogLevel read FLogLevel write SetFLogLevel;
199   end;
200 
201 var
202   SrvForm: TSrvForm;
203 
204 implementation
205 Uses
206   frmReport;
207 {$R *.dfm}
208 
RWAreaCallbacknull209 function RWAreaCallback(usrPtr : pointer; Sender, Operation : integer; PTag : PS7Tag; pUsrData : pointer) : integer; stdcall;
210 begin
211   try
212     TSrvForm(usrPtr).TagIncoming(Sender, Operation, PTag);
213   except
214   end;
215   Result:=0;
216 end;
217 
218 { TEventQueue }
219 
220 constructor TTagQueue.Create(const Capacity, BlockSize : integer);
221 begin
222   inherited Create;
223   FCapacity:=Capacity;
224   Max :=FCapacity-1;
225   FBlockSize:=BlockSize;
226   GetMem(Buffer,FCapacity*FBlockSize);
227 end;
228 
229 destructor TTagQueue.Destroy;
230 begin
231   FreeMem(Buffer,FCapacity*FBlockSize);
232   inherited;
233 end;
234 
Emptynull235 function TTagQueue.Empty: boolean;
236 begin
237   Result:=IndexIn=IndexOut;
238 end;
239 
TTagQueue.Extractnull240 function TTagQueue.Extract(lpdata : pointer): boolean;
241 Var
242   Offset : integer;
243   IdxOut : integer;
244 begin
245   Result:=not Empty;
246   if Result then
247   begin
248     // Calc offset
249     IdxOut:=indexOut;
250     if IdxOut<Max then inc(IdxOut) else IdxOut:=0;
251     Offset:=IdxOut*FBlockSize;
252     // moves data
253     move(Buffer^[Offset],lpData^,FBlockSize);
254     // Updates IndexOut
255     IndexOut:=IdxOut;
256   end;
257 end;
258 
259 procedure TTagQueue.Flush;
260 begin
261   IndexIn :=0;
262   IndexOut:=0;
263 end;
264 
265 procedure TTagQueue.Insert(lpdata : pointer);
266 Var
267   idxOut : integer;
268   Offset : integer;
269 begin
270   idxOut:=IndexOut; // To avoid that indexout may change during next line
271   if not ((IdxOut=IndexIn+1) or ((IndexIn=Max) and (IdxOut=0))) then // if not full
272   begin
273     // Calc offset
274     if IndexIn<Max then inc(IndexIn) else IndexIn:=0;
275     Offset:=IndexIn*FBlockSize;
276     move(lpData^,Buffer^[Offset],FBlockSize);
277   end;
278 end;
279 
280 { TObjectsList }
281 
TObjectsList.Findnull282 function TObjectsList.Find(UID : int64): TTagNode;
283 var
284   c: Integer;
285 begin
286   for c := 0 to Count-1 do
287   begin
288     if Obj[c].UID=UID then
289     begin
290       Result:=Obj[c];
291       exit;
292     end;
293   end;
294   Result:=nil;
295 end;
296 
TObjectsList.GetObjnull297 function TObjectsList.GetObj(index: integer): TTagNode;
298 begin
299   Result:=TTagNode(Items[index]);
300 end;
301 
302 
303 { TObjectNode }
304 
305 constructor TObjectNode.Create(NodeType: TNodeType);
306 begin
307   inherited Create;
308   FNodeType := NodeType;
309   case FNodeType of
310     ntRoot   : FImageIndex:=0;
311     ntClient : FImageIndex:=1;
312     ntTag    : FImageIndex:=2;
313     ntResRoot: FImageIndex:=3;
314     ntDB     : FImageIndex:=4;
315   end;
316   FChanged:=true;
317 end;
318 
319 { TResNode }
320 
321 procedure TResNode.SetFSizeNeeded(const Value: integer);
322 begin
323   FSizeNeeded := Value;
324   FSize:=IntToStr(FSizeNeeded);
325   FChanged:=true;
326 end;
327 
328 { TTagNode }
329 
330 procedure TTagNode.SetFOperation(const Value: integer);
331 Var
332   TheAccess : string;
333 begin
334   if Value=OperationRead then
335     FOperation:=FOperation OR $01
336   else
337     FOperation:=FOperation OR $02;
338 
339   case FOperation of
340     $01 : TheAccess:='R';
341     $02 : TheAccess:='W';
342     $03 : TheAccess:='R/W';
343   end;
344   FChanged:=THeAccess<>FAccess;
345   FAccess:=THeAccess;
346 end;
347 
348 procedure TTagNode.SetFTag(const Value: TS7Tag);
349 Var
350   WPrefix : string;
351   APrefix : string;
352   Offset  : string;
353 begin
354   FTag := Value;
355 
356   case FTag.Area of
357     S7AreaPE : APrefix:='E';
358     S7AreaPA : APrefix:='A';
359     S7AreaMK : APrefix:='M';
360     S7AreaDB : APrefix:='DB '+IntToStr(Tag.DBNumber)+' DB';
361     S7AreaCT : APrefix:='Z';
362     S7AreaTM : APrefix:='T';
363     else
364       APrefix:='(0x'+IntToHex(FTag.Area,4)+')';
365   end;
366 
367   case FTag.WordLen of
368     S7WLBit:
369       begin
370         if FTag.Area=S7AreaDB then
371           WPrefix:='X';
372         FTagType:='Bool';
373         Offset:=IntToStr(Tag.Start div 8)+'.'+IntToStr(Tag.Start mod 8);
374         FElements:=IntToStr(Tag.Elements);
375         FSize:=IntToStr(Tag.Elements);
376         FTagLimit:=Tag.Start div 8;
377         if FTagLimit mod 2 <>0 then
378           FTagLimit:=FTagLimit+1;
379         if FTagLimit=0 then
380           FTagLimit:=2;
381 
382       end;
383     S7WLByte:
384       begin
385         WPrefix:='B';
386         FTagType:='Byte';
387         FElements:=IntToStr(Tag.Elements);
388         Offset:=IntToStr(Tag.Start);
389         FSize:=IntToStr(Tag.Elements);
390         FTagLimit:=Tag.Start+Tag.Elements;
391       end;
392     S7WLChar:
393       begin
394         WPrefix:='B';
395         FTagType:='Char';
396         FElements:=IntToStr(Tag.Elements);
397         Offset:=IntToStr(Tag.Start);
398         FSize:=IntToStr(Tag.Elements);
399         FTagLimit:=Tag.Start+Tag.Elements;
400       end;
401     S7WLWord:
402       begin
403         WPrefix:='W';
404         FTagType:='Word';
405         FElements:=IntToStr(Tag.Elements);
406         Offset:=IntToStr(Tag.Start);
407         FSize:=IntToStr(Tag.Elements*2);
408         FTagLimit:=Tag.Start+Tag.Elements*2;
409       end;
410     S7WLInt:
411       begin
412         WPrefix:='W';
413         FTagType:='Int';
414         FElements:=IntToStr(Tag.Elements);
415         Offset:=IntToStr(Tag.Start);
416         FSize:=IntToStr(Tag.Elements*2);
417         FTagLimit:=Tag.Start+Tag.Elements*2;
418       end;
419     S7WLDWord:
420       begin
421         WPrefix:='D';
422         FTagType:='DWord';
423         FElements:=IntToStr(Tag.Elements);
424         Offset:=IntToStr(Tag.Start);
425         FSize:=IntToStr(Tag.Elements*4);
426         FTagLimit:=Tag.Start+Tag.Elements*4;
427       end;
428     S7WLDInt:
429       begin
430         WPrefix:='D';
431         FTagType:='DInt';
432         FElements:=IntToStr(Tag.Elements);
433         Offset:=IntToStr(Tag.Start);
434         FSize:=IntToStr(Tag.Elements*4);
435         FTagLimit:=Tag.Start+Tag.Elements*4;
436       end;
437     S7WLReal:
438       begin
439         WPrefix:='D';
440         FTagType:='Real';
441         FElements:=IntToStr(Tag.Elements);
442         Offset:=IntToStr(Tag.Start);
443         FSize:=IntToStr(Tag.Elements*4);
444         FTagLimit:=Tag.Start+Tag.Elements*4;
445       end;
446     S7WLCounter:
447       begin
448         FTagType:='Counter';
449         FElements:=IntToStr(Tag.Elements);
450         Offset:=IntToStr(Tag.Start);
451         FSize:=IntToStr(Tag.Elements*2);
452       end;
453     S7WLTimer:
454       begin
455         FTagType:='Timer';
456         FElements:=IntToStr(Tag.Elements);
457         Offset:=IntToStr(Tag.Start);
458         FSize:=IntToStr(Tag.Elements*2);
459       end;
460     else begin
461       FTagType:='0x'+IntToHex(Tag.WordLen,4);
462       WPrefix :=FTagType;
463       Offset:='('+IntToStr(Tag.Start)+')';
464     end;
465   end;
466 
467   FAddress:=APrefix+WPrefix+' '+Offset;
468 
469   if Odd(FTagLimit) then
470     FTagLimit:=FTagLimit+1;
471 end;
472 
473 { TSrvForm }
474 
475 procedure TSrvForm.TagIncoming(Client, Operation : integer; PTag : PS7Tag);
476 Var
477   CliTag : TClientTag;
478 begin
479   CliTag.Client:=Client;
480   CliTag.OpRw  :=Operation;
481   CliTag.HMITag:=PTag^;
482   Queue.Insert(@CliTag);
483 end;
484 
485 procedure TSrvForm.BasicMItemClick(Sender: TObject);
486 begin
487   BasicMItem.Checked:=true;
488   LogLevel:=llBasic;
489 end;
490 
491 procedure TSrvForm.Clear;
492 begin
493   VT.Clear;
494   RT.Clear;
495   Tags.Clear;
496   DBList.Clear;
497 end;
498 
499 procedure TSrvForm.Clear1Click(Sender: TObject);
500 begin
501   Log.Clear;
502 end;
503 
TSrvForm.ClientIPnull504 function TSrvForm.ClientIP(Address: integer): string;
505 Var
506   Addr : in_addr;
507 begin
508   Addr.s_addr:=Address;
509   Result:=String(inet_ntoa(Addr));
510 end;
511 
512 procedure TSrvForm.CreateReport;
513 Var
514   GDIPages : TGDIPages;
515   LastClient : string;
516   c: TGDIPages;
517 
518   procedure CreateHeader;
519   Var
520     Family : string;
521   begin
522     Family:='';
523     with GDIPages do
524     begin
525       // Footer
526       SaveLayout;
527       Font.Style := [];
528       TextAlign := taRight;
529       AddLineToFooter(false);
530       AddPagesToFooterAt('Page %d/%d',RightMarginPos);
531       RestoreSavedLayout;
532       // Header
533       DrawLine;
534       Font.Size := 12;
535       Font.Style:=[fsBold];
536       AddColumns([20,80]);
537       DrawTextAcrossCols(['Server',LocalAddress]);
538       DrawTextAcrossCols(['Session',DateTimeToStr(Now)]);
539       DrawLine;
540     end;
541   end;
542 
543   procedure ShowPreview(Pages : TGDIPages);
544   Var
545     ReportForm : TReportForm;
546     OldParent : TWinControl;
547   begin
548     ReportForm:=TReportForm.Create(nil);
549     ReportForm.Position := poScreenCenter;
550     ReportForm.Height := Screen.Height-64;
551     ReportForm.Pages:=Pages;
552     OldParent:=Pages.Parent;
553     Pages.Parent:=ReportForm;
554     Pages.Align := alClient;
555     Pages.Zoom := PAGE_FIT;
556     Pages.ExportPDFEmbeddedTTF:=true;
557     try
558       ReportForm.ShowModal;
559     finally
560       Pages.Parent:=OldParent;
561       ReportForm.Free;
562     end;
563   end;
564 
565   procedure CreatePage(PageName : string);
566   begin
567     GDIPages.Font.Style:=[fsBold];
568     GDIPages.Font.Size := 13;
569     GDIPages.AddColumns([100]);
570     GDIPages.DrawTextAcrossCols([' '+PageName],$00050EAB);
571   end;
572 
573   procedure CreateClient(ClientName : string);
574   begin
575     GDIPages.NewHalfLine;
576     GDIPages.Font.Style:=[fsBold];
577     GDIPages.Font.Size := 12;
578     GDIPages.AddColumns([100]);
579     GDIPages.DrawTextAcrossCols([ClientName]);
580     GDIPages.DrawLine;
581     GDIPages.AddColumns([2,25,8,27,13,15,15]);
582     GDIPages.Font.Style:=[];
583     GDIPages.Font.Size := 11;
584   end;
585 
586   procedure CreateDBGroup;
587   begin
588     GDIPages.AddColumns([2,25,73]);
589     GDIPages.Font.Style:=[];
590     GDIPages.Font.Size := 11;
591     GDIPages.NewHalfLine;
592   end;
593 
594   procedure AddTag(Obj : TTagNode);
595   begin
596     if Assigned(Obj) then
597       GDIPages.DrawTextAcrossCols(['',obj.Caption,Obj.Access,Obj.Address,Obj.FTagType,Obj.Elements,Obj.Size]);
598   end;
599 
600   procedure AddDB(Obj : TResNode);
601   begin
602     if Assigned(Obj) then
603       GDIPages.DrawTextAcrossCols(['',obj.Caption,Obj.Size]);
604   end;
605 
606 Var
607   ClientNode : PVirtualNode;
608   TagNode : PVirtualNode;
609   DBNode : PVirtualNode;
610   Obj : TTagNode;
611   DB  : TResNode;
612 begin
613   LastClient:='';
614   GDIPages:=TGDIPages.Create(self);
615   with GDIPages do
616   try
617     BeginDoc;
618     Font.Name := 'Tahoma';
619     CreateHeader;
620     CreatePage('Tag List');
621     if Assigned(VT.RootNode.FirstChild) then
622       ClientNode:=VT.RootNode.FirstChild.FirstChild
623     else
624       ClientNode:=nil;
625 
626     while ClientNode<>nil do
627     begin
628       Obj:=GetTagObject(ClientNode);
629       CreateClient(Obj.Caption);
630       TagNode:=ClientNode.FirstChild;
631       while TagNode<>nil do
632       begin
633         AddTag(GetTagObject(TagNode));
634         TagNode:=TagNode.NextSibling;
635       end;
636       ClientNode:=ClientNode.NextSibling;
637     end;
638 
639     GDIPages.NewLine;
640     CreatePage('DB List');
641     CreateDBGroup;
642 
643     if Assigned(RT.RootNode.FirstChild) then
644       DBNode:=RT.RootNode.FirstChild.FirstChild
645     else
646       DBNode:=nil;
647 
648     while DBNode<>nil do
649     begin
650       AddDB(GetResObject(DBNode));
651       DBNode:=DBNode.NextSibling;
652     end;
653 
654 
655 
656 
657     EndDoc;
658     ShowPreview(GDIPages);
659   finally
660     Free;
661   end;
662 
663 end;
664 
665 procedure TSrvForm.DebugMItemClick(Sender: TObject);
666 begin
667   DebugMItem.Checked:=true;
668   LogLevel:=llDebug;
669 end;
670 
671 procedure TSrvForm.DetailedMItemClick(Sender: TObject);
672 begin
673   DetailedMItem.Checked:=true;
674   LogLevel:=llDetailed;
675 end;
676 
677 procedure TSrvForm.Exit1Click(Sender: TObject);
678 begin
679   Close;
680 end;
681 
TSrvForm.FindClientNodenull682 function TSrvForm.FindClientNode(IP: string): PVirtualNode;
683 Var
684   aNode : PVirtualNode;
685   Obj : TTagNode;
686 begin
687   Result:=nil;
688   aNode:=TagRoot.FirstChild;
689   while aNode<>nil do
690   begin
691     Obj:=GetTagObject(aNode);
692     if Assigned(Obj) and SameText(Obj.Caption,IP) then
693     begin
694       Result:=aNode;
695       exit;
696     end;
697     aNode:=aNode.NextSibling;
698   end;
699 end;
700 
701 procedure TSrvForm.FormClose(Sender: TObject; var Action: TCloseAction);
702 begin
703   Server.Free;
704   Queue.Free;
705   DBList.Free;
706   Tags.Free;
707   VT.Clear;
708 end;
709 
710 procedure TSrvForm.FormCreate(Sender: TObject);
711 begin
712   Server := TS7Server.Create;
713   Server.SetRWAreaCallback(@RWAreaCallback,Self);
714   Queue := TTagQueue.Create(1024,SizeOf(TClientTag));
715   Tags:= TObjectsList.Create;
716   DBList :=TStringList.Create;
717   DBList.Sorted:=true;
718   Running := false;
719   LocalAddress :='0.0.0.0';
720   LogLevel:=llBasic;
721   TimLog.Enabled:=true;
722   InitTagTree;
723   InitResTree;
724 end;
725 
726 procedure TSrvForm.FreezeMItemClick(Sender: TObject);
727 begin
728   if TimLog.Enabled then
729   begin
730     TimLog.Enabled:=false;
731     FreezeMItem.Caption:='Run';
732   end
733   else begin
734     TimLog.Enabled:=true;
735     FreezeMItem.Caption:='Freeze';
736   end;
737 end;
738 
GetResObjectnull739 function TSrvForm.GetResObject(Node: PVirtualNode): TResNode;
740 Var
741   Data : PResTreeData;
742 begin
743   Data:=RT.GetNodeData(Node);
744   if Assigned(Data) then
745     Result:=Data^.Obj
746   else
747     Result:=nil;
748 end;
749 
TSrvForm.GetTagObjectnull750 function TSrvForm.GetTagObject(Node: PVirtualNode): TTagNode;
751 Var
752   Data : PTagTreeData;
753 begin
754   Data:=VT.GetNodeData(Node);
755   if Assigned(Data) then
756     Result:=Data^.Obj
757   else
758     Result:=nil;
759 end;
760 
761 procedure TSrvForm.InitResTree;
762 
763   procedure CreateRoot;
764   Var
765     Data    : PResTreeData;
766   begin
767     ResRoot:=RT.AddChild(nil);
768     Data:=RT.GetNodeData(ResRoot);
769     if Assigned(Data) then
770     begin
771       Data.Obj:=TResNode.Create(ntResRoot);
772       Data.Obj.Caption:='Memory';
773     end;
774   end;
775 
776 begin
777   RT.NodeDataSize:=SizeOf(TResTreeData);
778   CreateRoot;
779   RT.FullExpand();
780 end;
781 
782 procedure TSrvForm.InitTagTree;
783 
784   procedure CreateRoot;
785   Var
786     Data    : PTagTreeData;
787   begin
788     TagRoot:=VT.AddChild(nil);
789     Data:=VT.GetNodeData(TagRoot);
790     if Assigned(Data) then
791     begin
792       Data.Obj:=TTagNode.Create(ntRoot);
793       Data.Obj.Caption:='S7Server';
794     end;
795   end;
796 
797 begin
798   VT.NodeDataSize:=SizeOf(TTagTreeData);
799   CreateRoot;
800   VT.FullExpand();
801 end;
802 
803 procedure TSrvForm.NewTag(CliTag: TClientTag);
804 Var
805   UID : int64;
806   IP  : string;
807   Obj : TTagNode;
808   CliNode : PVirtualNode;
809   TagNode : PVirtualNode;
810 
CreateNodenull811   function CreateNode : TTagNode;
812   begin
813     Result:=TTagNode.Create(ntTag);
814     Result.UID:=UID;
815     Result.Caption:=NewTagName;
816     Result.Tag:=CliTag.HMITag;
817   end;
818 
CreateClientnull819   function CreateClient : PVirtualNode;
820   Var
821     Obj  : TTagNode;
822   begin
823     Obj:=TTagNode.Create(ntClient);
824     Obj.Caption:=IP;
825     Result:=VT.AddChild(TagRoot);
826     PTagTreeData(VT.GetNodeData(Result)).Obj:=Obj;
827   end;
828 
829 begin
830   UID:=TagUID(CliTag.HMITag);
831   Obj:=Tags.Find(UID);
832   if not Assigned(Obj) then
833   begin
834     // Get Client
835     IP:=ClientIP(CliTag.Client);
836     CliNode:=FindClientNode(IP);
837     if not Assigned(CliNode) then
838       CliNode:=CreateClient;
839     // Create New Node Tag
840     Obj:=CreateNode;
841     TagNode:=VT.AddChild(CliNode);
842     PTagTreeData(VT.GetNodeData(TagNode)).Obj:=Obj;
843     Tags.Add(Obj);
844     UpdateDBList(Obj);
845   end;
846   Obj.Operation:=CliTag.OpRw; // Tag exists : only access (R or W) update
847   if Obj.Changed then
848     VT.FullExpand;
849 end;
850 
NewTagNamenull851 function TSrvForm.NewTagName: string;
852 begin
853   inc(TagCount);
854   Result:='Tag_'+IntToStr(TagCount);
855 end;
856 
857 procedure TSrvForm.ReportMItemClick(Sender: TObject);
858 begin
859   CreateReport;
860 end;
861 
862 procedure TSrvForm.RTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
863 Var
864   Obj : TResNode;
865 begin
866   Obj:=GetResObject(Node);
867   if Assigned(Obj) then
868     Obj.Free;
869 end;
870 
871 procedure TSrvForm.RTGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
872   Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean;
873   var ImageIndex: Integer);
874 Var
875   Obj : TResNode;
876 begin
877   if (Column=0) and (Kind<>ikOverlay) then
878   begin
879     Obj:=GetResObject(Node);
880     if Assigned(Obj) then
881       ImageIndex:=Obj.ImageIndex;
882   end;
883   if Kind=ikOverlay then
884     ImageIndex:=0;
885 end;
886 
887 procedure TSrvForm.RTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
888   Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
889 Var
890   Obj : TResNode;
891 begin
892   CellText :='';
893   Obj:=GetResObject(Node);
894   if Assigned(Obj) then
895   begin
896     if Column>0 then
897     begin
898       case Column of
899         1 : CellText:=Obj.Size;
900       end;
901     end
902     else
903       CellText:=Obj.Caption;
904   end;
905 end;
906 
907 procedure TSrvForm.RunStop;
908 
909   procedure DoStart;
910   begin
911     if Server.StartTo(LocalAddress)=0 then
912     begin
913       Clear;
914       InitTagTree;
915       InitResTree;
916       TagCount :=0;
917       TimTag.Enabled:=true;
918       StartMItem.Caption:='Stop';
919       SettingMItem.Enabled:=false;
920       Running:=true;
921     end;
922   end;
923 
924   procedure DoStop;
925   begin
926     Server.Stop;
927     StartMItem.Caption:='Start';
928     Running:=false;
929     TimTag.Enabled:=false;
930     SettingMItem.Enabled:=true;
931     Queue.Flush;
932   end;
933 
934 begin
935   if Running then
936     DoStop
937   else
938     DoStart;
939 end;
940 
941 procedure TSrvForm.SetFClientsCount(const Value: integer);
942 begin
943   if FClientsCount <> Value then
944   begin
945     FClientsCount := Value;
946     SB.Panels[1].Text:='Clients connected: '+IntToStr(FClientsCount);
947   end;
948 end;
949 
950 procedure TSrvForm.SetFLogLevel(const Value: TLogLevel);
951 begin
952   FLogLevel := Value;
953   case FLogLevel of
954     llBasic   : Server.LogMask:=$000003FF;
955     llDetailed: Server.LogMask:=$000603FF;
956     llDebug   : Server.LogMask:=$FFFFFFFF;
957   end;
958 end;
959 
960 procedure TSrvForm.SetFServerStatus(const Value: integer);
961 begin
962   if FServerStatus <> Value then
963   begin
964     FServerStatus := Value;
965     case FServerStatus of
966       SrvStopped : SB.Panels[0].Text:='Stopped';
967       SrvRunning : SB.Panels[0].Text:='Running on '+LocalAddress;
968       SrvError   : SB.Panels[0].Text:='Error';
969     end;
970   end;
971 end;
972 
973 procedure TSrvForm.SettingMItemClick(Sender: TObject);
974 begin
975   LocalAddress:=InputBox('Server settings','IP Listen Address',LocalAddress);
976 end;
977 
978 procedure TSrvForm.StartMItemClick(Sender: TObject);
979 begin
980   RunStop;
981 end;
982 
TSrvForm.TagUIDnull983 function TSrvForm.TagUID(Tag: TS7Tag): int64;
984 Type
985   TUID = packed record
986     uAddress_wla  : longword; // wlength-area-address
987     uDBNumber     : word;
988     uElements     : word;
989   end;
990 Var
991   UID : TUID absolute Result;
992   IAW : longword;
993 begin
994   IAW :=$7F;
995   case Tag.Area of
996     S7AreaPE : IAW := $10000000;
997     S7AreaPA : IAW := $20000000;
998     S7AreaMK : IAW := $30000000;
999     S7AreaDB : IAW := $40000000;
1000     S7AreaCT : IAW := $50000000;
1001     S7AreaTM : IAW := $60000000;
1002   end;
1003   case Tag.WordLen of
1004     S7WLBit      : IAW:=IAW OR $01000000;
1005     S7WLByte     : IAW:=IAW OR $02000000;
1006     S7WLChar     : IAW:=IAW OR $03000000;
1007     S7WLWord     : IAW:=IAW OR $04000000;
1008     S7WLInt      : IAW:=IAW OR $05000000;
1009     S7WLDWord    : IAW:=IAW OR $06000000;
1010     S7WLDInt     : IAW:=IAW OR $07000000;
1011     S7WLReal     : IAW:=IAW OR $08000000;
1012     S7WLCounter  : IAW:=IAW OR $09000000;
1013     S7WLTimer    : IAW:=IAW OR $0A000000;
1014   end;
1015   UID.uAddress_wla:=IAW OR Longword(Tag.Start);
1016   UID.uDBNumber   :=Tag.DBNumber;
1017   UID.uElements   :=Tag.Elements;
1018 end;
1019 
1020 procedure TSrvForm.VTEdited(Sender: TBaseVirtualTree; Node: PVirtualNode;
1021   Column: TColumnIndex);
1022 begin
1023   Caption:=VT.Text[Node,Column];
1024 end;
1025 
1026 procedure TSrvForm.VTEditing(Sender: TBaseVirtualTree; Node: PVirtualNode;
1027   Column: TColumnIndex; var Allowed: Boolean);
1028 begin
1029   Allowed:=Column=0;
1030 end;
1031 
1032 procedure TSrvForm.VTFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode);
1033 Var
1034   Obj : TTagNode;
1035 begin
1036   Obj:=GetTagObject(Node);
1037   if Assigned(Obj) then
1038     Obj.Free;
1039 end;
1040 
1041 procedure TSrvForm.VTGetImageIndex(Sender: TBaseVirtualTree; Node: PVirtualNode;
1042   Kind: TVTImageKind; Column: TColumnIndex; var Ghosted: Boolean;
1043   var ImageIndex: Integer);
1044 Var
1045   Obj : TTagNode;
1046 begin
1047   if (Column=0) and (Kind<>ikOverlay) then
1048   begin
1049     Obj:=GetTagObject(Node);
1050     if Assigned(Obj) then
1051       ImageIndex:=Obj.ImageIndex;
1052   end;
1053   if Kind=ikOverlay then
1054     ImageIndex:=0;
1055 end;
1056 
1057 procedure TSrvForm.VTGetText(Sender: TBaseVirtualTree; Node: PVirtualNode;
1058   Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);
1059 Var
1060   Obj : TTagNode;
1061 begin
1062   CellText :='';
1063   Obj:=GetTagObject(Node);
1064   if Assigned(Obj) then
1065   begin
1066     if Column>0 then
1067     begin
1068       case Column of
1069         1 : CellText:=Obj.Access;
1070         2 : CellText:=Obj.Address;
1071         3 : CellText:=Obj.TagType;
1072         4 : CellText:=Obj.Elements;
1073         5 : CellText:=Obj.Size;
1074       end;
1075     end
1076     else
1077       CellText:=Obj.Caption;
1078   end;
1079 end;
1080 
1081 procedure TSrvForm.VTNewText(Sender: TBaseVirtualTree; Node: PVirtualNode;
1082   Column: TColumnIndex; NewText: string);
1083 Var
1084   Obj : TTagNode;
1085 begin
1086   Obj:=GetTagObject(Node);
1087   NewText:=Trim(NewText);
1088   if Length(NewText)>20 then
1089     NewText:=Copy(NewText,1,20);
1090   if (NewText<>'') and Assigned(Obj) and (Obj.NodeType<>ntRoot) then
1091     Obj.Caption:=NewText;
1092 end;
1093 
1094 procedure TSrvForm.TimLogTimer(Sender: TObject);
1095 Var
1096   Event : TSrvEvent;
1097 begin
1098   // Update Log memo
1099   if Server.PickEvent(Event) then
1100   begin
1101     if Log.Lines.Count>1024 then  // In case you want to run this demo for several hours....
1102       Log.Lines.Clear;
1103     Log.Lines.Append(SrvEventText(Event));
1104   end;
1105   // Update other Infos
1106   ServerStatus:=Server.ServerStatus;
1107   ClientsCount:=Server.ClientsCount;
1108 end;
1109 
1110 procedure TSrvForm.TimTagTimer(Sender: TObject);
1111 Var
1112   CliTag : TClientTag;
1113 begin
1114   while not Queue.Empty do
1115   begin
1116     Queue.Extract(@CliTag);
1117     NewTag(CliTag);
1118   end;
1119 end;
1120 
1121 procedure TSrvForm.UpdateDBList(Obj : TTagNode);
1122 Var
1123   DBName : string;
1124   DBIdx  : integer;
1125   DB     : TResNode;
1126   DBNode : PVirtualNode;
1127 
1128   procedure NewDB;
1129   begin
1130     DB:=TResNode.Create(ntDB);
1131     DB.Caption:=DBName;
1132     DB.SizeNeeded:=Obj.TagLimit;
1133     DBNode:=RT.AddChild(ResRoot);
1134     PResTreeData(RT.GetNodeData(DBNode)).Obj:=DB;
1135     DBList.AddObject(DBName,DB);
1136   end;
1137 
1138 begin
1139   if Obj.Tag.Area=S7AreaDB then
1140   begin
1141     DBName:='DB '+IntToStr(Obj.Tag.DBNumber);
1142     DBIdx:=DBList.IndexOf(DBName);
1143     if DBIdx>=0 then
1144     begin
1145       DB:=TResNode(DBList.Objects[DBIdx]);
1146       if DB.SizeNeeded<Obj.TagLimit then
1147         DB.SizeNeeded:=Obj.TagLimit;
1148     end
1149     else
1150       NewDB;
1151     if DB.Changed then
1152       RT.FullExpand;
1153   end;
1154 end;
1155 
1156 end.
1157 
1158