1 unit MainServer; 2 3 {$MODE Delphi} 4 5 interface 6 7 uses 8 LCLIntf, LCLType, LMessages, Messages, SysUtils, Variants, Classes, Graphics, 9 Controls, Forms, Dialogs, ComCtrls, StdCtrls, CheckLst, ExtCtrls, 10 Snap7; 11 12 Const 13 DBSize = 2048; 14 15 type 16 17 { TFrmServer } 18 19 TFrmServer = class(TForm) 20 Log: TMemo; 21 SB: TStatusBar; 22 Panel1: TPanel; 23 PC: TPageControl; 24 TabSheet1: TTabSheet; 25 TabSheet2: TTabSheet; 26 TabSheet3: TTabSheet; 27 StartBtn: TButton; 28 EdIP: TEdit; 29 Label1: TLabel; 30 StopBtn: TButton; 31 List: TCheckListBox; 32 TabSheet4: TTabSheet; 33 Label2: TLabel; 34 lblMask: TLabel; 35 MemoDB1: TMemo; 36 MemoDB2: TMemo; 37 MemoDB3: TMemo; 38 EvtTimer: TTimer; 39 Splitter1: TSplitter; 40 LogTimer: TTimer; 41 procedure ListClick(Sender: TObject); 42 procedure FormCreate(Sender: TObject); 43 procedure LogTimerTimer(Sender: TObject); 44 procedure StartBtnClick(Sender: TObject); 45 procedure StopBtnClick(Sender: TObject); 46 procedure EvtTimerTimer(Sender: TObject); 47 procedure FormDestroy(Sender: TObject); 48 private 49 { Private declarations } 50 Server : TS7Server; 51 FMask : longword; 52 TIM : packed array[0..DBSize-1] of byte; 53 DB1 : packed array[0..DBSize-1] of byte; 54 DB2 : packed array[0..DBSize-1] of byte; 55 DB3 : packed array[0..DBSize-1] of byte; 56 FServerStatus: integer; 57 FClientsCount: integer; 58 procedure UpdateMask; 59 procedure MaskToForm; 60 procedure MaskToLabel; 61 procedure SetFMask(const Value: longword); 62 procedure DumpData(P : PS7Buffer; Memo : TMemo; Count : integer); 63 procedure SetFServerStatus(const Value: integer); 64 procedure SetFClientsCount(const Value: integer); 65 public 66 { Public declarations } 67 DB1_changed : boolean; 68 DB2_changed : boolean; 69 DB3_changed : boolean; 70 property LogMask : longword read FMask write SetFMask; 71 property ServerStatus : integer read FServerStatus write SetFServerStatus; 72 property ClientsCount : integer read FClientsCount write SetFClientsCount; 73 end; 74 75 var 76 FrmServer: TFrmServer; 77 78 implementation 79 80 {$R *.lfm} 81 82 procedure ServerCallback(usrPtr : pointer; PEvent : PSrvEvent; Size : integer); 83 {$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} 84 begin 85 // Checks if we are interested in this event. 86 // We need to update DB Memo contents only if our DB changed. 87 88 // To avoid this check, an alternative way could be to mask 89 // the Server.EventsMask property. 90 91 if (PEvent^.EvtCode=evcDataWrite) and // write event 92 (PEvent^.EvtRetCode=0) and // succesfully 93 (PEvent^.EvtParam1=S7AreaDB) then // it's a DB 94 begin 95 case PEvent^.EvtParam2 of 96 1 : TFrmServer(usrPtr).DB1_changed:=true; 97 2 : TFrmServer(usrPtr).DB2_changed:=true; 98 3 : TFrmServer(usrPtr).DB3_changed:=true; 99 end; 100 end; 101 end; 102 103 { TFrmServer } 104 105 procedure TFrmServer.DumpData(P: PS7Buffer; Memo: TMemo; Count: integer); 106 Var 107 SHex, SChr, SOfs : string; 108 Ch : AnsiChar; 109 c, cnt, ofs : integer; 110 begin 111 Memo.Lines.Clear; 112 Memo.Lines.BeginUpdate; 113 SHex:='';SChr:='';cnt:=0;ofs:=0; 114 try 115 for c := 0 to Count - 1 do 116 begin 117 SHex:=SHex+IntToHex(P^[c],2)+' '; 118 Ch:=AnsiChar(P^[c]); 119 if not (Ch in ['a'..'z','A'..'Z','0'..'9','_','$','-',#32]) then 120 Ch:='.'; 121 SChr:=SChr+String(Ch); 122 inc(cnt); 123 if cnt=16 then 124 begin 125 SOfs:=IntToHex(ofs,4); 126 Memo.Lines.Add(SOfs+' - '+SHex+' '+SChr); 127 SHex:='';SChr:=''; 128 cnt:=0; 129 ofs:=ofs+16; 130 end; 131 end; 132 // Dump remainder 133 if cnt>0 then 134 begin 135 while Length(SHex)<48 do 136 SHex:=SHex+' '; 137 SOfs:=IntToHex(ofs,4); 138 Memo.Lines.Add(SOfs+' - '+SHex+' '+SChr); 139 end; 140 finally 141 Memo.Lines.EndUpdate; 142 end; 143 end; 144 145 procedure TFrmServer.EvtTimerTimer(Sender: TObject); 146 begin 147 if DB1_changed then 148 begin 149 DumpData(@DB1,MemoDB1, SizeOf(DB1)); 150 DB1_changed :=false; 151 end; 152 if DB2_changed then 153 begin 154 DumpData(@DB2,MemoDB2, SizeOf(DB2)); 155 DB2_changed :=false; 156 end; 157 if DB3_changed then 158 begin 159 DumpData(@DB3,MemoDB3, SizeOf(DB3)); 160 DB3_changed :=false; 161 end; 162 end; 163 164 procedure TFrmServer.FormCreate(Sender: TObject); 165 var 166 ThePlatform : string; 167 Wide : string; 168 begin 169 // Cosmetics 170 // Infamous trick to get the platform size 171 // Maybe it could not work ever, but we need only a form caption.... 172 case SizeOf(NativeUint) of 173 4 : Wide := ' [32 bit]'; 174 8 : Wide := ' [64 bit]'; 175 else Wide := ' [?? bit]'; 176 end; 177 {$IFDEF MSWINDOWS} 178 ThePlatform:='Windows platform'; 179 {$ELSE} 180 Platform:='Unix platform'; 181 {$ENDIF} 182 Caption:='Snap7 Server Demo - '+ThePlatform+Wide+ 183 {$IFDEF FPC} 184 ' [Lazarus]'; 185 {$ELSE} 186 ' [Delphi/RAD studio]'; 187 {$ENDIF} 188 189 PC.ActivePageIndex:=0; 190 DumpData(@DB1,MemoDB1,SizeOf(DB1)); 191 DumpData(@DB2,MemoDB2,SizeOf(DB2)); 192 DumpData(@DB3,MemoDB3,SizeOf(DB3)); 193 StopBtn.Enabled:=false; 194 FServerStatus:=-1; // to force update on start 195 FClientsCount:=-1; 196 197 // Server creation 198 Server:=TS7Server.Create; 199 // Add some shared resources 200 Server.RegisterArea(srvAreaDB, // it's DB 201 1, // Number 1 (DB1) 202 @DB1, // Its address 203 SizeOf(DB1)); // Its size 204 Server.RegisterArea(srvAreaDB,2,@DB2,SizeOf(DB2)); // same as above 205 Server.RegisterArea(srvAreaDB,3,@DB3,SizeOf(DB3)); // same as above 206 Server.RegisterArea(srvAreaTM,0,@TIM,SizeOf(TIM)); 207 // Setup the callback 208 Server.SetEventsCallback(@ServerCallback, self); 209 // Note 210 // Set the callback and set Events/Log mask are optional, 211 // we call them only if we need. 212 // Also Register area is optional, but a server without shared areas is 213 // not very useful :-) however it works and it's recognized by simatic manager. 214 215 LogMask:=Server.LogMask; // Get the current mask, always $FFFFFFFF on startup 216 end; 217 218 procedure TFrmServer.LogTimerTimer(Sender: TObject); 219 Var 220 Event : TSrvEvent; 221 begin 222 // Update Log memo 223 if Server.PickEvent(Event) then 224 begin 225 if Log.Lines.Count>1024 then // In case you want to run this demo for several hours.... 226 Log.Lines.Clear; 227 Log.Lines.Append(SrvEventText(Event)); 228 end; 229 // Update other Infos 230 ServerStatus:=Server.ServerStatus; 231 ClientsCount:=Server.ClientsCount; 232 end; 233 234 procedure TFrmServer.FormDestroy(Sender: TObject); 235 begin 236 Server.Free; 237 end; 238 239 procedure TFrmServer.UpdateMask; 240 Var 241 c: Integer; 242 BitMask : longword; 243 begin 244 BitMask:=$00000001; 245 for c := 0 to 31 do 246 begin 247 if List.Checked[c] then 248 FMask:=FMask or BitMask 249 else 250 FMask:=FMask and not BitMask; 251 BitMask:=BitMask shl 1; 252 end; 253 Server.LogMask:=FMask; 254 end; 255 256 procedure TFrmServer.ListClick(Sender: TObject); 257 begin 258 UpdateMask; 259 MaskToLabel; 260 end; 261 262 procedure TFrmServer.MaskToForm; 263 Var 264 c: Integer; 265 BitMask : longword; 266 begin 267 BitMask:=$00000001; 268 for c := 0 to 31 do 269 begin 270 List.Checked[c]:=(FMask and BitMask)<>0; 271 BitMask:=BitMask shl 1; 272 end; 273 end; 274 275 procedure TFrmServer.MaskToLabel; 276 begin 277 lblMask.Caption:='$'+IntToHex(FMask,8); 278 end; 279 280 procedure TFrmServer.SetFClientsCount(const Value: integer); 281 begin 282 if FClientsCount <> Value then 283 begin 284 FClientsCount := Value; 285 SB.Panels[1].Text:='Clients : '+IntToStr(FClientsCount); 286 end; 287 end; 288 289 procedure TFrmServer.SetFMask(const Value: longword); 290 begin 291 if FMask <> Value then 292 begin 293 FMask := Value; 294 MaskToForm; 295 MaskToLabel; 296 end; 297 end; 298 299 procedure TFrmServer.SetFServerStatus(const Value: integer); 300 begin 301 if FServerStatus <> Value then 302 begin 303 FServerStatus := Value; 304 case FServerStatus of 305 SrvStopped : SB.Panels[0].Text:='Stopped'; 306 SrvRunning : SB.Panels[0].Text:='Running'; 307 SrvError : SB.Panels[0].Text:='Error'; 308 end; 309 end; 310 end; 311 312 procedure TFrmServer.StartBtnClick(Sender: TObject); 313 Var 314 res : integer; 315 begin 316 res :=Server.StartTo(EdIP.Text); 317 if res=0 then 318 begin 319 StartBtn.Enabled:=false; 320 EdIP.Enabled:=false; 321 StopBtn.Enabled:=true; 322 end 323 else 324 SB.Panels[2].Text:=SrvErrorText(res); 325 end; 326 327 procedure TFrmServer.StopBtnClick(Sender: TObject); 328 begin 329 Server.Stop; 330 StopBtn.Enabled:=false; 331 StartBtn.Enabled:=true; 332 EdIP.Enabled:=true; 333 end; 334 335 end. 336