Files
ewsdr/DeviceForm.pas
T
2026-05-21 14:23:08 +03:00

682 lines
19 KiB
ObjectPascal
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
unit DeviceForm;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FlatButton, AppTheme, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, IniFiles;
// Декодирование типа платы (совпадает с MainForm.BoardTypeName)
function BoardTypeName(BoardType: Integer): string;
const
DEVICE_CFG_FILE = 'hpsdr_devices.ini';
type
// Запись о сохранённом устройстве
TSavedDevice = record
Name: string; // пользовательское имя
IPAddress: string;
BoardType: Integer;
AutoStart: Boolean; // запускать автоматически при старте
end;
// Результат диалога
TDeviceDialogResult = record
Accepted: Boolean;
IPAddress: string;
SavedIdx: Integer; // -1 если выбрали из discovery, иначе индекс в SavedDevices
end;
{ TDeviceDialog }
TDeviceDialog = class(TForm)
private
// Сохранённые устройства
FSavedDevices: array of TSavedDevice;
FSavedCount: Integer;
FResult: TDeviceDialogResult;
// Discovered devices (IP strings)
FDiscoveredIPs: array of string;
FDiscoveredNames: array of string;
FDiscoveredBoardTypes: array of Integer;
FDiscoveredCount: Integer;
// UI
PanelTop: TPanel;
PanelBottom: TPanel;
PanelLeft: TPanel;
PanelRight: TPanel;
LblSaved: TLabel;
LstSaved: TListBox;
BtnAdd: TFlatButton;
BtnRemove: TFlatButton;
BtnSetAuto: TFlatButton;
EdName: TEdit;
EdIP: TEdit;
LblName: TLabel;
LblIP: TLabel;
LblFound: TLabel;
LstFound: TListBox;
BtnDiscover: TFlatButton;
BtnAddFound: TFlatButton;
BtnConnect: TFlatButton;
BtnCancel: TFlatButton;
FOnDiscover: TNotifyEvent; // внешний callback для запуска discovery
procedure BuildUI;
procedure ApplyTheme;
procedure LoadSaved;
procedure SaveSaved;
procedure RefreshSavedList;
procedure BtnDiscoverClick(Sender: TObject);
procedure BtnAddClick(Sender: TObject);
procedure BtnRemoveClick(Sender: TObject);
procedure BtnSetAutoClick(Sender: TObject);
procedure BtnAddFoundClick(Sender: TObject);
procedure BtnConnectClick(Sender: TObject);
procedure BtnCancelClick(Sender: TObject);
procedure LstSavedDblClick(Sender: TObject);
procedure LstFoundDblClick(Sender: TObject);
procedure LstSavedClick(Sender: TObject);
function MakeBtn(AParent: TWinControl; const Cap: string;
X, Y, W, H: Integer; AClick: TNotifyEvent): TFlatButton;
function MakeLbl(AParent: TWinControl; const Cap: string;
X, Y: Integer): TLabel;
public
constructor Create(AOwner: TComponent); override;
procedure SetTheme(const T: TAppTheme);
// Добавить найденное устройство (вызывается из MainForm при discovery)
procedure AddDiscovered(const IP, DisplayName: string; BoardType: Integer = 0);
procedure ClearDiscovered;
// Автозапуск: возвращает IP если есть устройство с AutoStart=True
function GetAutoStartIP: string;
function GetAutoStartBoardType: Integer;
function GetSavedBoardType(Idx: Integer): Integer;
// Получить/сбросить результат
procedure ClearResult;
property DialogResult: TDeviceDialogResult read FResult;
property OnDiscover: TNotifyEvent read FOnDiscover write FOnDiscover;
property SavedCount: Integer read FSavedCount;
end;
implementation
function BoardTypeName(BoardType: Integer): string;
begin
case BoardType of
1: Result := 'HERMES (ANAN-10/100)';
2: Result := 'HERMES-E (ANAN-10E/100B)';
3: Result := 'ANGELIA (ANAN-100D)';
4: Result := 'ORION (ANAN-200D)';
5: Result := 'ORION MkII (ANAN-7000/8000)';
6: Result := 'HERMES-LITE 2';
10: Result := 'SATURN (G2)';
else Result := Format('Unknown Board #%d', [BoardType]);
end;
end;
const
CLR_BG = TColor($00121212);
CLR_PANEL = TColor($001A1A1A);
CLR_TEXT = TColor($00E0E0E0);
CLR_TEXTDIM = TColor($00888888);
CLR_BORDER = TColor($00303030);
CLR_ACCENT = TColor($0040FF80);
CLR_AUTO = TColor($0000CCFF); // цвет авто-устройства
DLG_W = 760;
DLG_H = 500;
GAP = 12;
PAD = 14;
BTN_H = 28;
EDIT_H = 26;
PANEL_H = 412;
LEFT_W = 348;
RIGHT_W = 372;
{ TDeviceDialog }
constructor TDeviceDialog.Create(AOwner: TComponent);
begin
inherited CreateNew(AOwner);
Caption := 'Device Selection';
Width := DLG_W;
Height := DLG_H;
Position := poScreenCenter;
BorderStyle := bsDialog;
Color := CLR_BG;
Font.Name := 'Courier New';
Font.Size := 8;
Font.Color := CLR_TEXT;
FSavedCount := 0;
FDiscoveredCount := 0;
FResult.Accepted := False;
BuildUI;
SetTheme(DarkTheme);
LoadSaved;
RefreshSavedList;
end;
function TDeviceDialog.MakeBtn(AParent: TWinControl; const Cap: string;
X, Y, W, H: Integer; AClick: TNotifyEvent): TFlatButton;
begin
Result := MakeFlatBtn(AParent, Cap, X, Y, W, H, AClick);
end;
function TDeviceDialog.MakeLbl(AParent: TWinControl; const Cap: string;
X, Y: Integer): TLabel;
begin
Result := TLabel.Create(Self);
Result.Parent := AParent;
Result.Caption := Cap;
Result.Left := X; Result.Top := Y;
Result.Font.Name := 'Courier New';
Result.Font.Size := 8;
Result.Font.Color := CLR_TEXTDIM;
end;
procedure TDeviceDialog.BuildUI;
const
LabelH = 18;
var
LblHint: TLabel;
FieldTop, ButtonsTop, BottomTop: Integer;
begin
// --- Левая панель: сохранённые устройства ---
PanelLeft := TPanel.Create(Self);
PanelLeft.Parent := Self;
PanelLeft.SetBounds(GAP, GAP, LEFT_W, PANEL_H);
PanelLeft.BevelOuter := bvNone;
PanelLeft.Color := CLR_PANEL;
MakeLbl(PanelLeft, 'SAVED DEVICES', PAD, PAD);
LstSaved := TListBox.Create(Self);
LstSaved.Parent := PanelLeft;
LstSaved.SetBounds(PAD, PAD + LabelH, LEFT_W - PAD * 2, 174);
LstSaved.Color := CLR_BG;
LstSaved.Font.Color:= CLR_TEXT;
LstSaved.Font.Name := 'Courier New';
LstSaved.Font.Size := 8;
LstSaved.OnClick := @LstSavedClick;
LstSaved.OnDblClick := @LstSavedDblClick;
FieldTop := 212;
MakeLbl(PanelLeft, 'Name:', PAD, FieldTop + 5);
EdName := TEdit.Create(Self);
EdName.Parent := PanelLeft;
EdName.SetBounds(76, FieldTop, LEFT_W - 76 - PAD, EDIT_H);
EdName.Color := CLR_BG;
EdName.Font.Color:= CLR_TEXT;
EdName.Font.Name := 'Courier New';
EdName.Font.Size := 8;
Inc(FieldTop, EDIT_H + 10);
MakeLbl(PanelLeft, 'IP:', PAD, FieldTop + 5);
EdIP := TEdit.Create(Self);
EdIP.Parent := PanelLeft;
EdIP.SetBounds(76, FieldTop, LEFT_W - 76 - PAD, EDIT_H);
EdIP.Color := CLR_BG;
EdIP.Font.Color:= CLR_TEXT;
EdIP.Font.Name := 'Courier New';
EdIP.Font.Size := 8;
EdIP.TextHint := '192.168.1.x';
ButtonsTop := FieldTop + EDIT_H + 12;
BtnAdd := MakeBtn(PanelLeft, 'ADD', PAD, ButtonsTop, 94, BTN_H, @BtnAddClick);
BtnRemove := MakeBtn(PanelLeft, 'REMOVE', PAD + 102, ButtonsTop, 94, BTN_H, @BtnRemoveClick);
Inc(ButtonsTop, BTN_H + 8);
BtnSetAuto := MakeBtn(PanelLeft, 'SET AUTOSTART', PAD, ButtonsTop, 154, BTN_H, @BtnSetAutoClick);
LblHint := MakeLbl(PanelLeft, '* = autostart', PAD + 168, ButtonsTop + 6);
LblHint.Font.Color := CLR_AUTO;
BottomTop := PANEL_H - PAD - BTN_H - 6;
BtnConnect := MakeBtn(PanelLeft, 'CONNECT', PAD, BottomTop, LEFT_W - PAD * 2, BTN_H + 6, @BtnConnectClick);
BtnConnect.ClrText := CLR_ACCENT;
BtnConnect.ClrTextAct := CLR_ACCENT;
// --- Правая панель: discovery ---
PanelRight := TPanel.Create(Self);
PanelRight.Parent := Self;
PanelRight.SetBounds(GAP + LEFT_W + GAP, GAP, RIGHT_W, PANEL_H);
PanelRight.BevelOuter := bvNone;
PanelRight.Color := CLR_PANEL;
MakeLbl(PanelRight, 'DISCOVERED DEVICES', PAD, PAD);
LstFound := TListBox.Create(Self);
LstFound.Parent := PanelRight;
LstFound.SetBounds(PAD, PAD + LabelH, RIGHT_W - PAD * 2, 250);
LstFound.Color := CLR_BG;
LstFound.Font.Color:= CLR_TEXT;
LstFound.Font.Name := 'Courier New';
LstFound.Font.Size := 8;
LstFound.OnDblClick := @LstFoundDblClick;
ButtonsTop := PAD + LabelH + 250 + 14;
BtnDiscover := MakeBtn(PanelRight, 'DISCOVER', PAD, ButtonsTop, 116, BTN_H, @BtnDiscoverClick);
BtnAddFound := MakeBtn(PanelRight, 'SAVE DEVICE', PAD + 128, ButtonsTop, 140, BTN_H, @BtnAddFoundClick);
BtnCancel := MakeBtn(PanelRight, 'CANCEL', RIGHT_W - PAD - 116, BottomTop, 116, BTN_H + 6, @BtnCancelClick);
end;
procedure TDeviceDialog.ApplyTheme;
begin
SetTheme(DarkTheme);
end;
procedure TDeviceDialog.SetTheme(const T: TAppTheme);
procedure StyleButton(B: TFlatButton; Active: Boolean);
begin
if B = nil then Exit;
B.Active := Active;
B.ClrNorm := T.BtnNorm;
B.ClrActive := T.BtnActive;
B.ClrHot := T.BtnHot;
if Active then B.ClrBorder := T.BtnBorderActive
else B.ClrBorder := T.BtnBorderNorm;
B.ClrText := T.BtnText;
B.ClrTextAct := T.BtnTextActive;
B.Font.Name := 'Courier New';
B.Font.Size := 8;
B.Font.Color := T.Text;
B.Invalidate;
end;
procedure StyleDiscoverButton(B: TFlatButton);
begin
if B = nil then Exit;
B.Active := False;
B.ClrNorm := T.TbDiscoverNorm;
B.ClrHot := T.TbDiscoverHot;
B.ClrActive := T.TbDiscoverHot;
B.ClrBorder := T.TbDiscoverBorder;
B.ClrText := T.TbDiscoverText;
B.ClrTextAct := T.TbDiscoverText;
B.Font.Name := 'Courier New';
B.Font.Size := 8;
B.Font.Color := T.TbDiscoverText;
B.Invalidate;
end;
procedure StyleConnectButton(B: TFlatButton);
begin
if B = nil then Exit;
B.Active := False;
B.ClrNorm := T.TbStartNorm;
B.ClrActive := T.BtnActive;
B.ClrHot := T.BtnHot;
B.ClrBorder := T.TbStartBorder;
B.ClrText := T.TbStartText;
B.ClrTextAct := T.TbStartText;
B.Font.Name := 'Courier New';
B.Font.Size := 8;
B.Font.Color := T.TbStartText;
B.Invalidate;
end;
procedure WalkLabels(C: TWinControl);
var i: Integer; Ctrl: TControl;
begin
for i := 0 to C.ControlCount - 1 do
begin
Ctrl := C.Controls[i];
if Ctrl is TLabel then
TLabel(Ctrl).Font.Color := T.TextDim
else if Ctrl is TWinControl then
WalkLabels(TWinControl(Ctrl));
end;
end;
begin
Color := T.BG;
Font.Color := T.Text;
if PanelLeft <> nil then PanelLeft.Color := T.Panel;
if PanelRight <> nil then PanelRight.Color := T.Panel;
if LstSaved <> nil then begin
LstSaved.Color := T.BG;
LstSaved.Font.Color := T.Text;
end;
if LstFound <> nil then begin
LstFound.Color := T.BG;
LstFound.Font.Color := T.Text;
end;
StyleButton(BtnAdd, False);
StyleButton(BtnRemove, False);
StyleButton(BtnSetAuto, False);
StyleDiscoverButton(BtnDiscover);
StyleButton(BtnAddFound, False);
StyleButton(BtnCancel, False);
StyleConnectButton(BtnConnect);
// Edit fields: white bg for light theme, dark bg for dark theme
if Integer(T.BG) > Integer(TColor($00808080)) then
begin
if EdName <> nil then begin EdName.Color := TColor($00FFFFFF); EdName.Font.Color := TColor($00202020); end;
if EdIP <> nil then begin EdIP.Color := TColor($00FFFFFF); EdIP.Font.Color := TColor($00202020); end;
end
else
begin
if EdName <> nil then begin EdName.Color := TColor($00121212); EdName.Font.Color := TColor($00E0E0E0); end;
if EdIP <> nil then begin EdIP.Color := TColor($00121212); EdIP.Font.Color := TColor($00E0E0E0); end;
end;
WalkLabels(Self);
Invalidate;
end;
procedure TDeviceDialog.LoadSaved;
var
Ini: TIniFile;
I, N: Integer;
Section: string;
begin
FSavedCount := 0;
if not FileExists(DEVICE_CFG_FILE) then Exit;
Ini := TIniFile.Create(DEVICE_CFG_FILE);
try
N := Ini.ReadInteger('Devices', 'Count', 0);
SetLength(FSavedDevices, N);
for I := 0 to N - 1 do
begin
Section := 'Device' + IntToStr(I);
FSavedDevices[I].Name := Ini.ReadString (Section, 'Name', 'HPSDR');
FSavedDevices[I].IPAddress := Ini.ReadString (Section, 'IP', '');
FSavedDevices[I].BoardType := Ini.ReadInteger(Section, 'BoardType', 0);
FSavedDevices[I].AutoStart := Ini.ReadBool (Section, 'AutoStart', False);
Inc(FSavedCount);
end;
finally
Ini.Free;
end;
end;
procedure TDeviceDialog.SaveSaved;
var
Ini: TIniFile;
I: Integer;
Section: string;
begin
Ini := TIniFile.Create(DEVICE_CFG_FILE);
try
Ini.WriteInteger('Devices', 'Count', FSavedCount);
for I := 0 to FSavedCount - 1 do
begin
Section := 'Device' + IntToStr(I);
Ini.WriteString (Section, 'Name', FSavedDevices[I].Name);
Ini.WriteString (Section, 'IP', FSavedDevices[I].IPAddress);
Ini.WriteInteger(Section, 'BoardType', FSavedDevices[I].BoardType);
Ini.WriteBool (Section, 'AutoStart', FSavedDevices[I].AutoStart);
end;
finally
Ini.Free;
end;
end;
procedure TDeviceDialog.RefreshSavedList;
var
I: Integer;
S: string;
begin
LstSaved.Items.Clear;
for I := 0 to FSavedCount - 1 do
begin
S := FSavedDevices[I].Name + ' [' + FSavedDevices[I].IPAddress + ']';
if FSavedDevices[I].BoardType > 0 then
S := S + ' ' + BoardTypeName(FSavedDevices[I].BoardType);
if FSavedDevices[I].AutoStart then
S := '* ' + S;
LstSaved.Items.Add(S);
end;
end;
procedure TDeviceDialog.LstSavedClick(Sender: TObject);
var
Idx: Integer;
begin
Idx := LstSaved.ItemIndex;
if (Idx < 0) or (Idx >= FSavedCount) then Exit;
EdName.Text := FSavedDevices[Idx].Name;
EdIP.Text := FSavedDevices[Idx].IPAddress;
end;
procedure TDeviceDialog.LstSavedDblClick(Sender: TObject);
begin
BtnConnectClick(nil);
end;
procedure TDeviceDialog.LstFoundDblClick(Sender: TObject);
begin
BtnConnectClick(nil);
end;
procedure TDeviceDialog.BtnDiscoverClick(Sender: TObject);
begin
LstFound.Items.Clear;
LstFound.Items.Add('Searching...');
if Assigned(FOnDiscover) then
FOnDiscover(Self);
end;
procedure TDeviceDialog.ClearDiscovered;
begin
FDiscoveredCount := 0;
SetLength(FDiscoveredIPs, 0);
SetLength(FDiscoveredNames, 0);
SetLength(FDiscoveredBoardTypes, 0);
LstFound.Items.Clear;
end;
procedure TDeviceDialog.AddDiscovered(const IP, DisplayName: string; BoardType: Integer = 0);
var
Idx: Integer;
S: string;
begin
if (LstFound.Items.Count = 1) and (LstFound.Items[0] = 'Searching...') then
LstFound.Items.Clear;
Idx := FDiscoveredCount;
Inc(FDiscoveredCount);
SetLength(FDiscoveredIPs, FDiscoveredCount);
SetLength(FDiscoveredNames, FDiscoveredCount);
SetLength(FDiscoveredBoardTypes, FDiscoveredCount);
FDiscoveredIPs[Idx] := IP;
FDiscoveredNames[Idx] := DisplayName;
FDiscoveredBoardTypes[Idx] := BoardType;
S := DisplayName;
if BoardType > 0 then
S := S + ' ' + BoardTypeName(BoardType);
LstFound.Items.Add(S);
end;
procedure TDeviceDialog.BtnAddClick(Sender: TObject);
var
Idx: Integer;
begin
if Trim(EdIP.Text) = '' then
begin
ShowMessage('Enter IP address');
Exit;
end;
Idx := FSavedCount;
Inc(FSavedCount);
SetLength(FSavedDevices, FSavedCount);
FSavedDevices[Idx].Name := Trim(EdName.Text);
if FSavedDevices[Idx].Name = '' then
FSavedDevices[Idx].Name := 'HPSDR';
FSavedDevices[Idx].IPAddress := Trim(EdIP.Text);
FSavedDevices[Idx].BoardType := 0;
FSavedDevices[Idx].AutoStart := False;
SaveSaved;
RefreshSavedList;
LstSaved.ItemIndex := Idx;
end;
procedure TDeviceDialog.BtnRemoveClick(Sender: TObject);
var
Idx, I: Integer;
begin
Idx := LstSaved.ItemIndex;
if (Idx < 0) or (Idx >= FSavedCount) then Exit;
for I := Idx to FSavedCount - 2 do
FSavedDevices[I] := FSavedDevices[I + 1];
Dec(FSavedCount);
SetLength(FSavedDevices, FSavedCount);
SaveSaved;
RefreshSavedList;
EdName.Text := '';
EdIP.Text := '';
end;
procedure TDeviceDialog.BtnSetAutoClick(Sender: TObject);
var
Idx, I: Integer;
begin
Idx := LstSaved.ItemIndex;
if (Idx < 0) or (Idx >= FSavedCount) then
begin
ShowMessage('Select a device first');
Exit;
end;
// Только одно устройство может быть AutoStart
for I := 0 to FSavedCount - 1 do
FSavedDevices[I].AutoStart := (I = Idx);
SaveSaved;
RefreshSavedList;
LstSaved.ItemIndex := Idx;
end;
procedure TDeviceDialog.BtnAddFoundClick(Sender: TObject);
var
Idx: Integer;
begin
Idx := LstFound.ItemIndex;
if (Idx < 0) or (Idx >= FDiscoveredCount) then
begin
ShowMessage('Select a discovered device first');
Exit;
end;
EdIP.Text := FDiscoveredIPs[Idx];
EdName.Text := FDiscoveredNames[Idx];
BtnAddClick(nil);
// Обновляем BoardType только что добавленной записи
if FSavedCount > 0 then
begin
FSavedDevices[FSavedCount - 1].BoardType := FDiscoveredBoardTypes[Idx];
SaveSaved;
RefreshSavedList;
LstSaved.ItemIndex := FSavedCount - 1;
end;
end;
procedure TDeviceDialog.BtnConnectClick(Sender: TObject);
var
IP: string;
Idx: Integer;
begin
IP := '';
// Приоритет: выбранное сохранённое > выбранное найденное > ручной IP
Idx := LstSaved.ItemIndex;
if (Idx >= 0) and (Idx < FSavedCount) then
begin
IP := FSavedDevices[Idx].IPAddress;
FResult.SavedIdx := Idx;
end
else
begin
Idx := LstFound.ItemIndex;
if (Idx >= 0) and (Idx < FDiscoveredCount) then
begin
IP := FDiscoveredIPs[Idx];
FResult.SavedIdx := -1;
end
else if Trim(EdIP.Text) <> '' then
begin
IP := Trim(EdIP.Text);
FResult.SavedIdx := -1;
end;
end;
if IP = '' then
begin
ShowMessage('Select or enter a device to connect');
Exit;
end;
FResult.Accepted := True;
FResult.IPAddress := IP;
ModalResult := mrOk;
end;
procedure TDeviceDialog.BtnCancelClick(Sender: TObject);
begin
FResult.Accepted := False;
ModalResult := mrCancel;
end;
procedure TDeviceDialog.ClearResult;
begin
FResult.Accepted := False;
FResult.IPAddress := '';
FResult.SavedIdx := -1;
end;
function TDeviceDialog.GetAutoStartIP: string;
var
I: Integer;
begin
Result := '';
for I := 0 to FSavedCount - 1 do
if FSavedDevices[I].AutoStart then
begin
Result := FSavedDevices[I].IPAddress;
Exit;
end;
end;
function TDeviceDialog.GetAutoStartBoardType: Integer;
var
I: Integer;
begin
Result := 0;
for I := 0 to FSavedCount - 1 do
if FSavedDevices[I].AutoStart then
begin
Result := FSavedDevices[I].BoardType;
Exit;
end;
end;
function TDeviceDialog.GetSavedBoardType(Idx: Integer): Integer;
begin
if (Idx >= 0) and (Idx < FSavedCount) then
Result := FSavedDevices[Idx].BoardType
else
Result := 0;
end;
end.