Последние записи
- Рандомное слайдшоу
- Событие для произвольной области внутри TImage
- Удаление папки с файлами
- Распечатка файла
- Преобразовать массив байт в вещественное число (single)
- TChromium (CEF3), сохранение изображений
- Как в Delphi XE обнулить таймер?
- Изменить цвет шрифта TextBox на форме
- Ресайз PNG без потери прозрачности
- Вывод на печать графического файла
Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk
Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw
17th
Май
Гауссовское распределение
К примеру, нормальное (Гауссово) строится используя математическую хитрость о том, что сумма равномерно-распределенных случ. величин – есть нормальная случ. величина.
{ Моделирование нормального распределения }
function Norm: Real;
var
s: Real;
i: Integer;
begin
s := 0;
for i := 1 to Nmax do s := s + Random;
norm := s-Nmax/2;
end;
{ Моделирование распределения скоростей Максвелла }
procedure Maxwell(disp,norm:real;var vx,vy:array of Real);
var
i: integer;
begin
for i := 1 to Nmax do begin
vx := norm*disp;
vy := norm*disp;
end;
end;
Максвеловское (на самом деле это очень похожее на него) приведено для примера. Как управлять дисперсией.
С нормальным немного почесать затылок и можно будет сместить и среднее значение и среднее отклонение.
ЗЫ: Random – встроенный генератор случайных чисел, выдает случайную величину с равномерной плотностью распределения. если что ))
17th
Фреймы HTML
Хоть от фреймов и желательно отказаться, но появляются в сети вопросы, о работе с ними.
Пример страницы с четырьмя фреймами.
<!--- содержимое файла index.html ---!>
<frameset rows="100,*,20">
<frame src="head.html">
<frameset cols="200,*">
<frame src="menu.html">
<frame src="content.html">
</frameset>
<frame src="footer.html">
</frameset>
<!--- содержимое файла head.html ---!>
шляпго
<!--- содержимое файла menu.html ---!>
<a href="http://url">гиперссылка(любая)</a>
<!--- содержимое файла content.html ---!>
текст(любой)
<!--- содержимое файла footer.html ---!>
<center>О_о</center>
PS: в данном примере все файлы должны лежать в одной папке.
17th
Движение бильярдного шара
Простенькая наработка для имитации движения бильярдного шара.
uses crt,graph;
var gd,gm:integer;
dx,dy:integer;
x1,y1,radius:integer;
begin
gd:=detect;
initgraph(gd,gm,' ');
setcolor(green);
rectangle(10,10,610,460);
x1:=50;y1:=200;
radius:=10;
dx:=3;dy:=2;
setcolor(yellow);
circle(x1,y1,radius);
repeat
setcolor(0);
circle(x1,y1,radius);
if x1>610 then dx:=-dx;
if x1<10 then dx:=-dx;
if y1>470 then dy:=-dy;
if y1<10 then dy:=-dy;
x1:=x1+dx;y1:=y1+dy;
setcolor(yellow);
circle(x1,y1,radius);
delay(10000);
until (x1-10<=10) and (y1+10>=47) or
(x1-10<=10) and (y1-10<=10) or
(x1+10>=610) and (y1-10<=10) or
(x1+10>=610) and (y1+10>=470);
readln;
closegraph;
end.
15th
Май
Как программно отправить CTRL+V?
raxp:
а нескольких кнопок послать нажатие можно так:
var msg: TMessage;
…
msg.LParamLo:= MOD_CONTROL;
msg.LParamHi:= VK_CONTROL or ord(’V’);
PostMessage(handle_window, WM_HOTKEY, 0, Msg.LParam);
12th
Май
Закрытие чужого процесса WinApi
Одно из многочисленных готовых решений:
function ProcessTerminate(dwPID:Cardinal):Boolean;
var
hToken:THandle;
SeDebugNameValue:Int64;
tkp:TOKEN_PRIVILEGES;
ReturnLength:Cardinal;
hProcess:THandle;
begin
Result:=false;
// Добавляем привилегию SeDebugPrivilege
// Для начала получаем токен нашего процесса
if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES
or TOKEN_QUERY, hToken ) then
exit;
// Получаем LUID привилегии
if not LookupPrivilegeValue( nil, 'SeDebugPrivilege', SeDebugNameValue )
then begin
CloseHandle(hToken);
exit;
end;
tkp.PrivilegeCount:= 1;
tkp.Privileges[0].Luid := SeDebugNameValue;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
// Добавляем привилегию к нашему процессу
AdjustTokenPrivileges(hToken,false,tkp,SizeOf(tkp),tkp,ReturnLength);
if GetLastError()< > ERROR_SUCCESS then exit;
// Завершаем процесс. Если у нас есть SeDebugPrivilege, то мы можем
// завершить и системный процесс
// Получаем дескриптор процесса для его завершения
hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, dwPID);
if hProcess =0 then exit;
// Завершаем процесс
if not TerminateProcess(hProcess, DWORD(-1))
then exit;
CloseHandle( hProcess );
// Удаляем привилегию
tkp.Privileges[0].Attributes := 0;
AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(tkp), tkp, ReturnLength);
if GetLastError() < > ERROR_SUCCESS
then exit;
Result:=true;
end;
12th
Прочитать значение раздела в реестре
uses Registry;
var
Reg: TRegistry;
Count: Integer;
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKeyReadOnly(’\Software\Microsoft\Windows\CurrentVersion\Run’);
Reg.GetValueNames(Memo1.Lines);
for Count := 0 to Memo1.Lines.Count -1 do
Memo1.Lines.Strings[Count] := Memo1.Lines.Strings[Count] + ‘ : ‘
+ Reg.ReadString(Memo1.Lines.Strings[Count]);
Reg.Free;
end;
10th
Май
Работа с датой в Delphi
Часто у новичков бывают проблемы при работе с датой. По просьбе одного из участников форума, Alex2009 любезно согласился помочь по некоторым типичным задачам.
Используя объектно – ориентированную среду Делфи напишите программу определения:
А) даты вчерашнего дня;
const
stDay : array[1..7] of string[11] =
('Воскресенье','Понедельник','Вторник','Среда','Четверг','Пятница','Суббота');
stMonth : array[1..12] of string[8] =
('Января','Февраля','Марта','Апреля ','Мая','Июня','Июля',
'Августа','Сентября','Октября','Ноя бря','Декабря');
procedure TForm1.FormCreate(Sender: TObject);
var
Present: TDateTime;
Year, Month, Day : Word;
begin
Present:=Now;
DecodeDate(Present, Year, Month, Day);
Caption := 'Сегодня '+IntToStr(Day)+ ' ' +
stMonth[Month] +' '+IntToStr(Year)+' года, '+
stDay[DayOfWeek(Present)];
end;
Б) дату, которая была за m дней до указанной даты;
const
stDay : array[1..7] of string[11] =
('Воскресенье','Понедельник','Вторник','Среда','Четверг','Пятница','Суббота');
stMonth : array[1..12] of string[8] =
('Января','Февраля','Марта','Апреля ','Мая','Июня','Июля',
'Августа','Сентября','Октября','Ноя бря','Декабря');
procedure TForm1.FormCreate(Sender: TObject);
var
Present: TDateTime;
Year, Month, Day : Word;
begin
Present:=Now;
Present:=Present-1;
Day:=Day-day;
DecodeDate(Present, Year, Month, Day);
Caption := 'Вчера '+IntToStr(Day)+ ' ' +
stMonth[Month] +' '+IntToStr(Year)+' года, '+
stDay[DayOfWeek(Present)];
end;
В) количество дней, прошедших от даты t до t 2
uses DateUtils;
........
procedure TForm1.Button1Click(Sender: TObject);
var d,d2:TDate;
begin
showmessage('Вчерашняя дата '+formatdatetime('dd mmmm yyyyг.',yesterday));
d:=Now;
d:=incDay(d,-10);
showmessage('Дата которая была 10 дней назад '+formatdatetime('dd mmm yyyyг.',d));
d:=StrToDate('12.03.2010');
d2:=StrToDate('25.04.2010');
showmessage('Кол-во дней между датами составляет '+inttostr(DaysBetween(d2,d))+' дней');
end;
9th
Май
Перевод числа в любую систему счисления на с++
Alex_sim:
\\привет вот накидал 100% работающий вариант перевода числа в любую СС извини только на с++ ну думаю переделать не составит труда))
#include
#include
#include
#includeint main()
{
setlocale(LC_ALL, “Russian”);// пример организации ввода с ограничением
int n;
do {
printf(”Введите положительное число: “);
scanf_s(”%d”, &n);
fflush(stdin); // сброс нераспознаваемого “мусора”
} while( n<0 );const int radix = 7; // основание СС тоже можно спросить у пользователя
char buffer[]=”00000000″;
int i=7; // позиция в буфере первой записываемой цифрыdo {
int x = n % radix;
n = n / radix;
char z;
if( x<10 )
z='0'+x;
else
z=’A’-10+x;
//printf(”%c”, z );
buffer=z; // вместо вывода на экран, записываем в буфер в обратном порядке
i–;
} while (n>0);// только в конце выводим результат
printf(”\nЗапись в %d-чной системе счисления: %s\n”, radix, buffer);_getch();
}
7th
Май
Изменение размера PNG без потери прозрачности
Всем привет! Попал в такую ситуацию: есть 2 временных TPNGImage; один загружен из файла, второй – пустой, предназначен для вывода растянутого/ужатого первого.
При копировании первого во второй и его последующем ресайзе теряется альфа-канал.
Как можно заново просчитать маску прозрачности (или как это делается), учитывая новые размеры?
Код:
var
Src,Dst:TPngImage;
type
PRGBAArray = ^TRGBAArray;
TRGBAArray = array[0..MaxPixelCountA-1] of TRGBQuad;
...
procedure Resize;
var BTOut:TBitmap;
BT:Tbitmap;
bt_tmp_rgb,bt_tmp_a:tbitmap;
bt_tmp_rgb2,bt_tmp_a2:tbitmap;
iii,ii:integer;
fff:PRGBAArray;
aaa:pByteArray;
begin
BTOut:=TBitmap.Create;
BTOut.PixelFormat:=pf32bit;
BT:=TBitmap.Create;
BT.PixelFormat:=pf32bit;
bt_tmp_rgb:=TBitmap.Create;
bt_tmp_a:=TBitmap.Create;
bt_tmp_rgb.PixelFormat:=pf32bit;
bt_tmp_a.PixelFormat:=pf32bit;
BT.Assign(Src);
for ii:=0 to BT.Height-1 do begin
fff:=BT.ScanLine[ii];
aaa:=Src.AlphaScanline[ii];
for iii:=0 to BT.Width-1 do begin
fff[iii].rgbReserved:=aaa[iii];
end;
end;
BTOut.SetSize(Dst.Width,Dst.Height);
bt_tmp_rgb.SetSize(BT.Width,BT.Height);
bt_tmp_a.SetSize(BT.Width,BT.Height);
//Разделяем битмап-подложку на "видимый" битмап RGB и альфаканал
GetLayerBitmap(bt,bt_tmp_rgb,bt_tmp_a);
BT.Free;
bt_tmp_rgb2:=TBitmap.Create;
bt_tmp_rgb2.PixelFormat:=pf32bit;
bt_tmp_rgb2.SetSize(BTOut.Width,BTOut.Height);
bt_tmp_rgb2.Canvas.StretchDraw(bt_tmp_rgb2.Canvas.ClipRect,bt_tmp_rgb);
bt_tmp_rgb.Free;
bt_tmp_a2:=TBitmap.Create;
bt_tmp_a2.PixelFormat:=pf32bit;
bt_tmp_a2.SetSize(BTOut.Width,BTOut.Height);
bt_tmp_a2.Canvas.StretchDraw(bt_tmp_a2.Canvas.ClipRect,bt_tmp_a);
bt_tmp_a.Free;
//собираем временные битмапы в один 32-битный, который потом будет отображен
Build32(bt_tmp_rgb2,bt_tmp_a2,BTOut);
bt_tmp_rgb2.Free;
bt_tmp_a2.Free;
Dst.Assign(BTOut);
Dst.CreateAlpha;
for ii:=0 to BTOut.Height-1 do begin
fff:=BTOut.ScanLine[ii];
aaa:=Layer.StretchPNG.AlphaScanline[ii];
for iii:=0 to BTOut.Width-1 do begin
aaa[iii]:=fff[iii].rgbReserved;
end;
end;
BTOut.Free;
end;
procedure GetLayerBitmap(_B_res:TBitmap; _Brgb,_Bmask:Tbitmap);
var x, y: Integer; RowOut,RowIn,RowOutM: PRGBAArray;
begin
for y:=0 to _B_res.Height-1 do begin
RowOut:= _Brgb.ScanLine[y];
RowOutM:= _Bmask.ScanLine[y];
RowIn:= _B_res.ScanLine[y];
for x:=0 to _B_res.Width-1 do begin
RowOutM[x].rgbReserved:=255;
RowOutM[x].rgbBlue:=RowIn[x].rgbReserved;
RowOutM[x].rgbGreen:=RowIn[x].rgbReserved;
RowOutM[x].rgbRed:=RowIn[x].rgbReserved;
RowOut[x].rgbReserved:=255;
RowOut[x].rgbBlue:=RowIn[x].rgbBlue;
RowOut[x].rgbGreen:=RowIn[x].rgbGreen;
RowOut[x].rgbRed:=RowIn[x].rgbRed;
end;
end;
end;
procedure Build32(_B_in,_B_inM:TBitmap; _Bout:Tbitmap);
var x, y: Integer; RowOut: PRGBAArray; RowIn,RowM:PRGBAArray;
begin
for y:=0 to _B_in.Height-1 do begin
RowOut:= _Bout.ScanLine[y];
RowIn:= _B_in.ScanLine[y];
RowM:= _B_inM.ScanLine[y];
for x:=0 to _B_in.Width-1 do begin
RowOut[x].rgbBlue:=RowIn[x].rgbBlue;
RowOut[x].rgbGreen:=RowIn[x].rgbGreen;
RowOut[x].rgbRed:=RowIn[x].rgbRed;
RowOut[x].rgbReserved:=RowM[x].rgbRed;
end;
end;
end;
7th
Как избавиться от мерцания при перерисовки картинки?
procedure TForm1.FormCreate(Sender: TObject);
begin
form1.DoubleBuffered:=true;
end;
Облако меток
css реестр ассемблер timer SaveToFile ShellExecute программы массив советы word MySQL SQL ListView pos random компоненты дата LoadFromFile form база данных сеть html php RichEdit indy строки Win Api tstringlist Image мысли макросы Edit ListBox office C/C++ memo графика StringGrid canvas поиск файл Pascal форма Файлы интернет Microsoft Office Excel excel winapi журнал ПРОграммист DelphiКупить рекламу на сайте за 1000 руб
пишите сюда - alarforum@yandex.ru
Да и по любым другим вопросам пишите на почту
пеллетные котлы
Пеллетный котел Emtas
Наши форумы по программированию:
- Форум Web программирование (веб)
- Delphi форумы
- Форумы C (Си)
- Форум .NET Frameworks (точка нет фреймворки)
- Форум Java (джава)
- Форум низкоуровневое программирование
- Форум VBA (вба)
- Форум OpenGL
- Форум DirectX
- Форум CAD проектирование
- Форум по операционным системам
- Форум Software (Софт)
- Форум Hardware (Компьютерное железо)