S
Познакомьтесь с пентестом веб-приложений на практике в нашем новом бесплатном курсе
Охх... Не люблю я, если честно таб-контрол... уж больно он примитивный.Как такое сделать одной или нескольким вкладкам, а затем вернуть исходную картинку?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ImgList, StdCtrls, Spin;
const
WM_ALARM_MSG = WM_USER + 28;
type
{ Поток, который будет управлять "морганием"
сменой индекса картинки для указанной закладки
}
TAlarmer = class (TThread)
private
FTabIndex: Integer;
FAlarmCount: Integer;
FControl: HWND;
protected
procedure Execute; override;
public
constructor Create(ControlWin: HWND; TabIndex: Integer; AlarmCount: Integer = 6);
end;
type
{ Хак наследования TTabControl, чтобы "достучаться" до GetImageIndex
и UpdateTabImages; потому как они в секции protected
}
TTabControl = class(ComCtrls.TTabControl)
private
FAlarm: Boolean;
FAlarmTabIndex: Integer; // TabIndex который будет "моргать"
FAlarmImgIndex: Integer; // ImageIndex для "моргания"
protected
{ Перекрытый метод protected ComCtrls.TTabControl }
function GetImageIndex(TabIndex: Integer): Integer; override;
{ Наш слушальщик сообщений Alarmer-ра }
procedure WMAlarmMSG(var Msg: TMessage); message WM_ALARM_MSG;
end;
type
TForm1 = class(TForm)
TabControl1: TTabControl;
ImageList1: TImageList;
SpinEdit1: TSpinEdit;
Button1: TButton;
Label1: TLabel;
Label2: TLabel;
SpinEdit2: TSpinEdit;
procedure TabControl1GetImageIndex(Sender: TObject; TabIndex: Integer;
var ImageIndex: Integer);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TAlarmer }
constructor TAlarmer.Create(ControlWin: HWND; TabIndex: Integer; AlarmCount: Integer);
begin
inherited Create (True);
FreeOnTerminate := True; // после завершения, должен самостоятельно "умереть"
FControl := ControlWin; // Хэндл окна TTabControl, куда "моргать" картинками
FTabIndex := TabIndex; // Индекс закладки в которой "моргать"
FAlarmCount := AlarmCount; // Количество "морганий"
Resume;
end;
procedure TAlarmer.Execute;
var
i: Integer;
begin
while (not Terminated) and (FAlarmCount > 0) do
begin
for i := 0 to 10 do
begin
Sleep(50);
if Terminated then Break; // проверяем чаще чем тикаем (А вдруг нас уже похоронили? :-)
end;
if Terminated then Break;
{ Получается два тика в секунду... }
SendMessage(FControl,WM_ALARM_MSG,FTabIndex,(FAlarmCount mod 2 + 1));
dec(FAlarmCount);
end;
{ В конце восстанавливаем "родной" ImageIndex }
SendMessage(FControl,WM_ALARM_MSG,FTabIndex,0);
end;
{ TTabControl }
function TTabControl.GetImageIndex(TabIndex: Integer): Integer;
begin
{ если Alarm - берем Alarm-мовый индекс картинки, иначе берем "родной" }
if FAlarm and (TabIndex = FAlarmTabIndex) then
Result := FAlarmImgIndex
else
Result := inherited GetImageIndex(TabIndex);
end;
procedure TTabControl.WMAlarmMSG(var Msg: TMessage);
begin
if (Msg.Msg = WM_ALARM_MSG) then
begin
FAlarmTabIndex := Msg.WParam;
FAlarmImgIndex := GetImageIndex(FAlarmTabIndex) + Msg.LParam;
FAlarm := True;
UpdateTabImages;
FAlarm := False;
FAlarmTabIndex := -1;
FAlarmImgIndex := -1;
end;
end;
{ TForm1 }
procedure TForm1.TabControl1GetImageIndex(Sender: TObject;
TabIndex: Integer; var ImageIndex: Integer);
begin
{ Назеначаем "Родные" индексы картинок на закладках }
case TabIndex of
0: ImageIndex := 2;
1: ImageIndex := 5;
2: ImageIndex := -1;
else
ImageIndex := -1;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
{ Можно не делать переменную, потому как после того как поток
создается с параметром FreeOnTerminate := True; т.е. освободит
память самостоятельно }
TAlarmer.Create(TabControl1.Handle,SpinEdit1.Value, SpinEdit2.Value);
end;
end.
А я не обещал что ничего тупить не будет (собственно Вы и не просили) ...Данный способ хорошо работает для одной вкладки. Если нужно сразу на многих делать мигание, то поток начинает тупить.
Не надо массивов никаких...Прям массив таймеров создавай. Так же нужно, чтобы иконка мигала до тех пор пока не будет осуществлён переход на вкладку, тоесть количество миганий безлимитное.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, ImgList, StdCtrls;
const
WM_ALARM_MSG = WM_USER + 28; // пользовательское сообщение
type
TAlarms = array of Boolean;
type
{ Поток, который будет управлять "морганием"
}
TAlarmer = class (TThread)
private
FControl: HWND;
protected
procedure Execute; override;
public
constructor Create(ControlWin: HWND);
end;
type
{ Хак наследования TTabControl, чтобы "достучаться" к UpdateTabImages;
потому как он в секции protected
}
TTabControl = class(ComCtrls.TTabControl)
private
FEvenAlarm: Boolean; // флаг - показывает четный или нечетный тик
protected
{ слушальщик сообщений Alarmer-ра }
procedure WMAlarmMSG(var Msg: TMessage); message WM_ALARM_MSG;
public
Alarm: TAlarms; // массив булиновых флагов (выставить длину по количеству Табов)
end;
type
TForm1 = class(TForm)
TabControl1: TTabControl;
ImageList1: TImageList;
Button1: TButton;
Button2: TButton;
CheckBox1: TCheckBox;
CheckBox2: TCheckBox;
CheckBox3: TCheckBox;
procedure TabControl1GetImageIndex(Sender: TObject; TabIndex: Integer;
var ImageIndex: Integer);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
procedure CheckBox2Click(Sender: TObject);
procedure CheckBox3Click(Sender: TObject);
private
{ Private declarations }
Alarmer : TAlarmer; // поток - алармер
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TAlarmer }
constructor TAlarmer.Create(ControlWin: HWND);
begin
inherited Create (True);
FreeOnTerminate := False; // после завершения, должен быть удален вручную !
FControl := ControlWin; // Хэндл окна TTabControl, куда "моргать" картинками
Resume;
end;
procedure TAlarmer.Execute;
var
i: Integer;
begin
while (not Terminated) do
begin
for i := 0 to 10 do
begin
Sleep(50);
if Terminated then Break; // проверяем чаще чем тикаем (А вдруг нас уже похоронили? :-)
end;
if Terminated then Break;
{ Получается два тика в секунду... }
PostMessage(FControl,WM_ALARM_MSG,1,0);
end;
{ В конце сбрасываем состояния "алармов" }
SendMessage(FControl,WM_ALARM_MSG,0,0);
end;
{ TTabControl }
procedure TTabControl.WMAlarmMSG(var Msg: TMessage);
var
i: Integer;
begin
if (Msg.Msg = WM_ALARM_MSG) and Visible then
begin
if (Msg.WParam > 0) then // штатный тик алармера
begin
FEvenAlarm := not FEvenAlarm;
UpdateTabImages;
end
else
begin // сброс алармов
for i := Low(Alarm) to High(Alarm) do
Alarm[i] := False;
UpdateTabImages;
end;
end;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Alarmer := nil;
with TabControl1 do
begin
SetLength(Alarm,Tabs.Count);
if (Tabs.Count > 0) then // начальное состояние всех элементов - False
ZeroMemory(@Alarm[0],Length(Alarm));
end;
end;
procedure TForm1.TabControl1GetImageIndex(Sender: TObject;
TabIndex: Integer; var ImageIndex: Integer);
var
Alarms : TAlarms;
EvenAlarm : Boolean;
begin
case TabIndex of
0: ImageIndex := 2;
1: ImageIndex := 5;
2: ImageIndex := -1;
else
ImageIndex := -1;
end;
with (Sender as TTabControl) do
begin
Alarms := Alarm;
EvenAlarm := FEvenAlarm;
end;
if (TabIndex < Length(Alarms)) and (Alarms[TabIndex]) then { and (TabIndex in [0..2]) }
begin
if EvenAlarm then
Inc(ImageIndex,1)
else
Inc(ImageIndex,2)
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(Alarmer) then
Alarmer := TAlarmer.Create(TabControl1.Handle);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if Assigned(Alarmer) then
begin
{Завер}
Alarmer.Terminate; // завершаем поток
Alarmer.WaitFor; // ожидание фактического! завершения потока
FreeAndNil(Alarmer); // уничножаем поток как объект
end;
CheckBox1.Checked := False;
CheckBox2.Checked := False;
CheckBox3.Checked := False;
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
TabControl1.Alarm[0] := CheckBox1.Checked;
end;
procedure TForm1.CheckBox2Click(Sender: TObject);
begin
TabControl1.Alarm[1] := CheckBox2.Checked;
end;
procedure TForm1.CheckBox3Click(Sender: TObject);
begin
TabControl1.Alarm[2] := CheckBox3.Checked;
end;
end.
Справлюсь с помощью TabControl1ChangeСо сбросом булина, по переход на вкладку, справитесь надеюсть?
procedure TForm1.TabControl1GetImageIndex(Sender: TObject;
TabIndex: Integer; var ImageIndex: Integer);
var
Alarms: TAlarms;
EvenAlarm: Boolean;
begin
{case TabIndex of
0: ImageIndex := 2;
1: ImageIndex := 5;
2: ImageIndex := -1;
else
ImageIndex := -1;
end;}
ImageIndex := 0;
with (Sender as TTabControl) do
begin
Alarms := Alarm;
EvenAlarm := FEvenAlarm;
end;
if (TabIndex < Length(Alarms)) and (Alarms[TabIndex]) then {and (TabIndex in [0..2])}
begin
if EvenAlarm then Inc(ImageIndex, 1) else Inc(ImageIndex, 2);
end;
end;
Хм... как доктор, ответственно заявляю, что всё у Вас в порядке и тест не врёт... B)1. Под сомнением. При таком количестве картинок данный код будет таким? Тест показал, что всё нормально.
Иконка 0 - основная для вкладки (default) Иконки 1 - 2 - мигание
2. Добавление новых вкладок и удаление старых не отразится ли негативно на вашем коде?
Alarmer := nil;
with TabControl1 do
begin
SetLength(Alarm, Tabs.Count);
// Начальное состояние всех элементов - False
if (Tabs.Count > 0) then ZeroMemory(@Alarm[0], Length(Alarm));
end;
type
TTabsData = record
Nick: string;
IP: string;
TempMessage: string;
TabIndex: Integer;
end;
TabsDataArr = array of TTabsData;
...
var
FormPrivate: TFormPrivate;
TD: TabsDataArr;
function DeleteEl(TD: TabsDataArr; Index: Integer): TabsDataArr;
procedure TFormPrivate.AddTab(Nick, IP: string; ChangeTab, ShowForm: Boolean);
var
i: Integer;
B: Boolean; // Создать новую вкладку (True - да, False - нет)
begin
B := False; // Чтобы изначально не создавать вторую вкладку после самой первой
// Добавляем самую первую вкладку
if TabControl1.Tabs.Count = 0 then
begin
i := High(TD) + 2;
SetLength(TD, i);
TD[i - 1].Nick := Nick;
TD[i - 1].IP := IP;
TD[i - 1].TempMessage := '';
TD[i - 1].TabIndex := 0;
TabControl1.Tabs.Add(Nick);
LName.Caption := Nick;
LIP.Caption := IP;
// Загрузим историю переписки приватного чата
LoadHistory(IP);
end
else
begin
// Ищем IP-адрес в массиве
for i := 0 to Length(TD) - 1 do
begin
B := False;
// Если найден нужный IP-адрес
if TD[i].IP = IP then
begin
if ChangeTab then
begin
// Сохраняем данные из текущей вкладки
TD[TabControl1.TabIndex].TempMessage := GetSendText(RVEMessage);
LName.Caption := TD[i].Nick;
LIP.Caption := TD[i].IP;
TabControl1.TabIndex := i; // Перейдём на вкладку
// Очищаем RVEMessage
RVEMessage.Clear;
ChatAddWithSmilesToEdit(RVEMessage, TD[i].TempMessage);
RVEMessage.Format;
SendTextChange(Self);
// Переводим каретку в конец сообщения
RVEMessage.SelectAll;
RVEMessage.Deselect;
// Загрузим историю переписки приватного чата
LoadHistory(TD[i].IP);
Break;
end
else
begin
// Если IP-адрес из массива совпадает с IP-адресом на вкладке
if TD[i].IP = LIP.Caption then
begin
LoadHistory(TD[i].IP);
Break;
end;
end;
Break;
end
else B := True;
end;
end;
if B then
begin
// Добавляем новую вкладку
i := High(TD) + 2;
SetLength(TD, i);
TD[i - 1].Nick := Nick;
TD[i - 1].IP := IP;
TD[i - 1].TempMessage := '';
TD[i - 1].TabIndex := TabControl1.Tabs.Count; // Задаём индекс без "- 1"
TabControl1.Tabs.Add(Nick);
if ChangeTab then
begin
// Сохраняем данные из текущей вкладки
TD[TabControl1.TabIndex].TempMessage := GetSendText(RVEMessage);
LName.Caption := Nick;
LIP.Caption := IP;
TabControl1.TabIndex := TabControl1.Tabs.Count - 1; // Перейдём на вкладку
// Очищаем RVEMessage
RVEMessage.Clear;
RVEMessage.Format;
SendTextChange(Self);
// Загрузим историю переписки приватного чата
LoadHistory(IP);
end;
end;
if ShowForm then
begin
ShowAs;
RVEMessage.SetFocus;
end;
end;
procedure TFormPrivate.TBCloseChatClick(Sender: TObject);
var
i, i2: Integer;
begin
if TabControl1.Tabs.Count > 1 then
begin
i := TabControl1.TabIndex - 1; // Вкладка левее
if i < 1 then i := 0;
// Ищем IP-адрес в массиве
for i2 := 0 to Length(TD) - 1 do
begin
if TD[i2].IP = LIP.Caption then
begin
SetLength(TD, Length(TD)); // Задаём новую длину
TD := DeleteEl(TD, i2); // Удаляем найденную секцию при этом индексы вкладок остаются старые
Break;
end;
end;
TabControl1.Tabs.Delete(TabControl1.TabIndex);
TabControl1.TabIndex := i; // Перейдём на вкладку
// Переназначим индексы у вкладок после удаления элемента из массива
for i := 0 to Length(TD) - 1 do
begin
TD[i].TabIndex := i;
end;
TabControl1.OnChange(Self);
end
else
begin
TabControl1.Tabs.Delete(TabControl1.TabIndex);
SetLength(TD, 0);
SLSenders.Clear;
// Нет вклдок, нет и оповещений
CoolTrayIcon1.IconVisible := False;
CoolTrayIcon1.CycleIcons := False;
// Очищаем RVEMessage
RVEMessage.Clear;
RVEMessage.Format;
SendTextChange(Sender);
RVEMessage.SetFocus;
Close;
end;
end;
procedure TFormPrivate.TabControl1Change(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Length(TD) - 1 do
begin
if TabControl1.TabIndex = TD[i].TabIndex then
begin
LName.Caption := TD[i].Nick;
LIP.Caption := TD[i].IP;
TabControl1.TabIndex := i; // Перейдём на вкладку
DeleteSender(TD[i].IP, False, True);
// Очищаем RVEMessage
RVEMessage.Clear;
ChatAddWithSmilesToEdit(RVEMessage, TD[i].TempMessage);
RVEMessage.Format;
SendTextChange(Sender);
// Переводим каретку в конец сообщения
RVEMessage.SelectAll;
RVEMessage.Deselect;
// Загрузим историю переписки приватного чата
LoadHistory(TD[i].IP);
Break;
end;
end;
end;
procedure TFormPrivate.TabControl1Changing(Sender: TObject;
var AllowChange: Boolean);
begin
// Сохраняем данные из текущей вкладки
TD[TabControl1.TabIndex].TempMessage := GetSendText(RVEMessage);
end;
function DeleteEl(TD: TabsDataArr; Index: Integer): TabsDataArr;
var
NewSize: Integer;
i, Ind: Integer;
begin
NewSize := Length(TD) - 1;
if Index > NewSize {Length(TD) - 1} then raise Exception.Create('Указанный элемент не существует');
SetLength(Result, NewSize);
Ind := 0;
for i := 0 to High(TD) do
begin
if i <> Index then
begin
Result[Ind] := TD[i];
Inc(Ind);
end;
end;
end;
procedure TFormPrivate.FormCreate(Sender: TObject);
begin
SetLength(TD, 0);
end;
Роман! Ну ёханый бабай!... Ну почему сразу нельзя внятно изложить ТЗ?Первые косяки с внедрением кода.
...
Есть TabControl и его тень ввиде массива
*.bmp, 16x16, 24bit, прозрачный цвет стандартный: RGB(255,0,255).В каком формате сохранены иконки, которые вы вставили в ImageList? С вашими иконками всё норально, вставляю свои *.ico или *.bmp, так дёргаться начинают.
procedure TTabControl.WMAlarmMSG(var Msg: TMessage);
var
i,ind: Integer;
TCItem: TTCItem; // добавить в uses CommCtrl
begin
if (Msg.Msg = WM_ALARM_MSG) and Visible then
begin
{Если не назначен Имажлист - выходим }
if (Self.Images = nil) then Exit;
FEvenAlarm := not FEvenAlarm;
{ Если пришла команда на запрет алармов
бежим по юзерам которые в закладках и выключаем Alarm
}
if (Msg.WParam = 0) then
begin
for i := 0 to Self.Tabs.Count-1 do
if (Self.TD[i] <> nil) then
Self.TD[i].Alarm := False;
end;
{ бежим по закладкам }
for i := 0 to Self.Tabs.Count-1 do
begin
{ получили текущий индекс картинки, для данного Таба }
TCItem.mask := TCIF_IMAGE;
SendMessage(Handle, TCM_GETITEM, i, Longint(@TCItem));
{ получили индекс картинки, который нужно назначить (новый) }
ind := GetImageIndex(i);
{ Если новый индекс отличается от текущего, то переназначаем }
if (TCItem.iImage <> ind) then
begin
TCItem.mask := TCIF_IMAGE;
TCItem.iImage := ind;
SendMessage(Handle, TCM_SETITEM, i, Longint(@TCItem));
end;
end;
end;
end;
TabsDataArr = array of TTabsData;
...
var
...
TD: TabsDataArr;
if (Msg.WParam = 0) then
begin
for i := 0 to Self.Tabs.Count-1 do
if (Self.TD[i] <> nil) then
Self.TD[i].Alarm := False;
end;
if (Msg.WParam = 0) then
begin
for i := 0 to Self.Tabs.Count-1 do
if (TabUsers[i] <> nil) then
TabUsers[i].Alarm := False;
end;
С какого извините "будуна" TabUsers[i] может вдруг оказаться nil если тип TTabUsers у Вас - record?Застрял здесь
type
TTabUsers = record
UserID: Integer;
Nick: string;
TempMessage: string;
Alarm: Boolean;
end;
var
TabUsers: array of TTabUsers;
//...
{ Если пришла команда на запрет алармов
бежим по юзерам которые в закладках и выключаем Alarm
}
if (Msg.WParam = 0) then
begin
//!// Застрял тут
for i := 0 to Self.Tabs.Count-1 do
if (TabUsers[i] <> nil) then // ????????!!!!!!!!!
TabUsers[i].Alarm := False;
end;
if (Msg.WParam = 0) then
begin
for i := 0 to Self.Tabs.Count-1 do TabUsers[i].Alarm := False;
end;
Alarm := False?
Обучение наступательной кибербезопасности в игровой форме. Начать игру!