112
var
dmServer: TdmServer;
implementation
{$R *.dfm}
uses udssmRemoteData;
procedure T dmServer.BroadcastStorageProductChanged;
var
//
Msg : TJSONString;
begin
//
Msg := TJSONString.Create ('StorageProductChanged');
DSServer.BroadcastMessage('SystemCallback', Msg);
end;
procedure T dmServer.BroadcastProductChanged;
var
//
Msg : TJSONString;
begin
//
Msg := TJSONString.Create ('ProductChanged');
DSServer.BroadcastMessage('SystemCallback', Msg);
113
function TdmServer.GetTable (TableName : String) : TADOTable;
begin
//
Result := TADOTable.Create(nil);
try
//
Result.Connection := adoConnection;
Result.TableName := TableName;
Result.Open;
except
//
on E : Exception do
begin
//
Result.Free;
raise;
end;
end;
end;
function TdmServer.GetQuery (SQL : String) : TADOQuery;
begin
//
Result := TADOQuery.Create(nil);
try
//
Result.Connection := adoConnection;
Result.SQL.Text := SQL;
Result.Open;
end;
except
114
//
on E : Exception do
begin
//
Result.Free;
raise;
end;
end;
end;
function TdmServer.ExecQuery (SQL : String) : Integer;
var
//
R : TADOQuery;
begin
//
R := TADOQuery.Create(nil);
try
//
R.Connection := adoConnection;
R.SQL.Text := SQL;
Result := R.ExecSQL;
finally
R.Free;
end;
end;
function TdmServer.GetUserKey (Login, Password : String; var Blocked :
Boolean; var UserType : Integer) : Integer;
var
115
T : TADOQuery;
begin
//
Result := 0;
T := TADOQuery.Create (nil);
T.Connection := adoConnection;
T.SQL.Text := 'select * from Пользователь where Логин = ' + QuotedStr
(Login);
try
//
T.Active := true;
if (T.RecordCount > 0) then
begin
//
if T.FieldByName('Пароль').AsString = Password then
begin
//
Result := T.FieldByName('Код').AsInteger;
UserType := T.FieldByName('Код_Тип_пользователя').AsInteger;
Blocked := T.FieldByName('Блокировать_доступ').AsBoolean;
end;
end;
finally
//
end;
T.Free;
//
end;
116
procedure TdmServer.DataModuleCreate(Sender: TObject);
function GetDataBaseName : String;
begin
//
Result := Settings.ReadString(c_Settings_Setion_Base,
c_Settings_Setion_Base_FileName, 'Base.mdb');
if (ExtractFilePath(Result) = ") then
begin
//
Result := ExtractFilePath(Application.ExeName) + Result;
end;
end;
begin
//
FSettings := TIniFile.Create (ExtractFilePath (Application.ExeName) + '\' +
c_Settings_File);
if adoConnection.Connected = true then
begin
ShowMessage ('adoConnection.Connected = true. Приложение будет
закрыто.');
Application.Terminate;
end;
adoConnection. ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4. 0;' +
'Data Source- + GetDataBaseName + ';' +
'Persist Security Info-False';
try
//
DSTCPServerTransport.Port :=
Settings.ReadInteg er(c_Settings_Setion_Server,
c_Settings_Setion_S erver_P ort,
117
0);
DSServer.Start;
adoConnection.Connected := True;
except
//
on E : Exception do
begin
//
Application.MainForm.Show;
MessageDlg (E.Message, mtError, [mbOK], 0);
MessageDlg ('Приложение будет закрыто.', mtInformation, [mbOK],
Application.Terminate;
end;
end;
5000);
end;
procedure TdmServer.DSAuthenticationManagerUserAuthenticate(Sender:
TObject;
const Protocol, Context, User, Password: string; var valid: Boolean;
UserRoles: TStrings);
var
//
UserKey, UserTypeKey : Integer;
CI : TConnectionInfo;
Blocked : Boolean;
begin
//
UserKey := GetUserKey (User, Password, Blocked, UserTypeKey);
if (UserTypeKey <> 1) and (UserTypeKey <> 2) and (UserTypeKey <> 9)
then
118
raise Exception.Create(^aHHOMy типу пользователей доступ закрыт');
if (Blocked = True) then raise Exception.Create('Вход в систему
невозможен. Ваш аккаунт заблокирован.');
valid := UserKey > 0;
if (valid = False) then
raise Exception.Create('Неверная пара логин/пароль.');
if valid = true then
begin
CI := ConnectionList.GetConnectionKey(GetCurrentThreadId);
CI.UserKey := UserKey;
CI.UserTypeKey := UserTypeKey;
end;
end;
procedure TdmServer.DSServerClassGetClass(DSServerClass:
TDSServerClass;
var PersistentClass: TPersistentClass);
begin
//
PersistentClass := udssmRemoteData.TdssmRemoteData;
end;
procedure T dmServer.DSTCPServerTransportConnect(
Event: TDSTCPConnectEventObject);
var
//
CI : TConnectionInfo;
begin
//
CI := ConnectionList.AddConnection(Windows.GetCurrentThreadId);
CI.IP := Event.Channel.ChannelInfo.ClientInfo.IpAddress;
CI.Channel := Event.Channel;
119
procedure T dmServer.DSTCPServerTransportDisconnect(
Event: TDSTCPDisconnectEventObject);
begin
//
ConnectionList.DelConnection(GetCurrentThreadId);
end;
procedure TdmServer.SendMessage (Email : string; Subject : string; Msg :
TStringList);
var
ServerAddress : String; ServerPort : Integer; Login : String; Password :
String;
Q : TADOQuery;
IdSMTP : TIdSMTP;
IdMsg : TIdMessage;
IdText : TIdText;
begin
//
Q := dmServer.GetQuery('select * from Параметры where Код = 1');
try
ServerAddress := Trim(Q.FieldByName ('Email_Адрес_сервера').Value);
Login := Trim(Q.FieldByName ('Email').Value);
Password := Q.FieldByName ('Email_Пароль').Value;
ServerPort := Q.FieldByName ('Email_Порт').AsInteger;
Email := Trim(Email);
if (Email = '') then
raise Exception.Create('Email получателя не задан');
if (ServerPort <= 0) then
raise Exception.Create('Порт почтового сервера не задан. См.
"Параметры"');
end;
120
if (ServerAddress = ") then
raise Exception.Create(Aдрес почтового сервера не задан. См.
"Параметры"');
if (Login = ") then
raise Exception.Create('Адрес электронной почты не задан. См.
"Параметры"');
if (Password = ") then
raise Exception.Create('Пароль для электронной почты не задан. См.
"Параметры"');
IdSMTP := TIdS MTP.Create(nil);
try
IdSMTP.Disconnect;
IdSMTP.Port := ServerPort;
IdSMTP.Host := ServerAddress;
IdSMTP.AuthType := satDefault;
IdSMTP.Username := Login;
IdSMTP.Password := Password;
IdSMTP.ConnectTimeout := 1000;
IdSMTP.Connect;
IdMsg := TIdMessage.Create (nil);
try
IdMsg.Subject := Subject; //текст темы сообщения
IdMsg.ContentType := 'multipart/mixed; charset=windows-1251';
IdMsg.Recipients.EMailAddresses := Email; //указываем адрес
получателя
IdMsg.From.Address := Login; //указываем автора
письма
IdMsg.Date := Now; //дата отправки письма
может быть любой
121
IdText := TIdText.Create(IdMsg.MessageParts, Msg);
try
IdText.CharSet := 'windows-1251';
IdSMTP.Send (IdMsg);
finally
IdText.Free;
end;
finally
//
IdMsg.Free;
end;
finally
IdSMTP.Free;
end;
finally
Q.Free;
end;
end;
end.
unit ufAnalyserParams;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls,
Vcl.DBCtrls;