
Последние записи
- Прозрачность тайлсета в TPNGImage
- Как сделать VBA макрос в excel
- Поиск по столбцу 1-ого не нулевого значения (формулой в Microsoft Office Excel)
- Простановка единиц в ячейки под объектами (Microsoft Office Excel)
- Расчет затраченного времени между определенным рабочим временем (формулой в Microsoft Office Excel)
- Мигающий экран на Assembler
- VBA-макрос по копированию 10 строчек в выбранном диапазоне в Microsoft Office Excel
- Копирование только нужного диапазона в Microsoft Office Excel
- Перенос диапазона стоки в Microsoft Office Excel на другой лист по условию
- Мелодия в Pascal.ABC.Net с помощью System.Console.Beep — задержка воспроизведения звука

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;
7th
Авторизация “В контакте”
procedure TForm1.Button1Click(Sender: TObject);
var data:tstringlist;
PageProfile, pic:string;
error:boolean;
beginpos, endpos : Integer;
ms: TMemoryStream;
jpeg: TJpegImage;
begin
IdHTTP1.AllowCookies:=true;
IdHTTP1.HandleRedirects:=false;
data:=tstringlist.create;
data.Add('email=ЛОГИН'); // логин для авторизации
data.Add('pass=ПАРОЛЬ'); // пароль для авторизации
data.Add('expire=');
data.Add('vk=');
error:=false;
try
PageProfile:=IdHTTP1.Post('http://login.vk.com/?act=login', data);
except
error:=true;
end;
if not(error) then
begin
data.Clear;
data.Add('s='+Copy(PageProfile, Pos('value', PageProfile)+7, 56));
data.Add('op=slogin');
data.Add('redirect=1');
data.Add('expire=0');
data.Add('to=');
IdHTTP1.HandleRedirects:=true;
try
PageProfile:=IdHTTP1.Post('http://vkontakte.ru/login.php', data);
except
end;
beginpos := Pos('center', PageProfile);
endpos := PosEx('/>', PageProfile, beginpos + 21);
pic := Copy(PageProfile, beginpos + 21, endpos - (beginpos + 21));
Memo1.Lines.Add(pic);
ms := TMemoryStream.Create;
jpeg := TJpegImage.Create;
try
IdHTTP1.Get(pic, ms);
ms.Position := 0;
jpeg.LoadFromStream(ms);
Image1.Picture.Graphic := jpeg;
finally
jpeg.Free; ms.Free;
end;
end
else
Memo1.Lines.Add('Авторизация не удалась');
Data.Free;
end;
7th
Как скачать файл?
Alex2009:
uses
URLMon, ShellApi;function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0, nil) = 0;
except
Result := False;
end;
end;procedure TForm1.Button1Click(Sender: TObject);
const
SourceFile = ‘http://rap-zt.at.ua/style/photo/cover2/mafon.jpg’;
DestFile = ‘c:\temp\mafon.jpg’;
begin
if DownloadFile(SourceFile, DestFile) then
begin
ShowMessage(’Файл скачанl!’);
ShellExecute(Application.Handle, PChar(’open’), PChar(DestFile),
PChar(”), nil, SW_NORMAL)
end
else
ShowMessage(’Ошибка закачки ‘ + SourceFile)
end;
7th
Как сделать ссылку в Label?
ShellExecute(handle, ‘open’, ‘http://www.programmersforum.ru’, nil, nil, SW_SHOW);
7th
Подключения запароленной базы данных Access
Баламут:
Для подключения запароленной базы используется строка подключения примерно следующего вида:
AdoConnection1.ConnectionString:= ‘Provider=Microsoft.Jet.OLEDB.4.0;’+
’Data Source=имя_базы.mdb;Persist Security Info=False;’+
’Jet OLEDB:Database Password=ПАРОЛЬ‘;
6th
Май
Рассылка. Выпуск 57
От ведущего рассылки.
Приветствую Вас в Клубе ПРОграммистов!! Сегодня выходит очередной 57 выпуск рассылки от клуба.
В этом номере будут самые интересные темы и статьи клуба, форума, а так же статьи из журнала ПРОграммист, который ведут наши участники, ну и немного юмора.
4th
Май
Delphi 7 или RAD 2010?
Человек_Борща:
Интересует вопрос.. в чем отличия Borland Delphi 7 от Embracode RAD 2010?