Files
ewsdr/DeviceForm.pas
ew8bakandClaude Sonnet 5 c95620fb23 fix(ui): DPI-масштабирование SettingsForm/DeviceForm + общий DpiScale
Вся раскладка окон, построенных кодом (SettingsForm, DeviceForm), была
захардкожена в пикселях под неявные 96 DPI — на Windows 125-200% или
HiDPI-десктопах контролы физически не росли вместе с укрупнившимся
шрифтом. Добавлено масштабирование SetBounds через MulDiv(V,
Screen.PixelsPerInch, 96) на каждой листовой точке потребления
(const-блоки раскладки не трогались).

Общий DpiScale вынесен в новый юнит DpiUtils.pas — убрана дублированная
копия одноимённого приватного метода в 9 классах (FlatCheckBox,
FlatComboBox, FlatListBox, FlatSpinEdit, FlatFloatSpinEdit, FlatEdit,
FlatRadioButton, FlatPopupMenu, SettingsForm, DeviceForm) и инлайн-MulDiv
без обёртки в MainForm.pas/PanafallPanel.pas.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
2026-07-29 16:05:39 +03:00

564 lines
17 KiB
ObjectPascal
Raw Permalink 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, FlatEdit, FlatListBox, AppTheme, Forms, Controls, Graphics, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, LCLType,
BoardUtils, PlatformUtils, DeviceStore, RadioBackend, DpiUtils;
type
// Результат диалога
TDeviceDialogResult = record
Accepted: Boolean;
IPAddress: string;
SavedIdx: Integer; // -1 если выбрали из discovery, иначе индекс в SavedDevices
end;
{ TDeviceDialog }
TDeviceDialog = class(TForm)
private
// Общее хранилище устройств (saved+discovered) — единый источник правды,
// владелец контроллер; диалог только рендерит и редактирует через него.
FStore: TDeviceStore;
FResult: TDeviceDialogResult;
// UI
PanelTop: TPanel;
PanelBottom: TPanel;
PanelLeft: TPanel;
PanelRight: TPanel;
LblSaved: TLabel;
LstSaved: TFlatListBox;
BtnAdd: TFlatButton;
BtnRemove: TFlatButton;
BtnSetAuto: TFlatButton;
EdName: TFlatEdit;
EdIP: TFlatEdit;
LblName: TLabel;
LblIP: TLabel;
LblFound: TLabel;
LstFound: TFlatListBox;
BtnDiscover: TFlatButton;
BtnAddFound: TFlatButton;
BtnConnect: TFlatButton;
BtnCancel: TFlatButton;
FOnDiscover: TNotifyEvent; // внешний callback для запуска discovery
procedure BuildUI;
procedure ApplyTheme;
procedure SetStore(AStore: TDeviceStore);
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);
// Перерисовать список найденных из store (вызывается по rfDeviceList)
procedure RefreshFound;
procedure ClearDiscovered;
procedure NoDevicesFound; // UI-сообщение «нет устройств» в список найденных
// Автозапуск: возвращает IP если есть устройство с AutoStart=True
function GetAutoStartIP: string;
function GetAutoStartBoardType: Integer;
function GetSavedBoardType(Idx: Integer): Integer;
// Текст поля ручного ввода IP/URI (для probe сетевых Pluto при discovery).
function ManualIP: string;
// Получить/сбросить результат
procedure ClearResult;
// Общее хранилище устройств — назначается владельцем (MainForm/контроллер)
// до показа диалога; диалог рендерит и редактирует через него.
property Store: TDeviceStore read FStore write SetStore;
property DialogResult: TDeviceDialogResult read FResult;
property OnDiscover: TNotifyEvent read FOnDiscover write FOnDiscover;
end;
implementation
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 := DpiScale(DLG_W);
Height := DpiScale(DLG_H);
Position := poScreenCenter;
BorderStyle := bsDialog;
Color := CLR_BG;
Font.Name := 'Courier New';
Font.Size := 8;
Font.Color := CLR_TEXT;
FStore := nil; // назначается владельцем через property Store до показа
FResult.Accepted := False;
BuildUI;
SetTheme(DarkTheme);
end;
procedure TDeviceDialog.SetStore(AStore: TDeviceStore);
begin
FStore := AStore;
if FStore <> nil then RefreshSavedList;
end;
function TDeviceDialog.MakeBtn(AParent: TWinControl; const Cap: string;
X, Y, W, H: Integer; AClick: TNotifyEvent): TFlatButton;
begin
// MakeFlatBtn — общая фабрика в FlatButton.pas, используется и другими
// окнами (PanafallPanel/PopSignalPopup/...) со своей раскладкой; масштаб
// применяем только здесь, на границе вызова из DeviceForm, а не внутри
// самой MakeFlatBtn (иначе задело бы все остальные вызовы).
Result := MakeFlatBtn(AParent, Cap, DpiScale(X), DpiScale(Y), DpiScale(W), DpiScale(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 := DpiScale(X); Result.Top := DpiScale(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(DpiScale(GAP), DpiScale(GAP), DpiScale(LEFT_W), DpiScale(PANEL_H));
PanelLeft.BevelOuter := bvNone;
PanelLeft.Color := CLR_PANEL;
MakeLbl(PanelLeft, 'SAVED DEVICES', PAD, PAD);
LstSaved := TFlatListBox.Create(Self);
LstSaved.Parent := PanelLeft;
LstSaved.SetBounds(DpiScale(PAD), DpiScale(PAD + LabelH), DpiScale(LEFT_W - PAD * 2), DpiScale(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 := TFlatEdit.Create(Self);
EdName.Parent := PanelLeft;
EdName.SetBounds(DpiScale(76), DpiScale(FieldTop), DpiScale(LEFT_W - 76 - PAD), DpiScale(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 := TFlatEdit.Create(Self);
EdIP.Parent := PanelLeft;
EdIP.SetBounds(DpiScale(76), DpiScale(FieldTop), DpiScale(LEFT_W - 76 - PAD), DpiScale(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(DpiScale(GAP + LEFT_W + GAP), DpiScale(GAP), DpiScale(RIGHT_W), DpiScale(PANEL_H));
PanelRight.BevelOuter := bvNone;
PanelRight.Color := CLR_PANEL;
MakeLbl(PanelRight, 'DISCOVERED DEVICES', PAD, PAD);
LstFound := TFlatListBox.Create(Self);
LstFound.Parent := PanelRight;
LstFound.SetBounds(DpiScale(PAD), DpiScale(PAD + LabelH), DpiScale(RIGHT_W - PAD * 2), DpiScale(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 LstSaved.SetAppTheme(T);
if LstFound <> nil then LstFound.SetAppTheme(T);
StyleButton(BtnAdd, False);
StyleButton(BtnRemove, False);
StyleButton(BtnSetAuto, False);
StyleDiscoverButton(BtnDiscover);
StyleButton(BtnAddFound, False);
StyleButton(BtnCancel, False);
StyleConnectButton(BtnConnect);
if EdName <> nil then EdName.SetAppTheme(T);
if EdIP <> nil then EdIP.SetAppTheme(T);
WalkLabels(Self);
Invalidate;
end;
procedure TDeviceDialog.RefreshSavedList;
var
I: Integer;
begin
LstSaved.Items.Clear;
if FStore = nil then Exit;
for I := 0 to FStore.SavedCount - 1 do
LstSaved.Items.Add(FStore.SavedDisplay(I));
end;
procedure TDeviceDialog.LstSavedClick(Sender: TObject);
var
Idx: Integer;
Dev: TSavedDevice;
begin
Idx := LstSaved.ItemIndex;
if (FStore = nil) or (Idx < 0) or (Idx >= FStore.SavedCount) then Exit;
Dev := FStore.Saved(Idx);
EdName.Text := Dev.Name;
EdIP.Text := Dev.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
if FStore <> nil then FStore.ClearDiscovered;
LstFound.Items.Clear;
end;
procedure TDeviceDialog.RefreshFound;
// Рендер списка найденных из store. Пустой store во время поиска → 'Searching...'.
var
I: Integer;
S: string;
D: TDiscoveredDevice;
begin
if FStore = nil then Exit;
LstFound.Items.Clear;
if FStore.DiscoveredCount = 0 then
begin
LstFound.Items.Add('Searching...');
Exit;
end;
for I := 0 to FStore.DiscoveredCount - 1 do
begin
D := FStore.Discovered(I);
S := D.DisplayName;
if D.BoardType > 0 then
S := S + ' ' + BoardTypeName(D.BoardType);
LstFound.Items.Add(S);
end;
end;
procedure TDeviceDialog.NoDevicesFound;
begin
ClearDiscovered;
LstFound.Items.Add('-- no device found --');
end;
procedure TDeviceDialog.BtnAddClick(Sender: TObject);
var
Idx: Integer;
begin
if FStore = nil then Exit;
if Trim(EdIP.Text) = '' then
begin
ShowMessage('Enter IP address');
Exit;
end;
Idx := FStore.AddSaved(EdName.Text, EdIP.Text, 0);
RefreshSavedList;
LstSaved.ItemIndex := Idx;
end;
procedure TDeviceDialog.BtnRemoveClick(Sender: TObject);
var
Idx: Integer;
begin
Idx := LstSaved.ItemIndex;
if (FStore = nil) or (Idx < 0) or (Idx >= FStore.SavedCount) then Exit;
FStore.RemoveSaved(Idx);
RefreshSavedList;
EdName.Text := '';
EdIP.Text := '';
end;
procedure TDeviceDialog.BtnSetAutoClick(Sender: TObject);
var
Idx: Integer;
begin
Idx := LstSaved.ItemIndex;
if (FStore = nil) or (Idx < 0) or (Idx >= FStore.SavedCount) then
begin
ShowMessage('Select a device first');
Exit;
end;
FStore.SetAutoStart(Idx);
RefreshSavedList;
LstSaved.ItemIndex := Idx;
end;
procedure TDeviceDialog.BtnAddFoundClick(Sender: TObject);
var
Idx, NewIdx: Integer;
D: TDiscoveredDevice;
begin
Idx := LstFound.ItemIndex;
if (FStore = nil) or (Idx < 0) or (Idx >= FStore.DiscoveredCount) then
begin
ShowMessage('Select a discovered device first');
Exit;
end;
D := FStore.Discovered(Idx);
// Pluto сохраняем с Kind/URI/Serial (иначе после перезапуска резолвится как
// HPSDR по голому IP и не подключается).
if D.Kind = bkPluto then
NewIdx := FStore.AddSavedPluto('PlutoSDR', D.URI, D.Serial)
else
NewIdx := FStore.AddSaved(D.DisplayName, D.IPAddress, D.BoardType);
RefreshSavedList;
LstSaved.ItemIndex := NewIdx;
end;
procedure TDeviceDialog.BtnConnectClick(Sender: TObject);
var
IP: string;
Idx: Integer;
begin
IP := '';
if FStore = nil then Exit;
// Приоритет: выбранное сохранённое > выбранное найденное > ручной IP
Idx := LstSaved.ItemIndex;
if (Idx >= 0) and (Idx < FStore.SavedCount) then
begin
IP := FStore.Saved(Idx).IPAddress;
FResult.SavedIdx := Idx;
end
else
begin
Idx := LstFound.ItemIndex;
if (Idx >= 0) and (Idx < FStore.DiscoveredCount) then
begin
IP := FStore.Discovered(Idx).IPAddress;
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;
function TDeviceDialog.ManualIP: string;
begin
if EdIP <> nil then Result := Trim(EdIP.Text) else Result := '';
end;
procedure TDeviceDialog.ClearResult;
begin
FResult.Accepted := False;
FResult.IPAddress := '';
FResult.SavedIdx := -1;
end;
function TDeviceDialog.GetAutoStartIP: string;
begin
if FStore <> nil then Result := FStore.AutoStartIP
else Result := '';
end;
function TDeviceDialog.GetAutoStartBoardType: Integer;
begin
if FStore <> nil then Result := FStore.AutoStartBoardType
else Result := 0;
end;
function TDeviceDialog.GetSavedBoardType(Idx: Integer): Integer;
begin
if FStore <> nil then Result := FStore.SavedBoardType(Idx)
else Result := 0;
end;
end.