Получаем имена ODBC-источников
Получаем имена ODBC-источников
usesRegistry;
procedure TForm1.GetDataSourceNames(System: Boolean);
var
reg: TRegistry;
begin
ListBox1.Items.Clear;
reg := TRegistry.Create;
try
if System then
reg.RootKey := HKEY_LOCAL_MACHINE
else
reg.RootKey := HKEY_CURRENT_USER;
if reg.OpenKey('\Software\ODBC\ODBC.INI\ODBC Data Sources', False) then
begin
reg.GetValueNames(ListBox1.Items);
end;
finally
reg.CloseKey;
FreeAndNil(reg);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
//Системные DSNs
GetDataSourceNames(True);
//Пользовательские DSNs
GetDataSourceNames(False);
end;
Взято из
Получение дескриптора ODBC соединения
Получение дескриптора ODBC соединения
Я как-то обращал ваше внимание на трудность получения дескриптора ODBC соединения посредством DBE. После тесного общения со службой поддержки Borland, я наконец нашел решение как это сделать. Вот этот код:
unitGetprop;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, DBGrids, StdCtrls, DB, DBTables,
DBIProcs, DBITypes, DBIErrs;
type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
Button1: TButton;
Button2: TButton;
DBGrid1: TDBGrid;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Table1.active := True;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
hTmpDB: hDBIDb;
iLen: word;
begin
Check(DbiGetProp(hDBIObj(Table1.DBhandle), dbNATIVEHNDL, @hTmpDB, sizeof(hDBIDb), iLen));
Edit1.text := inttostr(longint(htmpdb));
end;
end
- Chris Fioravanti
Взято из
Советов по Delphi от
Сборник Kuliba
Получение файла из сети
Получение файла из сети
(Перевод одноимённой статьи с сайта delphi.about.com )
Обычно при разработке приложений, которые планируется в дальнейшем обновлять и усовершенствовать, основные модули хранятся в виде пакетов (Package) или библиотек DLL. В настоящее время Internet предоставляет возможность без особых усилий осуществлять обновление этих модулей. Поэтому добавление к Вашему приложению функции авто-обновления, является наилучшим способом для обновления приложения.
Давайте посмотрим, как реализовывается данный механизм в любом FTP приложении.
Delphi предоставляет нам полный доступ к WinInet API (wininet.pas), который можно использовать для соединения и получения файлов с веб-сайта, который использует либо Hypertext Transfer Protocol (HTTP) либо File Transfer Protocol (FTP). Например, мы можем использовать функции из WinInet API для: добавления FTP браузера в любое приложение, создания приложения, которое автоматически скачивает файлы с общедоступных FTP серверов или поиска Internet сайтов, ссылающихся на графику и скачивать только графику.
Функция GetInetFile
uses Wininet;
function GetInetFile
(const fileURL, FileName: String): boolean;
const BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: DWORD;
f: File;
sAppName: string;
begin
Result:=False;
sAppName := ExtractFileName(Application.ExeName);
hSession := InternetOpen(PChar(sAppName),
INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil, 0);
try
hURL := InternetOpenURL(hSession,
PChar(fileURL),
nil,0,0,0);
try
AssignFile(f, FileName);
Rewrite(f,1);
repeat
InternetReadFile(hURL, @Buffer,
SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen)
until BufferLen = 0;
CloseFile(f);
Result:=True;
finally
InternetCloseHandle(hURL)
end
finally
InternetCloseHandle(hSession)
end
end;
Обратите внимание: Чтобы обеспечить некоторую визуальную обратную связь для пользователя, Вы можете добавить строчку наподобие FlashWindow(Application.Handle,True) в тело блока "повторить/до тех пор" (repeat/until). Вызов FlashWindow API высвечивает заголовок Вашего имени приложений в панели задач.
Использование
Для вызова функции GetInetFile можно использовать следующий код:
var FileOnNet, LocalFileName: string
begin
FileOnNet:=
'http://delphi.about.com/library/forminbpl.zip';
LocalFileName:='File Downloaded From the Net.zip'
if GetInetFile(FileOnNet,LocalFileName)=True then
ShowMessage('Download successful')
else
ShowMessage('Error in file download')
end;
Данный код запрашивает файл 'forminbpl.zip' с сайта, скачивает его, и сохраняет его как 'File Downloaded From the Net.zip'.
Обратите внимание: В зависимости от версии Delphi, Вы можете использовать различные компоненты, которые можно найти на Интернет страницах, посвещённых VCL и, которые можно использовать для упрощения создания приложений (например FTP компонент, необходимый для TNMFTP, находящийся на странице FastNet VCL).
Взято с Исходников.ru
Получение Gaussian Blur
Получение Gaussian Blur
Автор: Den is Com
Ну вот, добрались и до фильтров. В неформальных испытаниях этот код оказался вдвое быстрее, чем это делает Adobe Photoshop. Мне кажется есть множество фильтров, которые можно переделать или оптимизировать для быстроты обработки изображений.
Ядро гауссовой функции exp(-(x^2 + y^2)) есть разновидность формулы f(x)*g(y), которая означает, что мы можем выполнить двумерную свертку, делая последовательность одномерных сверток - сначала мы свертываем каждую строчку изображения, затем - каждую колонку. Хороший повод для ускорения (N^2 становится N*2). Любая свертка требует некоторого место для временного хранения результатов - ниже в коде программа BlurRow как раз распределяет и освобождает память для каждой колонки. Вероятно это должно ускорить обработку изображения, правда не ясно насколько.
Поле "size" в записи TKernel ограничено значением 200. Фактически, если вы хотите использовать еще больший радиус, это не вызовет проблем - попробуйте со значениями radius = 3, 5 или другими. Для большого количества данных методы свертки на поверку оказываются эффективнее преобразований Фурье (как показали опыты).
Еще один комментарий все же необходим: гауссово размывание имеет одно магическое свойство, а именно - вы можете сначала размыть каждую строчку (применить фильтр), затем каждую колонку - фактически получается значительно быстрее, чем двумерная свертка.
Во всяком случае вы можете сделать так:
unitGBlur2;
interface
uses Windows, Graphics;
type
PRGBTriple = ^TRGBTriple;
TRGBTriple = packed record
b: byte; //легче для использования чем типа rgbtBlue...
g: byte;
r: byte;
end;
PRow = ^TRow;
TRow = array[0..1000000] of TRGBTriple;
PPRows = ^TPRows;
TPRows = array[0..1000000] of PRow;
const
MaxKernelSize = 100;
type
TKernelSize = 1..MaxKernelSize;
TKernel = record
Size: TKernelSize;
Weights: array[-MaxKernelSize..MaxKernelSize] of single;
end;
//идея заключается в том, что при использовании TKernel мы игнорируем
//Weights (вес), за исключением Weights в диапазоне -Size..Size.
procedure GBlur(theBitmap: TBitmap; radius: double);
implementation
uses SysUtils;
procedure MakeGaussianKernel(var K: TKernel; radius: double;
MaxData, DataGranularity: double);
//Делаем K (гауссово зерно) со среднеквадратичным отклонением = radius.
//Для текущего приложения мы устанавливаем переменные MaxData = 255,
//DataGranularity = 1. Теперь в процедуре установим значение
//K.Size так, что при использовании K мы будем игнорировать Weights (вес)
//с наименее возможными значениями. (Малый размер нам на пользу,
//поскольку время выполнения напрямую зависит от
//значения K.Size.)
var
j: integer;
temp, delta: double;
KernelSize: TKernelSize;
begin
for j := Low(K.Weights) to High(K.Weights) do
begin
temp := j / radius;
K.Weights[j] := exp(-temp * temp / 2);
end;
//делаем так, чтобы sum(Weights) = 1:
temp := 0;
for j := Low(K.Weights) to High(K.Weights) do
temp := temp + K.Weights[j];
for j := Low(K.Weights) to High(K.Weights) do
K.Weights[j] := K.Weights[j] / temp;
//теперь отбрасываем (или делаем отметку "игнорировать"
//для переменной Size) данные, имеющие относительно небольшое значение -
//это важно, в противном случае смазавание происходим с малым радиусом и
//той области, которая "захватывается" большим радиусом...
KernelSize := MaxKernelSize;
delta := DataGranularity / (2 * MaxData);
temp := 0;
while (temp < delta) and (KernelSize > 1) do
begin
temp := temp + 2 * K.Weights[KernelSize];
dec(KernelSize);
end;
K.Size := KernelSize;
//теперь для корректности возвращаемого результата проводим ту же
//операцию с K.Size, так, чтобы сумма всех данных была равна единице:
temp := 0;
for j := -K.Size to K.Size do
temp := temp + K.Weights[j];
for j := -K.Size to K.Size do
K.Weights[j] := K.Weights[j] / temp;
end;
function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
if (theInteger <= Upper) and (theInteger >= Lower) then
result := theInteger
else if theInteger > Upper then
result := Upper
else
result := Lower;
end;
function TrimReal(Lower, Upper: integer; x: double): integer;
begin
if (x < upper) and (x >= lower) then
result := trunc(x)
else if x > Upper then
result := Upper
else
result := Lower;
end;
procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
j, n, LocalRow: integer;
tr, tg, tb: double; //tempRed и др.
w: double;
begin
for j := 0 to High(theRow) do
begin
tb := 0;
tg := 0;
tr := 0;
for n := -K.Size to K.Size do
begin
w := K.Weights[n];
//TrimInt задает отступ от края строки...
with theRow[TrimInt(0, High(theRow), j - n)] do
begin
tb := tb + w * b;
tg := tg + w * g;
tr := tr + w * r;
end;
end;
with P[j] do
begin
b := TrimReal(0, 255, tb);
g := TrimReal(0, 255, tg);
r := TrimReal(0, 255, tr);
end;
end;
Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;
procedure GBlur(theBitmap: TBitmap; radius: double);
var
Row, Col: integer;
theRows: PPRows;
K: TKernel;
ACol: PRow;
P: PRow;
begin
if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
raise
exception.Create('GBlur может работать только с 24-битными изображениями');
MakeGaussianKernel(K, radius, 255, 1);
GetMem(theRows, theBitmap.Height * SizeOf(PRow));
GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
//запись позиции данных изображения:
for Row := 0 to theBitmap.Height - 1 do
theRows[Row] := theBitmap.Scanline[Row];
//размываем каждую строчку:
P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
for Row := 0 to theBitmap.Height - 1 do
BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
//теперь размываем каждую колонку
ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
for Col := 0 to theBitmap.Width - 1 do
begin
//- считываем первую колонку в TRow:
for Row := 0 to theBitmap.Height - 1 do
ACol[Row] := theRows[Row][Col];
BlurRow(Slice(ACol^, theBitmap.Height), K, P);
//теперь помещаем обработанный столбец на свое место в данные изображения:
for Row := 0 to theBitmap.Height - 1 do
theRows[Row][Col] := ACol[Row];
end;
FreeMem(theRows);
FreeMem(ACol);
ReAllocMem(P, 0);
end;
end.
Должно работать, если только вы не удалите некоторый код вместе с глупыми коментариями. Для примера:
procedure TForm1.Button1Click(Sender: TObject);
var
b: TBitmap;
begin
if not openDialog1.Execute then
exit;
b := TBitmap.Create;
b.LoadFromFile(OpenDialog1.Filename);
b.PixelFormat := pf24Bit;
Canvas.Draw(0, 0, b);
GBlur(b, StrToFloat(Edit1.text));
Canvas.Draw(b.Width, 0, b);
b.Free;
end;
Имейте в виду, что 24-битные изображения при системной 256-цветной палитре требуют некоторых дополнительных хитростей, так как эти изображения не только выглядят в таком случае немного "странными", но и серьезно нарушают работу фильтра.
Взято из
Гауссово размывание (Gaussian Blur) в Delphi (продолжение) - Создание тени у метки
Автор: Den is Com
Данный метод позволяет создавать тень у текстовых меток TLabel. Не требует лазить в Photoshop и что-то ваять там - тень рисуется динамически, поэтому и объём программы не раздувает. Создание тени присходит в фоновом режиме, во время "простоя" процессора.
Пример использования:
ShowFade(CaptionLabel);
//или
ShowFadeWithParam(CaptionLabel,3,3,2,clGray);
Blur.pas
unitblur;
interface
uses
Classes, graphics, stdctrls, gblur2;
const
add_width = 4;
add_height = 5;
type
TBlurThread = class(TThread)
private
{ Private declarations }
text_position: Integer;
FadeLabel: TLabel;
Temp_Bitmap: TBitmap;
procedure ShowBlur;
procedure SetSize;
protected
F_width, F_X, F_Y: Integer;
F_color: TColor;
procedure Execute; override;
public
constructor Create(Sender: TLabel; Fade_width: integer; Fade_X: Integer;
Fade_Y: Integer; Fade_color: TColor);
destructor Destroy;
end;
procedure ShowFade(Sender: TLabel);
procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
Integer; Fade_Y: Integer; Fade_color: TColor);
implementation
procedure ShowFadeWithParam(Sender: TLabel; Fade_width: integer; Fade_X:
Integer; Fade_Y: Integer; Fade_color: TColor);
var
SlowThread: TBlurThread;
begin
SlowThread := TBlurThread.Create(Sender, Fade_width, Fade_X, Fade_Y,
Fade_color);
SlowThread.Priority := tpIdle;
SlowThread.Resume;
end;
procedure ShowFade;
var
SlowThread: TBlurThread;
begin
SlowThread := TBlurThread.Create(Sender, 3, 3, 3, clBlack);
SlowThread.Priority := tpIdle;
//SlowThread.Priority:=tpLowest;
//SlowThread.Priority:=tpTimeCritical;
SlowThread.Resume;
end;
constructor TBlurThread.Create(Sender: TLabel; Fade_width: integer; Fade_X:
Integer; Fade_Y: Integer; Fade_color: TColor);
begin
Temp_Bitmap := TBitmap.Create;
Temp_Bitmap.Canvas.Font := Sender.Font;
FadeLabel := Sender;
F_width := Fade_width;
F_X := Fade_X;
F_Y := Fade_Y;
F_color := Fade_color;
inherited Create(True);
end;
destructor TBlurThread.Destroy;
begin
Temp_Bitmap.Free;
inherited Destroy;
end;
procedure TBlurThread.ShowBlur;
begin
FadeLabel.Canvas.Draw(text_position + F_X, F_Y, Temp_Bitmap);
FadeLabel.Canvas.TextOut(text_position, 0, FadeLabel.Caption);
end;
procedure TBlurThread.SetSize;
begin
if FadeLabel.Width < (Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
+ F_X {add_width}) then
begin
FadeLabel.Width := Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) + F_width
+ F_X {add_width};
FadeLabel.Tag := 2;
end
else
FadeLabel.Tag := 0;
if FadeLabel.Height < (Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
F_width + F_Y {add_height}) then
begin
FadeLabel.Height := Temp_Bitmap.Canvas.TextHeight(FadeLabel.Caption) +
F_width + F_Y {add_height};
FadeLabel.Tag := 1;
end
else if FadeLabel.Tag <> 2 then
FadeLabel.Tag := 0;
end;
{ TBlurThread }
procedure TBlurThread.Execute;
begin
{ Place thread code here }
Synchronize(SetSize);
if FadeLabel.Tag = 0 then
begin
Temp_Bitmap.Width := FadeLabel.Width;
Temp_Bitmap.Height := FadeLabel.Height;
Temp_Bitmap.Canvas.Brush.Color := FadeLabel.Color;
Temp_Bitmap.Canvas.FillRect(FadeLabel.ClientRect);
Temp_Bitmap.Canvas.Font.Color := F_color; //clBlack
if FadeLabel.Alignment = taRightJustify then
text_position := FadeLabel.Width -
Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X {add_width}
else if FadeLabel.Alignment = taCenter then
text_position := (FadeLabel.Width -
Temp_Bitmap.Canvas.TextWidth(FadeLabel.Caption) - F_width - F_X
{add_width}) div 2
else
text_position := 0;
Temp_Bitmap.Canvas.TextOut(0, 0, FadeLabel.Caption);
Temp_Bitmap.PixelFormat := pf24Bit;
GBlur(Temp_Bitmap, F_width);
//Temp_Bitmap.SaveToFile('a.bmp');
Synchronize(ShowBlur);
end;
end;
end.
Взято из
The gaussian kernel exp(-(x^2 + y^2)) is of the form f(x)*g(y), which means that you can perform a two-dimensional convolution by doing a sequence of one-dimensional convolutions - first you convolve each row and then each column. This is much faster (an N^2 becomes an N*2). Any convolution requires some temporary storage - below the BlurRow routine allocates and frees the memory, meaning that it gets allocated and freed once for each row. Probably changing this would speed it up some, it's not entirely clear how much.
The kernel "size" is limited to 200 entries. In fact if you use radius anything like that large it will take forever - you want to try this with a radius = 3 or 5 or something. For a kernel with that many entries a straight convolution is the thing to do, while when the kernel gets much larger Fourier transform techniques will be better (I couldn't say what the actual cutoff is.)
One comment that needs to be made is that a gaussian blur has the magical property that you can blur each row one by one and then blur each column - this is much faster than an actual 2-d convolution.
Anyway, you can do this:
unit GBlur2;
interface
uses
Windows, Graphics;
type
PRGBTriple = ^TRGBTriple;
TRGBTriple = packed record
b: byte; {easier to type than rgbtBlue}
g: byte;
r: byte;
end;
PRow = ^TRow;
TRow = array[0..1000000] of TRGBTriple;
PPRows = ^TPRows;
TPRows = array[0..1000000] of PRow;
const
MaxKernelSize = 100;
type
TKernelSize = 1..MaxKernelSize;
TKernel = record
Size: TKernelSize;
Weights: array[-MaxKernelSize..MaxKernelSize] of single;
end;
{the idea is that when using a TKernel you ignore the Weights except
for Weights in the range -Size..Size.}
procedure GBlur(theBitmap: TBitmap; radius: double);
implementation
uses
SysUtils;
procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double);
{makes K into a gaussian kernel with standard deviation = radius. For the current application
you set MaxData = 255 and DataGranularity = 1. Now the procedure sets the value of K.Size so
that when we use K we will ignore the Weights that are so small they can't possibly matter. (Small
Size is good because the execution time is going to be propertional to K.Size.)}
var
j: integer;
temp, delta: double;
KernelSize: TKernelSize;
begin
for j := Low(K.Weights) to High(K.Weights) do
begin
temp := j / radius;
K.Weights[j] := exp(-temp * temp / 2);
end;
{now divide by constant so sum(Weights) = 1:}
temp := 0;
for j := Low(K.Weights) to High(K.Weights) do
temp := temp + K.Weights[j];
for j := Low(K.Weights) to High(K.Weights) do
K.Weights[j] := K.Weights[j] / temp;
{now discard (or rather mark as ignorable by setting Size) the entries that are too small to matter.
This is important, otherwise a blur with a small radius will take as long as with a large radius...}
KernelSize := MaxKernelSize;
delta := DataGranularity / (2 * MaxData);
temp := 0;
while (temp < delta) and (KernelSize > 1) do
begin
temp := temp + 2 * K.Weights[KernelSize];
dec(KernelSize);
end;
K.Size := KernelSize;
{now just to be correct go back and jiggle again so the sum of the entries we'll be using is exactly 1}
temp := 0;
for j := -K.Size to K.Size do
temp := temp + K.Weights[j];
for j := -K.Size to K.Size do
K.Weights[j] := K.Weights[j] / temp;
end;
function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
if (theInteger <= Upper) and (theInteger >= Lower) then
result := theInteger
else if theInteger > Upper then
result := Upper
else
result := Lower;
end;
function TrimReal(Lower, Upper: integer; x: double): integer;
begin
if (x < upper) and (x >= lower) then
result := trunc(x)
else if x > Upper then
result := Upper
else
result := Lower;
end;
procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
j, n, LocalRow: integer;
tr, tg, tb: double; {tempRed, etc}
w: double;
begin
for j := 0 to High(theRow) do
begin
tb := 0;
tg := 0;
tr := 0;
for n := -K.Size to K.Size do
begin
w := K.Weights[n];
{the TrimInt keeps us from running off the edge of the row...}
with theRow[TrimInt(0, High(theRow), j - n)] do
begin
tb := tb + w * b;
tg := tg + w * g;
tr := tr + w * r;
end;
end;
with P[j] do
begin
b := TrimReal(0, 255, tb);
g := TrimReal(0, 255, tg);
r := TrimReal(0, 255, tr);
end;
end;
Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;
procedure GBlur(theBitmap: TBitmap; radius: double);
var
Row, Col: integer;
theRows: PPRows;
K: TKernel;
ACol: PRow;
P: PRow;
begin
if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
raise exception.Create('GBlur only works for 24-bit bitmaps');
MakeGaussianKernel(K, radius, 255, 1);
GetMem(theRows, theBitmap.Height * SizeOf(PRow));
GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
{record the location of the bitmap data:}
for Row := 0 to theBitmap.Height - 1 do
theRows[Row] := theBitmap.Scanline[Row];
{blur each row:}
P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
for Row := 0 to theBitmap.Height - 1 do
BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
{now blur each column}
ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
for Col := 0 to theBitmap.Width - 1 do
begin
{first read the column into a TRow:}
for Row := 0 to theBitmap.Height - 1 do
ACol[Row] := theRows[Row][Col];
BlurRow(Slice(ACol^, theBitmap.Height), K, P);
{now put that row, um, column back into the data:}
for Row := 0 to theBitmap.Height - 1 do
theRows[Row][Col] := ACol[Row];
end;
FreeMem(theRows);
FreeMem(ACol);
ReAllocMem(P, 0);
end;
end.
Example:
procedure TForm1.Button1Click(Sender: TObject);
var
b: TBitmap;
begin
if not openDialog1.Execute then
exit;
b := TBitmap.Create;
b.LoadFromFile(OpenDialog1.Filename);
b.PixelFormat := pf24Bit;
Canvas.Draw(0, 0, b);
GBlur(b, StrToFloat(Edit1.text));
Canvas.Draw(b.Width, 0, b);
b.Free;
end;
Note that displaying 24-bit bitmaps on a 256-color system requires some special tricks - if this looks funny at 256 colors it doesn't prove the blur is wrong.
Взято с
Delphi Knowledge BaseПолучение имени конфигурации HardWare profile
Получение имени конфигурации HardWare profile
function GettingHWProfileName: string; //Win95OSR2 or later and NT4.0 or later
var
pInfo: tagHW_PROFILE_INFOA;
begin
GetCurrentHwProfile(pInfo);
Result:=pInfo.szHwProfileName;
end;
Получение информации о таблице
Получение информации о таблице
Вам нужно воспользоваться свойством FieldDefs. В следующем примере список полей и их соответствующий размер передается компоненту TMemo (расположенному на форме) с именем Memo1:
procedureTForm1.ShowFields;
var
i: Word;
begin
Memo1.Lines.Clear;
Table1.FieldDefs.Update;
{ должно быть вызвано, если Table1 не активна }
for i := 0 to Table1.FieldDefs.Count - 1 do
With Table1.FieldDefs.Items[i] do
Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
end;
Если вам просто нужны имена полей (FieldNames), то используйте метода TTable GetFieldNames:
GetIndexNames для получения имен индексов:
var
FldNames, IdxNames : TStringList;
begin
FldNames := TStringList.Create;
IdxNames := TStringList.Create;
If Table1.State = dsInactive then
Table1.Open;
Table1.GetFieldNames(FldNames);
Table1.GetIndexNames(IdxNames);
{...... используем полученную информацию ......}
FldNames.Free; {освобождаем stringlist}
IdxNames.Free;
end;
Для получения информации об определенном поле вы должны использовать FieldDef.
Взято из
Получение IP-адреса и маски для всех сетевых интерфейсов
Получение IP-адреса и маски для всех сетевых интерфейсов
Автор: Giannis Sampaziotis
Существует множество методов получения IP адреса компьютера. Но данный пример представляет наиболее корректный способ получения всех адресов, сетевых масок, broadcast адресов и статусов для всех интерфейсов включая циклический 127.0.0.1 - требует WinSock 2.
Совместимость: Delphi 3.х (или выше)
Это завершённый Delphi компонент. Для его использования достаточно вызвать :
EnumInterfaces(var s string): Boolean;
которая вернёт строку, разделённую CRLF и содержащую всё, нужную нам информацию.
unit USock;
interface
uses Windows, Winsock;
{
Если Вы поместите строку результатов в wide TMEMO (в его свойство memo.lines.text)
то никаких результатов не увидите.
Тестировалось на Win98/ME/2K, 95 OSR 2 и NT service
pack #3 , потому что используется WinSock 2 (WS2_32.DLL)
}
function EnumInterfaces(var sInt: string): Boolean;
{ функция WSAIOCtl импортируется из Winsock 2.0 - Winsock 2 доступен }
{ только в Win98/ME/2K и 95 OSR2, NT srv pack #3 }
function WSAIoctl(s: TSocket; cmd: DWORD; lpInBuffer: PCHAR; dwInBufferLen:
DWORD;
lpOutBuffer: PCHAR; dwOutBufferLen: DWORD;
lpdwOutBytesReturned: LPDWORD;
lpOverLapped: POINTER;
lpOverLappedRoutine: POINTER): Integer; stdcall; external 'WS2_32.DLL';
{ Константы взятые из заголовка C файлов }
const SIO_GET_INTERFACE_LIST = $4004747F;
IFF_UP = $00000001;
IFF_BROADCAST = $00000002;
IFF_LOOPBACK = $00000004;
IFF_POINTTOPOINT = $00000008;
IFF_MULTICAST = $00000010;
type sockaddr_gen = packed record
AddressIn: sockaddr_in;
filler: packed array[0..7] of char;
end;
type INTERFACE_INFO = packed record
iiFlags: u_long; // Флаги интерфейса
iiAddress: sockaddr_gen; // Адрес интерфейса
iiBroadcastAddress: sockaddr_gen; // Broadcast адрес
iiNetmask: sockaddr_gen; // Маска подсети
end;
implementation
{-------------------------------------------------------------------
1. Открываем WINSOCK
2. Создаём сокет
3. Вызываем WSAIOCtl для доступа к сетевым интерфейсам
4. Для каждого интерфейса, получаем IP, MASK, BROADCAST, статус
5. Разделяем строку символом CRLF
6. Конец :)
--------------------------------------------------------------------}
function EnumInterfaces(var sInt: string): Boolean;
var s: TSocket;
wsaD: WSADATA;
NumInterfaces: Integer;
BytesReturned, SetFlags: u_long;
pAddrInet: SOCKADDR_IN;
pAddrString: PCHAR;
PtrA: pointer;
Buffer: array[0..20] of INTERFACE_INFO;
i: Integer;
begin
result := true; // Инициализируем переменную
sInt := '';
WSAStartup($0101, wsaD); // Запускаем WinSock
// Здесь можно дабавить различные обработчики ошибки :)
s := Socket(AF_INET, SOCK_STREAM, 0); // Открываем сокет
if (s = INVALID_SOCKET) then exit;
try // Вызываем WSAIoCtl
PtrA := @bytesReturned;
if (WSAIoCtl(s, SIO_GET_INTERFACE_LIST, nil, 0, @Buffer, 1024, PtrA, nil,
nil)
<> SOCKET_ERROR)
then
begin // Если OK, то определяем количество существующих интерфейсов
NumInterfaces := BytesReturned div SizeOf(INTERFACE_INFO);
for i := 0 to NumInterfaces - 1 do // Для каждого интерфейса
begin
pAddrInet := Buffer[i].iiAddress.addressIn; // IP адрес
pAddrString := inet_ntoa(pAddrInet.sin_addr);
sInt := sInt + ' IP=' + pAddrString + ',';
pAddrInet := Buffer[i].iiNetMask.addressIn; // Маска подсети
pAddrString := inet_ntoa(pAddrInet.sin_addr);
sInt := sInt + ' Mask=' + pAddrString + ',';
pAddrInet := Buffer[i].iiBroadCastAddress.addressIn; // Broadcast адрес
pAddrString := inet_ntoa(pAddrInet.sin_addr);
sInt := sInt + ' Broadcast=' + pAddrString + ',';
SetFlags := Buffer[i].iiFlags;
if (SetFlags and IFF_UP) = IFF_UP then
sInt := sInt + ' Interface UP,' // Статус интерфейса up/down
else
sInt := sInt + ' Interface DOWN,';
if (SetFlags and IFF_BROADCAST) = IFF_BROADCAST then // Broadcasts
sInt := sInt + ' Broadcasts supported,' // поддерживает или
else // не поддерживается
sInt := sInt + ' Broadcasts NOT supported,';
if (SetFlags and IFF_LOOPBACK) = IFF_LOOPBACK then // Циклический или
sInt := sInt + ' Loopback interface'
else
sInt := sInt + ' Network interface'; // нормальный
sInt := sInt + #13#10; // CRLF между каждым интерфейсом
end;
end;
except
end;
//
// Закрываем сокеты
//
CloseSocket(s);
WSACleanUp;
result := false;
end;
end.
Взято с Исходников.ru
Получение количества установленных процессоров
Получение количества установленных процессоров
function GettingProcNum: string; //Win95 or later and NT3.1 or later
var
Struc: _SYSTEM_INFO;
begin
GetSystemInfo(Struc);
Result:=IntToStr(Struc.dwNumberOfProcessors);
end;
Получение переменных среды
Получение переменных среды
procedureGetEnvironmentStrings(ss: TStrings);
{Переменные среды}
var
ptr: PChar;
s: string;
Done: boolean;
begin
ss.Clear;
s := '';
Done := FALSE;
ptr := windows.GetEnvironmentStrings;
while Done = false do begin
if ptr^ = #0 then begin
inc(ptr);
if ptr^ = #0 then Done := TRUE
else ss.Add(s);
s := ptr^;
end else s := s + ptr^;
inc(ptr);
end;
end;
Взято с
Получение списка DLL загруженных приложением
Получение списка DLL загруженных приложением
Автор: Simon Carter
Иногда бывает полезно знать какими DLL-ками пользуется Ваше приложение. Давайте посмотрим как это можно сделать в Win NT/2000.
Пример функции
unit ModuleProcs;
interface
uses Windows, Classes;
type
TModuleArray = array[0..400] of HMODULE;
TModuleOption = (moRemovePath, moIncludeHandle);
TModuleOptions = set of TModuleOption;
function GetLoadedDLLList(sl: TStrings;
Options: TModuleOptions = [moRemovePath]): Boolean;
implementation
uses SysUtils;
function GetLoadedDLLList(sl: TStrings;
Options: TModuleOptions = [moRemovePath]): Boolean;
type
EnumModType = function (hProcess: Longint; lphModule: TModuleArray;
cb: DWord; var lpcbNeeded: Longint): Boolean; stdcall;
var
psapilib: HModule;
EnumProc: Pointer;
ma: TModuleArray;
I: Longint;
FileName: array[0..MAX_PATH] of Char;
S: string;
begin
Result := False;
(* Данная функция запускается только для Widnows NT *)
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
psapilib := LoadLibrary('psapi.dll');
if psapilib = 0 then
Exit;
try
EnumProc := GetProcAddress(psapilib, 'EnumProcessModules');
if not Assigned(EnumProc) then
Exit;
sl.Clear;
FillChar(ma, SizeOF(TModuleArray), 0);
if EnumModType(EnumProc)(GetCurrentProcess, ma, 400, I) then
begin
for I := 0 to 400 do
if ma[i] <> 0 then
begin
FillChar(FileName, MAX_PATH, 0);
GetModuleFileName(ma[i], FileName, MAX_PATH);
if CompareText(ExtractFileExt(FileName), '.dll') = 0 then
begin
S := FileName;
if moRemovePath in Options then
S := ExtractFileName(S);
if moIncludeHandle in Options then
sl.AddObject(S, TObject(ma[I]))
else
sl.Add(S);
end;
end;
end;
Result := True;
finally
FreeLibrary(psapilib);
end;
end;
end.
Для вызова приведённой функции надо сделать следующее:
Добавить listbox на форму (Listbox1)
Добавить кнопку на форму (Button1)
Обработчик события OnClick для кнопки будет выглядеть следующим образом
procedure TForm1.Button1Click(Sender: TObject);
begin
GetLoadedDLLList(ListBox1.Items, [moIncludeHandle, moRemovePath]);
end;
Взято с Исходников.ru
Получение ссылки на экземпляр класса
Получение ссылки на экземпляр класса
...мне также понадобилось в подпрограмме получить ссылку на дочернее MDI-окно без сообщения подпрограмме с каким конкретно классом MDI необходимо работать. Что я сделал: я передавал в виде параметров тип дочернего MDI-окна и ссылку как нетипизированную переменную и затем обрабатывал это в подпрограмме.
Вот пример. Эта подпрограмма работает с дочерним окном, которое может иметь только один экземпляр. Если оно не открыто, подпрограмма создаст его, если оно открыто, оно переместит его на передний план.
procedureFormLoader(FormClassType: TFormClass; var FormName);
begin
if TForm(FormName) = nil then
begin
Application.CreateForm(FormClassType, FormName);
end
else
begin
TForm(FormName).BringToFront;
TForm(FormName).WindowState := wsNormal;
end;
end;
Вот как это вызывать:
procedure TfrmTest.sbOpenClick(Sender: TObject);
begin
FormLoader(TfrmTest, frmTest);
end;
Взято из
Советов по Delphi от
Сборник Kuliba
Получение типа клавиатуры
Получение типа клавиатуры
function GettingKeybType: string; //Win95 or later and NT3.1 or later
var
Flag: integer;
begin
Flag:=0;
Case GetKeyboardType(Flag) of
1: Result:='IBM PC/XT or compatible (83-key) keyboard';
2: Result:='Olivetti "ICO" (102-key) keyboard';
3: Result:='IBM PC/AT (84-key) or similar keyboard';
4: Result:='IBM enhanced (101- or 102-key) keyboard';
5: Result:='Nokia 1050 and similar keyboards';
6: Result:='Nokia 9140 and similar keyboards';
7: Result:='Japanese keyboard';
end;
end;
Получение уровня процессора
Получение уровня процессора
function GettingProcLevel: string; //Win95 or later and NT3.1 or later
var
Struc: _SYSTEM_INFO;
begin
GetSystemInfo(Struc);
Case Struc.wProcessorLevel of
3: Result:='Intel 80386';
4: Result:='Intel 80486';
5: Result:='Intel Pentium';
6: Result:='Intel Pentium II or better';
end;
end;
Получить и установить системные цвета
Получить и установить системные цвета
var
OldColor: TColor;
Element: TColor = COLOR_BTNFACE;
{....}
{
Set the color for a system element. SetSysColors function
changes the current Windows session only.
The new colors are not saved when Windows terminates.
For a list of color elements see Win32 API Help - Function GetSysColor
Open the ColorDialog - and set the new color systemwide
}
procedure TForm1.Button1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
begin
SetSysColors(1, Element, ColorDialog1.Color);
end;
end;
{
Save the old color value of the element COLOR_BTNFACE to restore on Button2 click
}
procedure TForm1.FormShow(Sender: TObject);
begin
OldColor := GetSysColor(COLOR_BTNFACE);
end;
{
Restore the old color value
Stellt den alten Farbwert wieder her
}
procedure TForm1.Button2Click(Sender: TObject);
begin
SetSysColors(1, Element, OldColor);
end;
Взято из
Получить информацию о BIOSе
Получить информацию о BIOSе
Вот пример как можно даты БИОС материнской платы и видеокарты выдрать.
То же самое можно с названием производителя и версией.
В WinNT приходится читать не из ПЗУ а из реестра но это достаточно надежно
- соотв ключи WinNT закрывает на запись и обновляет при каждом старте (?).
Для Win9x можешь хоть весь БИОС напрямую читать.
Получить заводской номер винчестера (не тот что getvolumeinfo дает) ИМХО
невозможно - порты IDE даже Win9x блокирует.
type
TRegistryRO= class (TRegistry)
function OpenKeyRO (const Key: string): Boolean;
end;
{ это уже ветхая история - был один глюк у D3}
implementation
uses WAPIInfo, Windows, SysUtils, StrUtils;
function TRegistryRO.OpenKeyRO (const Key: string): Boolean;
function
IsRelative(const Value: string): Boolean;
begin Result := not ((Value <> '') and (Value[1] = '\')) end;
var
TempKey: HKey;
S: string;
Relative: Boolean;
begin
S := Key;
Relative := IsRelative(S);
if not Relative then Delete(S, 1, 1);
TempKey := 0;
Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,
KEY_READ, TempKey) = ERROR_SUCCESS;
if Result then begin
if (CurrentKey <> 0) and Relative then S := CurrentPath + '\' + S;
ChangeKey(TempKey, S);
end;
end;
function GetBIOSDate : string;
const
BIOSDatePtr
= $0ffff5;
SystemKey = 'HARDWARE\DESCRIPTION\System';
BiosDateParam = 'SystemBiosDate';
var
p : pointer;
s : string[128];
begin
if OSisNT then begin
with TRegistryRO.Create do try
RootKey := HKEY_LOCAL_MACHINE;
if OpenKeyRO (SystemKey) then begin
s := ReadString (BiosDateParam);
end;
finally Free;
end; { of try}
end
else try
s[0] := #8;
p := Pointer(BIOSDatePtr);
Move (p^, s[1], 8);
except FillChar (s[1],
8, '9');
end; { of try}
Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2);
end;
function GetVideoDate : string;
const
VideoDatePtr = $0C0000;
SystemKey = 'HARDWARE\DESCRIPTION\System';
VideoDateParam = 'VideoBiosDate';
var
p : pointer;
s : string[255];
begin
if OSisNT then begin
with TRegistryRO.Create do try
RootKey := HKEY_LOCAL_MACHINE;
if OpenKeyRO (SystemKey)
then s := ReadString (VideoDateParam)
else s := 'NT/de/tected';
finally Free;
end; { of
try}
end
else try
s[0] := #255;
p := Pointer(VideoDatePtr + 60); { первые $60 - строка CopyRight}
Move (p^, s[1], 255);
if pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8)
else begin
p := Pointer(VideoDatePtr + 60 + 250);
Move (p^, s[1], 255);
if pos('/', s) > 2 then s := copy (s, pos('/', s) - 2, 8);
end;
except FillChar (s[1], 8, '9');
end; { of try}
Result := copy (s, 1, 2) + copy (s, 4, 2) + copy (s, 7, 2);
end;
unit WAPIInfo;
interface
uses
Registry, SysUtils, Windows;
procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string);
function OSisNT : boolean;
procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string);
procedure GetMemInfo (var MemStr : string);
implementation
procedure GetOSVerInfo (var OSID : DWORD; var OSStr : string);
var
OSVerInfo : TOSVersionInfo;
Reg : TRegistry;
s : string;
begin
OSVerInfo.dwOSVersionInfoSize := SizeOf (OSVerInfo);
GetVersionEx (OSVerInfo);
OSID := OSVerInfo.dwPlatformID;
case OSID of
VER_PLATFORM_WIN32S : OSStr := 'Windows 3+';
VER_PLATFORM_WIN32_WINDOWS : OSStr := 'Windows 95+';
VER_PLATFORM_WIN32_NT : begin
OSStr := 'Windows NT';
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey ('SYSTEM\CurrentControlSet\Control\', False)
then try
s := Reg.ReadString ('ProductOptions')
except s := ''
end;
if s = 'WINNT' then OSStr := OSStr + ' WorkStation'
else if s = 'SERVERNT' then OSStr := OSStr + ' Server 3.5 & hi'
else if s = 'LANMANNT' then OSStr := OSStr + ' Advanced server 3.1';
Reg.Free;
end;
end;
with OSVerInfo do OSStr := OSStr + Format (' %d.%d (выпуск %d)',
[dwMajorVersion, dwMinorVersion, LoWord(dwBuildNumber)]);
end;
function OSisNT : boolean;
var
s : string;
i : DWORD;
begin
GetOSVerInfo (i, s);
Result := (i = VER_PLATFORM_WIN32_NT);
end;
procedure GetCPUInfo (var CPUID : DWORD; var CPUStr : string);
var SI : TSystemInfo;
begin
GetSystemInfo (SI);
CPUID := SI.dwProcessorType;
case CPUID of
386: CPUStr := '80386-совместимый процессор';
486: CPUStr := '80486-совместимый процессор';
586: CPUStr := 'Pentium-совместимый процессор';
else CPUStr := 'Неизвестный процессор';
end;
{ case SI.wProcessorArchitecture of
PROCESSOR_ARCHITECTURE_INTEL: ;
MIPS
ALPHA
PPC
UNKNOWN
end;}
end;
procedure GetMemInfo (var MemStr : string);
var MemInfo : TMemoryStatus;
begin
MemInfo.dwLength := SizeOf (MemInfo);
GlobalMemoryStatus (MemInfo);
with MemInfo do MemStr := Format ('ОЗУ: %0.2f M (свободно %0.2f M)'#$d+
' Файл подкачки: %0.2f M (свободно: %0.2f M)'#$d,
[(dwTotalPhys div 1024) / 1024,
(dwAvailPhys div 1024) / 1024,
(dwTotalPageFile div 1024) / 1024,
(dwAvailPageFile div 1024) / 1024]);
end;
end.
PS Возможно, эти процедуры не всегда дату возвращают
но то что практически всегда для разных материнских/видео
плат возвращаются разные значения - проверено, что мне
собственно и требовалось.
Andrey Sorokin from sunny
Russian Technology http://attend.to/rt anso@rt.spb.ru
Автор:
SongВзято из
Пользователи, пароли, защита информации
Пользователи, пароли, защита информации
Cодержание раздела:
См. также статьи в других разделах:
Ползунок компонента TScrollBar все время мигает. Как это отключить?
Ползунок компонента TScrollBar все время мигает. Как это отключить?
Установите свойтсво ScrollBar.TabStop в False.
Помещение компонентов в DBGrid
Помещение компонентов в DBGrid
Данный совет и сопутствующий код показывает как просто поместить любой компонент в ячейку сетки данных. Компонент в данном контексте может означать любой видимый элемент управления - от простого combobox до сложного диалогового окна. Методы, описанные ниже, применимы практически к любому визуальному компоненту. Если Вы можете поместить его на форму, то, вероятно, сможете поместить и в ячейку DBGrid.
Здесь нет новых идей, фактически основная технология работы заключается в имитации-трансплантации внешних компонентов в DBGrid. Идея в том, чтобы получить контроль над табличной сеткой. Практически DBGrid состоит из набора компонентов TDBEdit. Вводя данные в ячейку, вы работаете непосредственно с TDBEdit. Остальные без фокуса ячейки в данный момент реально являются статичной картинкой. В данном совете Вы узнаете как поместить в сфокусированную ячейку другой, отличный от TDBEdit, визуальный компонент.
КОМПОНЕНТ #1 - TDBLOOKUPCOMBO
Вам нужна форма с компонентом DBGrid на ней. Создайте новый проект и поместите на основную форму DBGrid.
Далее поместите на форму TTable, установите псевдоним (Alias) в DBDEMOS, TableName в GRIDDATA.DB и присвойте свойству Active значение True. Поместите DataSource и сошлитесь в свойстве DataSet на Table1. Вернитесь к DBGrid и укажите в свойстве DataSource компонент DataSource1. Данные из GRIDDATA.DB должные появиться в табличной сетке...
Первый элемент, который мы собираемся поместить в DBGrid - TDBLookupCombo, т.к. нам нужна вторая таблица для поиска. Поместите второй TTable на форму. Установите псевдоним (Alias) в DBDEMOS, TableName в CUSTOMER.DB и присвойте свойству Active значение True. Поместите второй DataSource и сошлитесь в свойстве DataSet на Table2.
Теперь нужно поместить компонент TDBLookupCombo из палитры Data Controls на любое место формы - это не имеет никакого значения, т.к. он обычно будет невидим или будет нами имплантирован в табличную сетку. Установите свойства компонента LookuoCombo следующим образом:
DataSourceDataSource1
DataField CustNo
LookupSource DataSource2
LookupField CustNo
LookupDisplay CustNo {Вы можете изменить это на Company позже,
но сейчас пусть это будет CustNo)
Пока мы только настроили компоненты. Теперь давайте создадим некоторый код.
Первое, что Вам необходимо - сделать так, чтобы DBLookupCombo, который Вы поместили на форму, во время запуска приложения оставался невидимым. Для этого выберите Form1 в инспекторе объектов, перейдите на закладку Events (события) и дважды щелкните на событии onCreate. Delphi немедленно сгенерит и отобразит скелет кода будущего обработчика события onCreate:
procedure TForm1.FormCreate(Sender: TObject);
begin
end;
Присвойте свойству Visible значение False в LookupCombo следующим образом:
procedure TForm1.FormCreate(Sender: TObject);
begin
DBLookupCombo1.Visible := False;
end;
Наверняка многим стало интересно, почему я не воспользовался инспектором объектов для изменения свойств компонента. Действительно, можно было бы и так. Лично я таким способом инициализирую компоненты, чьи свойства могут изменяться во время работы приложения. Я изменил статическое свойство, которое не отображается во время проектирования (если воспользоваться инспектором объктов). Я думаю это делает код легче для понимания.
Теперь нам необходимо "прикрутить" компонент к нашей табличной сетке. Наша задача - автоматически отобразить DBLookupCombo в ячейке во время получения ею фокуса (или перемещении курсора). Для этого необходимо написать код для обработчиков двух событий: OnDrawDataCell и OnColExit. Первым делом обработаем событие OnDrawDataCell. Дважды щелкните на строчке OnDrawDataCell в инспекторе объектов и введите следующий код:
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
if (gdFocused in State) then
begin
if (Field.FieldName = DBLookupCombo1.DataField) then
begin
DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
DBLookupCombo1.Width := Rect.Right - Rect.Left;
{ DBLookupCombo1.Height := Rect.Bottom - Rect.Top; }
DBLookupCombo1.Visible := True;
end;
end;
end;
Причины чрезмерного использования конструкций begin/end скоро станут понятны. В коде "говорится", что если параметр State имеет значение gdFocused, то данная ячейка имеет фокус (в любой момент времени только одна ячейка в табличной сетке может иметь фокус). Далее: если это выделенная ячейка и ячейка имеет тоже имя поля как и поле данных DBLookupCombo, DBLookupCombo необходимо поместить над этой ячейкой и сделать его видимым. Обратите внимание на определение позиции DBLookupCombo: она определяется относительно формы, а не ячейки. Так, например, положение левой стороны LookupCombo должно учитывать положение сетки (DBGrid1.Left) плюс положение соответствующей ячейки относительно сетки (Rect.Left).
Также обратите внимание на то, что определение высоты LookupCombo в коде закомментарено. Причина в том, что LookupCombo имеет минимальную высоту. Вы просто не сможете сделать ее меньше. Минимальная высота LookupCombo больше высоты ячейки. Если Вы раскомментарили строку, касающуюся высоты LookupCombo, Ваш код изменит размер компонента и Delphi немедленно его перерисует. Это вызовет неприятное моргание компонента. Бороться с этим невозможно. Позвольте, чтобы LookupCombo был немного больше, чем ячейка. Это выглядит немного странным, но это работает.
Теперь ради шутки запустите программу. Заработала? Сразу после запуска переместите курсор на одну из ячеек табличной сетки. Вы ожидали чего-то большего? Да! Мы только в середине пути. Теперь нам нужно спрятать LookupCombo при покидании курсором колонки. Напишем обработчик события onColExit. Это должно выглядеть примерно так:
procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
If DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
DBLookupCombo1.Visible := false;
end;
Код использует свойство TDBGrids SelectedField для ассоциации имени поля ячейки (FieldName) с нашим LookupCombo. Код "говорит": "Если ячейка была в колонке с DBLookupCombo (имя поля ячейки совпадает с именем поля DBLookupCombo), его необходимо сделать невидимым".
Теперь снова запустите приложение. Чувствуете эффект?
Теперь вроде бы все правильно, но мы забыли об одной вещи. Попробуйте ввести новое значение в одно из LookupCombo. Проблема в том, что нажатие клавиши обрабатывает DBGrid, а не LookupCombo. Чтобы исправить это, нам нужно написать для табличной сетки обработчик события onKeyPress. Это должно выглядеть примерно так:
procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
if (key <> chr(9)) then
begin
if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
begin
DBLookupCombo1.SetFocus;
SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
end;
end;
end;
В данном коде "говорится": если нажатая клавиша не является клавишей Tab (Chr(9)) и текущее поле в табличной сетке LookupCombo, тогда установите фокус на LookupCombo и передайте сообщение с кодом нажатой клавиши LookupCombo. Здесь я воспользовался WIN API функцией. Вам не нужно знать как это работает, достаточно того, что это просто работает.
Небольшое пояснение я все же дам. Для того, чтобы функция Window SendMessage послала сообщение "куда надо", ей в качестве параметра необходим дескриптор ("адрес") нужного компонента. Используйте свойство компонента Handle. Затем нужно сообщить компоненту что мы от него хотим. В нашем случае это Windows-сообщение WM_CHAR, извещающее LookupCombo о том, что ему посылается символ. Наконец, мы передаем ему сам символ нажатой клавиши - word(Key). Word(key) - приведение к типу word параметра Key события нажатия клавиши. Все достаточно просто, правда? Все, что Вам действительно необходимо сделать - заменить имя DBLookupCombo1 нашего вымышленного компонента на имя реального компонента, который будет участвовать в "модернизации" табличной сетки. Более подробную информацию о функции SendMessage Вы можете почерпнуть из электронной справки, поставляемой вместе с Delphi.
Запустите снова Ваше приложение и попробуйте что-нибудь ввести. Это работает! Экспериментируя, Вы увидите что с помощью клавиши Tab Вы можете перейти из режима редактирования в режим перемещения курсора и наоборот.
Теперь перейдите к инспектору объектов и измнените у компонента DBLookupCombo свойство LookupDIsplay на Company. Снова запустите. Это то, что Вы ожидали?
КОМПОНЕНТ #2 - TDBCOMBO
Здесь я не собираюсь обсуждать технологию имплантации DBCombo, так как она практически не отличается от той, что была показана выше. Все написанное в пункте #1 имеет силу и здесь. Вот пошагово разработанный код для вашего компонента.
procedure TForm1.FormCreate(Sender: TObject);
begin
DBLookupCombo1.Visible := False;
DBComboBox1.Visible := False;
end;
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
if (gdFocused in State) then
begin
if (Field.FieldName = DBLookupCombo1.DataField) then
begin
DBLookupCombo1.Left := Rect.Left + DBGrid1.Left;
DBLookupCombo1.Top := Rect.Top + DBGrid1.top;
DBLookupCombo1.Width := Rect.Right - Rect.Left;
DBLookupCombo1.Visible := True;
end
else if (Field.FieldName = DBComboBox1.DataField) then
begin
DBComboBox1.Left := Rect.Left + DBGrid1.Left;
DBComboBox1.Top := Rect.Top + DBGrid1.top;
DBComboBox1.Width := Rect.Right - Rect.Left;
DBComboBox1.Visible := True;
end
end;
end;
procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
if DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
DBLookupCombo1.Visible := false
else if DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
DBComboBox1.Visible := false;
end;
procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
if (key <> chr(9)) then
begin
if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
begin
DBLookupCombo1.SetFocus;
SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
end
else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
begin
DBComboBox1.SetFocus;
SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
end;
end;
end;
КОМПОНЕНТ #3 - TDBCHECKBOX
Технология работы с компонентом DBCheckBox более интересна. В этом случае нам необходимо дать понять пользователю о наличие компонента DBCheckBox в ячейках без фокуса. Вы можете вставлять статическое изображение компонента или динамически изменять изображение в зависимости от логического состояния элемента управления. Я выбрал второе. Я создал два BMP-файла - включенный (TRUE.BMP) и выключенный (FALSE.BMP) DBCheckBox. Поместите два компонента TImage на форму, присвойте им имена ImageTrue и ImageFalse и назначьте соответствующие BMP-файлы в свойстве Picture. Да, чуть не забыл: Вам также необходимо поместить на форму два компонента DBCheckbox. Установите набор данных обоих компонентов в DataSource1 и присвойстве свойству Color значение clWindow. Для начала создадим для формы обработчик события onCreate:
procedure TForm1.FormCreate(Sender: TObject);
begin
DBLookupCombo1.Visible := False;
DBCheckBox1.Visible := False;
DBComboBox1.Visible := False;
ImageTrue.Visible := False;
ImageFalse.Visible := False;
end;
Теперь нам нужен обработчик события onDrawDataCell чтобы делать что-то с ячейками, не имеющими фокуса. Здесь подойдет следующий код:
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
if (gdFocused in State) then
begin
if (Field.FieldName = DBLookupCombo1.DataField) then
begin
// ...СМОТРИ ВЫШЕ
end
else if (Field.FieldName = DBCheckBox1.DataField) then
begin
DBCheckBox1.Left := Rect.Left + DBGrid1.Left + 1;
DBCheckBox1.Top := Rect.Top + DBGrid1.top + 1;
DBCheckBox1.Width := Rect.Right - Rect.Left { - 1};
DBCheckBox1.Height := Rect.Bottom - Rect.Top { - 1};
DBCheckBox1.Visible := True;
end
else if (Field.FieldName = DBComboBox1.DataField) then
begin
// ...СМОТРИ ВЫШЕ
end
end
else {в этом месте помещаем статическое изображение компонента}
begin
if (Field.FieldName = DBCheckBox1.DataField) then
begin
if TableGridDataCheckBox.AsBoolean then
DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageTrue.Picture.Bitmap)
else
DBGrid1.Canvas.Draw(Rect.Left, Rect.Top, ImageFalse.Picture.Bitmap)
end
end;
end;
Самое интересное место - последний участок кода. Он выполняется в случае, когда состояние не равно gdFocused и сам CheckBox находится в колонке. В нем осуществляется проверка данных поля: если они равны True, то выводится рисунок TRUE.BMP, в противном случае - FALSE.BMP. Предварительно я создал два изображения, представляющие собой "слепок" двух логических состояния компонента, теперь будет очень трудно обнаружить отсутствие компонента в ячейках с фокусом и без оного. Теперь напишем обработчик события onColExit:
procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
If DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField then
DBLookupCombo1.Visible := false
else
If DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField then
DBCheckBox1.Visible := false
else
If DBGrid1.SelectedField.FieldName = DBComboBox1.DataField then
DBComboBox1.Visible := false;
end;
Организуйте обработку события onKeyPress как показано ниже:
procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
if (key <> chr(9)) then
begin
if (DBGrid1.SelectedField.FieldName = DBLookupCombo1.DataField) then
begin
DBLookupCombo1.SetFocus;
SendMessage(DBLookupCombo1.Handle, WM_Char, word(Key), 0);
end
else if (DBGrid1.SelectedField.FieldName = DBCheckBox1.DataField) then
begin
DBCheckBox1.SetFocus;
SendMessage(DBCheckBox1.Handle, WM_Char, word(Key), 0);
end
else if (DBGrid1.SelectedField.FieldName = DBComboBox1.DataField) then
begin
DBComboBox1.SetFocus;
SendMessage(DBComboBox1.Handle, WM_Char, word(Key), 0);
end;
end;
end;
Наконец, последняя хитрость. Для удобства пользователя заголовку компонента нужно присвоить текущее логическое значение. С самого начала у меня была идея поручить это обработчику события onChange, но проблема в том, что событие может возникнуть неединожды. Итак, я должен снова воспользоваться функцией Windows API и послать компоненту соответствующее значение: "SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0)", которая возвращает 0 в случае если компонент невключен и любое другое число в противном случае.
procedure TForm1.DBCheckBox1Click(Sender: TObject);
begin
if SendMessage(DBCheckBox1.Handle, BM_GetCheck, 0, 0) = 0 then
DBCheckBox1.Caption := ' ' + 'Ложь'
else
DBCheckBox1.Caption := ' ' + 'Истина'
end;
Это все. Надеюсь, Вы узнали для себя что-то новое. Я пробовал данную технологию с диалоговыми окнами. Делается достаточно просто и великолепно работает. Радует простота реализации. Вам даже не нужно знать как это работает, единственное, что Вам придется - заменить в тексте кода имена вымышленных компонентов на те, которые Вы реально хотите отображать в табличной сетке.
Ревизия
Вышеприведенный код оказался несвободным от недостатков - после первой публикации совета дотошные программисты таки обнаружили две значительные недоработки. Первая проблема - если компонент имеет фокус, то для перемещения на следующую ячейку необходимо двукратное нажатие клавиши Tab. Вторая проблема возникает при добавлении новой записи.
Проблема # 1 - Необходимость двойного нажатия клавиши Tab.
Действительно, компонент, используемый для имплантации существует сам по себе, а не является частью табличной сетки. В случае, когда DBGrid имеет фокус, то для перемещения на следующую ячейку необходимо двукратное нажатие клавиши Tab. Первое нажатие клавиши перемещает фокус из имплантированного компонента на текущую ячейку, находящуюся под этим компонентом, и только второе нажатие клавиши Tab перемещает нас в следующую ячейку. Попробуем это исправить.
Для начала в форме, содержащей табличную сетку, опишем логическую переменную WasInFloater следующим образом:
type
TForm1 = class(TForm)
...
...
private
{ Private declarations }
WasInFloater : Boolean;
...
...
end;
Затем для компонента LookupCombo напишем обработчик события onEnter, где присвоим переменной WasInFloater значение True. Это позволит нам понять где в данный момент находится фокус.
procedure TForm1.DBLookupCombo1Enter(Sender: TObject);
begin
WasInFloater := True;
end;
И, наконец, создаем хитрый обработчик события onKeyUp, позволяющий исправить досадный недостаток.
procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key in [VK_TAB]) and WasInFloater then
begin
SendMessage(DBGrid1.Handle, WM_KeyDown, Key, 0);
WasInFloater := False;
end;
end;
Данный код реагирует на нажатие клавиши и позволяет в случае, когда фокус передался из имплантированного элемента управления табличной сетеке, вторично эмулировать нажатие клавиши Tab (передается код нажатой клавиши, т.е. Tab). Это работает как для отдельной клавиши Tab, так и для комбинации Shift-Tab.
Проблема #2 - Новая запись исчезает, когда компонент получает фокус.
Вторая проблема - в случае, когда вы нажимаете в навигаторе кнопку "добавить", запись добавляется, но, когда Вы после щелкаете на одном из компонентов, имплантированных в табличную сетку, новая запись таинственным образом исчезает. Причина этого - странный флаг dgCancelOnExit в опциях DBGrid, который имеет значение True по умолчанию. Установите это в False и вышеназванная проблема исчезает.
По-моему, Borland неправильно поступил, назначив такое значение по умолчанию, флаг должен иметь значение False. Я все время сталкиваюсь с данной проблемой, да и не только я, судя по новостным конференциям. Данная опция действует в случае потери компонентом фокуса и отменяет последние результаты редактирования. Во всяком случае во всех моих проектах я первым делом сбрасываю данный флаг.
Взято с
Помещение компонентов в StringGrid
Помещение компонентов в StringGrid
Автор: Neil Rubenking
Некоторое время тому назад такой вопрос уже ставился: возможно ли поместить элемент управления, например, CheckBox или ComboBox внутрь компонента ...Grid. Я сегодня помозговал и нашел неплохую, на мой взгляд, технологию. Это работает! Вот решение для тех, кто этим интересуется:
При создании компонента (в обработчике OnCreate), создайте его объекты Objects[C,R], например TCheckBox.Create(Self). Имейте в виду, что вы должны присвоить ячейкам Cells[C,R] какие-либо значения прежде, чем чем вы сможете иметь доступ к Objects[C,R]. Установите у вновь созданного компонента свойство Visible в FALSE, а свойство parent в SELF. Осуществите другую необходимую инициализацию. Имейте в виду, что вы должны внести необходимые модули в список uses, если создаете тип компонента, которого нигде кроме как на форме нет.
Создайте процедуру, берущую координаты колонки/строки и правильно позиционирующую соотвествующий объект в пределах прямоугольника ячейки, например:
procedureTForm1.FixObjPosn(vCol, vRow: LongInt);
{Размещаем содержимое компонента в области прямоугольника ячейки}
var
R: TRect;
begin
R := StringGrid1.CellRect(vCol, vRow);
if StringGrid1.Objects[vCol, vRow] is TControl then
with TControl(StringGrid1.Objects[vCol, vRow]) do
if R.Right = R.Left then {прямоугольник ячейки невидим}
Visible := False
else
begin
InflateRect(R, -1, -1);
OffsetRect(R, StringGrid1.Left + 1, StringGrid1.Top + 1);
BoundsRect := R;
Visible := True;
end;
end;
смещение позиции необходимо, поскольку CellRect расчитывается относительно верхнего левого угла строки сетки, и родителем компонента является форма).
В обработчике события сетки OnSelectCell проверьте, располагается ли элемент Objects в текущей колонке Col и строке Row TControl - если так, установите его свойство visible в FALSE. Теперь вызовите процедуру установления координат из шага 2 для *НОВЫХ* Col и Row, передавая их из параметров обработчика события в параметры функции.
В обработчике OnTopLeftChanged просто вызовите FixObjPosn
В обработчике события OnDrawCell во-первых, если ячейка выбрана, EXIT. Если элемент ячейки Objects не TControl, также EXIT. В противном случае вам нужно создать код, обеспечивающий отрисовку "фасада" каждого типа элемента управления, которого вы разместили в сетке.
Обратите внимание на то, что если вы делаете что-либо с элементом управления, на который влияют ДРУГИЕ элементы управления (например, изменение статуса какой-либо радиокнопки из группы, или операции enable/disable), вы должны вызвать метод сетки Refresh.
Опс! Это звучит немного запутанно, но это работает. Успехов!
Взято с
Помещение VCL компонентов в область заголовка
Помещение VCL компонентов в область заголовка
Здесь есть хитрость:
Нужно разместить все необходимые элементы управления в отдельной форме, которая должна отслеживать перемещение и изменение размеров основной формы. Данная форма будет всегда находится над областью заголовка основной формы.
Нижеприведенный проект включает в себя 2 формы и выпадающий список (combobox). После запуска программы список появляется в области заголовка главной формы. Два ключевых вопроса: 1) организация перехвата сообщения WM_MOVE главной формы; и 2) возвращение фокуса в главную форму после того, как пользователь нажмет на каком-либо элементе управления, способным иметь фокус (например, TComboBox, TButton и др.)
Я использую 32-битную Delphi 2.0 под Win95, тем не менее данный код должен работать с любой версией Delphi.
Вот исходный код главной формы:
unitUnit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
procedure FormResize(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormHide(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure WMMove(var Msg: TWMMove); message WM_MOVE;
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.DFM}
procedure TForm1.FormResize(Sender: TObject);
begin
with Form2 do
begin
{Заменим мои магические числа реальной информацией SystemMetrics}
Width := Form1.Width - 120;
Top := Form1.Top + GetSystemMetrics(SM_CYFRAME);
Left := ((Form1.Left + Form1.Width) - Width) - 60;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Form2.Show;
end;
procedure TForm1.FormHide(Sender: TObject);
begin
Form2.Hide;
end;
procedure TForm1.WMMove(var Msg: TWMMove);
begin
inherited;
if (Visible) then
FormResize(Self);
end;
end.
Вот исходный код для псевдо-заголовка. Данная форма может содержать любые элементы управления VCL, которые вы хотите установить в области заголовка главной формы. По существу, это - независимый диалог со следующими свойствами:
Caption='' {NULL строка}
Height={высота области заголовка}
Width={высота всех компонентов на форме}
BorderIcons=[] {пусто}
BorderStyle=bsNone
FormStyle=fsStayOnTop
И, наконец, исходный код для Form2:
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm2 = class(TForm)
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses Unit1;
{$R *.DFM}
procedure TForm2.FormCreate(Sender: TObject);
begin
Height := ComboBox1.Height - 1;
Width := ComboBox1.Width - 1;
end;
procedure TForm2.ComboBox1Change(Sender: TObject);
begin
Form1.SetFocus;
end;
procedure TForm2.FormResize(Sender: TObject);
begin
ComboBox1.Width := Width;
end;
end.
Файл проекта (.DPR) довольно простой:
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
Application.Run;
end.
Это все!
Хотя некоторые авторы книг утверждают:
"Вы не можете установить компоненты Delphi в заголовок окна, точнее, не существует никакого способа установить их там."
Зато существует иллюзия...
Взято с
Помогите спрятать программу из списка задач?
Помогите спрятать программу из списка задач?
Или Как заказать сервисный процесс ?
unit Stealth;
interface
uses
WinTypes, WinProcs, Classes, Forms, SysUtils, Controls, Messages;
type
TStealth = class(TComponent)
private
fHideApp: Boolean;
procedure SetHideApp(Value: Boolean);
protected
{ Protected declarations }
procedure HideApplication;
procedure ShowApplication;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// procedure Loaded; override;
published
{ Published declarations }
property HideApp: Boolean read fHideApp write SetHideApp default false;
end;
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';
procedure Register;
implementation
destructor TStealth.Destroy;
begin
ShowApplication;
inherited destroy;
end;
constructor TStealth.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// fHideform := true;
end;
procedure TStealth.SetHideApp(Value: Boolean);
begin
fHideApp := Value;
if Value then HideApplication else ShowApplication;
end;
procedure TStealth.HideApplication;
begin
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 1);
end;
procedure TStealth.ShowApplication;
begin
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 0);
end;
procedure Register;
begin
RegisterComponents('My', [TStealth]);
end;
end.
Автор ответа: Admin
Взято с Vingrad.ru
Понимание многопоточности в VCL для веб-серверных ISAPI-расширений
Понимание многопоточности в VCL для веб-серверных ISAPI-расширений
Автор: Andrew Kachanov (www.arisesoft.com)
В среде Delphi можно создавать высокоэффективные веб-серверные ISAPI-расширения на основе технологии WebBroker. Создайте проект с помощью мастера (New -> Web Server Application - ISAPI DLL). Прилагаемая справочная документация, а так же демонстрационный пример "$(DELPHI)\Demos\Webserv" позволяют достаточно быстро освоиться в приемах написания веб-серверных ISAPI-расширений. На выходе у вас получится обычная DLL (далее по тексту - библиотека).
Сложность заключается в том, что веб-сервер (для ускорения обработки поступающих запросов) вызывает нашу библиотеку в много-поточном режиме. В результате чего на разработчика ложиться ответственность за написание поточно-безопасного кода. Не беспокойтесь, ребята из Borland постарались упростить вам жизнь настолько, насколько это возможно. Когда я понял смысл "обертки" TWebApplication и наследника TISAPIApplication, то был восхищен, и вдохновлен поделиться этими знаниями с вами!
Согласно спецификации ISAPI-расширений, созданная библиотека имеет всего три экспортируемые функции: GetExtensionVersion, HttpExtensionProc, TerminateExtension. Нас интересует только HttpExtensionProc, через которую выполняется вся работа: получение запросов с веб-сервера (Request), обработка и обратная отправка результата (Response).
Итак, рассмотрим весь путь прохождения данных. Запрос веб-сервера поступает через экспортируемую библиотекой функцию HttpExtensionProc в TISAPIApplication через инкапсулированный метод с одноименным названием (объект Application, как и в любом VCL-приложении другого вида, присутствует всегда: создается при инициализации и разрушается при завершении приложения, однако в данном случае имеет тип TISAPIApplication):
function TISAPIApplication.HttpExtensionProc(var ECB: TEXTENSION_CONTROL_BLOCK): DWORD;
var
HTTPRequest: TISAPIRequest;
HTTPResponse: TISAPIResponse;
{ ^ локально объявленные переменные запроса и ответа }
begin
try
HTTPRequest := NewRequest(ECB);
{ ^ инициализация переменной запроса по структуре ECB, полученной от веб-сервера }
try
HTTPResponse := NewResponse(HTTPRequest);
{ ^ инициализация переменной ответа }
try
if HandleRequest(HTTPRequest, HTTPResponse) then
{ ^ обработка переходит к TWebApplication.HandleRequest }
Result := HSE_STATUS_SUCCESS
else Result := HSE_STATUS_ERROR;
finally
HTTPResponse.Free;
end;
finally
HTTPRequest.Free;
end;
except
HandleServerException(Exception(ExceptObject), ECB);
Result := HSE_STATUS_ERROR;
end;
end;
Из приведенного кода видно, что переменные HTTPRequest и HTTPResponse объявлены локально, и объекты соответствующих типов создаются для каждого поступающего запроса веб-сервера. После инициализации этих переменных обработка переходит к TWebApplication.HandleRequest:
function TWebApplication.HandleRequest(Request: TWebRequest;
Response: TWebResponse): Boolean;
var
DataModule: TDataModule;
Dispatcher: TCustomWebDispatcher;
I: Integer;
begin
Result := False;
DataModule := ActivateWebModule;
{ ^ назначает объект, который не используется другими потоками }
if DataModule <> nil then
try
if DataModule is TCustomWebDispatcher then
Dispatcher := TCustomWebDispatcher(DataModule)
else with DataModule do
begin
Dispatcher := nil;
for I := 0 to ComponentCount - 1 do
begin
if Components[I] is TCustomWebDispatcher then
begin
Dispatcher := TCustomWebDispatcher(Components[I]);
Break;
end;
end;
end;
if Dispatcher <> nil then
begin
Result := TWebDispatcherAccess(Dispatcher).DispatchAction(Request, Response);
{ ^ обработка переходит к TWebDispatcher.DispatchAction }
if Result and not Response.Sent then
Response.SendResponse;
{ ^ отправка ответа веб-серверу }
end else raise Exception.CreateRes(@sNoDispatcherComponent);
finally
DeactivateWebModule(DataModule);
{ ^ переводит в список неиспользуемых объектов - FInactiveWebModules }
end;
end;
Тут следующая хитрость: локально объявленная переменная DataModule получает ссылку на объект от метода TWebApplication.ActivateWebModule. Для каждого потока предоставляется неиспользуемый в настоящее время другими потоками объект типа TDataModule, для чего выполняется перемещение этих объектов между списками FInactiveWebModules и FActiveWebModules. Если список FInactiveWebModules исчерпан, то создается новый экземпляр объекта типа TDataModule. В результате этих манипуляций для каждого потока используется собственный экземпляр объекта типа TDataModule, и разработчик может быть уверен в поточно-безопасном объявлении полей данных своего объекта TWebModule! Но это еще не все.
Локально объявленные в TISAPIApplication.HttpExtensionProc переменные HTTPRequest и HTTPResponse, о которых говорилось выше, переданы методу TWebApplication.HandleRequest в качестве параметров Request и Response, который в свою очередь передает их методу TCustomWebDispatcher.DispatchAction:
function TCustomWebDispatcher.DispatchAction(Request: TWebRequest;
Response: TWebResponse): Boolean;
var
I: Integer;
Action, Default: TWebActionItem;
Dispatch: IWebDispatch;
begin
FRequest := Request;
FResponse := Response;
{...}
end;
Тут выполняется присваивание переменных Request и Response полям объекта TWebModule (как наследнику TCustomWebDispatcher). А нам уже известно, что экземпляр объекта TWebModule у каждого потока - собственный. Теперь посмотрим правде в глаза: у каждого запроса веб-сервера есть собственные экземпляры объектов TRequest и TResponse в полях TWebModule.Request и TWebModule.Response; и они поточно-безопасны.
Далее путь лежит через метод TWebActionItem.DispatchAction, который вызывается в TCustomWebDispatcher.DispatchAction. Тут может вступать в действие ваш код обработки запроса, после чего подготовленному ответу предстоит обратная дорога.
Как видно из приведенного выше фрагмента кода TWebApplication.HandleRequest - DataModule передается в качестве параметра методу TWebApplication.DeactivateWebModule, в котором может быть переведен в список FInactiveWebModules, или вовсе разрушен (если выключено свойство CacheConnections - этим не стоит пользоваться без необходимости, так как существенно снижается производительность обработки запросов). После чего обработка возвращается к TISAPIApplication.HttpExtensionProc и ответ передается веб-серверу вызовом Response.SendResponse.
Отдельно следует отметить. Мне несколько раз попадались на глаза рекомендации устанавливать глобальную переменную IsMultiThread к True в dpr-файл проекта - этого делать не нужно, т.к. в конструкторе TWebApplication эта работа уже выполняется!
Если вы используете доступ к BDE посредством наследников TBDEDataSet (TTable, TQuery, TStoredProc) то все что вам нужно сделать для обеспечения поточно-безопасности, это присвоить в конструкторе TWebModule: Session.AutoSessionName := True (подробнее смотри в справочной документации: "Managing multiple sessions").
Реализация инкапсуляции WinSock в компонентах TClientSocket и TServerSocket, которые вам могут потребоваться, так же поточно-безопасна.
Конечно, если используется файловый ввод-вывод, а так же прямые вызовы WinSock, то тогда все же нужно выполнять много-поточную защиту самостоятельно и вам все же придется прочитать раздел документации "Programming with Delphi - Using threads". :-)
Замечание: изложенное выше относится к Delphi 5.
Взято с Исходников.ru
Понятие интерфейса
Понятие интерфейса
Тут наконец проявляется одно из ключевых понятий COM - интерфейс(interface).
Наша запись ICalc - это он и есть. То есть интерфейс - это таблица содержашаяя указатели на функции. Когда вы работаете с COM объектом, несмотря на то, что это выглядит так, как будто вы работаете с самим объектом, вы работаете с его интерфейсами. Реализация здесь может быть разная, это может быть указатели на внешнии функции, как это сделанно у нас (так практическм никто не делает), но чаще всего это указатели на методы класса. Пользователя это не волнует - он получает интерфейс и с ним работает, а уж ваша задача потрудиться над тем, чтобы работа с вашим интерфейсом проходила корректно.
Мы можем создать несколько интерфейсов. Допустим, добавим в наш класс две функции:
procedure MyCalc.Mult; //умножение
begin
result:=fx*fy;
end;
procedure MyCalc.Divide; //деление
begin
result:=fx div fy;
end;
ну и придется добавить еще две внешнии функции:
procedure Mult;
begin
Calc.Mult
end;
procedure Divide;
begin
Calc.Divide;
end;
и переделаем GetInterface;
procedure GetInterface(IID:integer; var Calc:ICalc); //IID - Interface ID(индефикатор интерфейса)
begin
CreateObject;
if IID=1 then
begin
Calc.Sum:=Sum;
Calc.Diff:=Diff;
end
else
If IID=2 then
begin
Calc.Sum:=Mult;
Calc.Diff:=Divide;
end;
Calc.SetOpers:=SetOperands;
Calc.Release:=ReleaseObject;
end;
Теперь пользователь может ввести какой он хочет интерфейс сложение/вычитание или умножение/деление и получить соответсвующую таблицу методов.
Слышу, слышу. Читатели уже начинают замечать сколько несуразностей в нашем коде. Давайте попробуем приводести его в нормальный вид.
Во первых, неплохо бы избавиться от внешних функций. Сейчас нам приходилось на каждый метод нашего класса добавлять еще одну внешнюю функцию, чтобы этот метод вызывать. Почему мы не можем передпть указатели на методы класса? Дело в том, что указатель на методы класса должен содержать в себе также и указатель на экземпляр класса, чтобы метод мог обращаться к членам этого класса. В Делфи можно задать указатель на функцию класса:
MethodPointer:procedure of object;
Такое обявление увеличивает размер указателя с 4 до 8 байт, что позволяет хранить в нем указатель на экземпляр класса. В принципе, возможно этим воспользоваться и описать процедуры нашего интерфейса как объектные, но это не будет шаг в сторону COM. Так как COM должен обеспечивать единый стандарт в нем используются указатели стандартного размера 4 байта. Как же нам все-таки избавиться от неудобных внешних функций? В разных средах разработки это может быть реализованно по разному, но раз уж мы начали с Delhpi, рассмотрим как это реализованно в нем.
В Delphi вводиться ключевое слово - interface. Объявление инерфейса - это и есть объявление таблицы методов. Выглядит это так
IMyInterface=interface
[{GUID}]
<метод1>
<метод2>
...
end;
GUID - необязательное поле индефицируеющая интерфейс. Тут надо сказать, что GUID(он же UUID, CLSID) - это 128-битное число, алгоритм генерации которого гарантирует его уникальность во вселенной. В Windows его можно получить функцией CoCreateGuid или UuidCreate. В Делфи это очень удобно встроенно в среду, и вы его можете получить нажав Ctrl+Shift+G.
В нашем простом случае это будет выглядить так:
ICalc=interface
['{149D0FC0-43FE-11D6-A1F0-444553540000}']
procedure SetOperands(x,y:integer);
function Sum:integer;
function Diff:integer;
procedure Release;
end;
Объявленный таким образом интерфейс можно прицепить к классу. Причем заметье, что методы интерфейса имплементируются только в классе, к которому они прицеплены. То есть вот так вы написать не можете:
function ICalc.Sum:integer;
begin
Result:=0;
end;
Как и было сказанно, объявление интерфейса это всего лишь объявление таблицы методов. А имплементируется это так:
MyCalc=class(TObject,ICalc) //интерфейс указывается в списке наследования!
fx,fy:integer;
public
procedure SetOperands(x,y:integer);
function Sum:integer;
function Diff:integer;
procedure Release;
end;
Все методы класса у нас уже имплементированны, кроме Release. Ну с ним все понятно:
procedure MyCalc.Release;
begin
Free;
end;
По умолчанию, методы привязываются по именам. То есть если в ICalc указан метод Sum, то компилятор будет искать метод Sum в классе MyCalc. Однако вы можете указать явно другие имена. Например:
MyCalc=class(TObject,ICalc)
fx,fy:integer;
public
function ICalc.Diff = Difference; //задаем нужнок имя (Difference)
procedure SetOperands(x,y:integer);
function Sum:integer;
function Difference:integer; //другое имя
procedure Release;
end;
В нашем случае, удобно промаппить метод Release к методу Free, это избавит нас от необходимости имплементировать Release в нашем классе.
MyCalc=class(TObject,ICalc)
fx,fy:integer;
public
function ICalc.Release = Free;
procedure SetOperands(x,y:integer);
function Sum:integer;
function Diff:integer;
end;
Что же происходит при добовлении к классу интерфейса? Здесь для каждого экземпляра нашего класса создается специальная таблица(interface table), в которой храняться все записи о поддерживаемых интерфейсах. Каждая такая запись содержит адрес соответствующего интерфейса, который в свою очередь, как уже было сказанно является таблицей методов. То есть если мы получим адрес, допустим, нашего ICalc, то вызывая функцию по этому же адресу, мы вызовем метод SetOperands класса MyCalc. Ecли вы вызовете вызовете функцию по адресу <адрес ICalc>+4 то вызовется метод Sum. Еще +4 байта будет метод Diff. То есть как вы видете, здесь указатели на функции имеют размер 4 байта, и адрес нужной функции получают прибавлением нужного смещения к адресу интерфейса.
Получить же адрес нужного интерфейса можно с помощью метода GetInterface класса TObject.
Забудем пока, что мы делали два интерфейса, и вернмся к варианту с одним интерфейсом. Перепишим наш GetInterface.
procedure GetInterface(var ACalc:ICalc);
begin
CreateObject;
Calc.GetInterface(ICalc,ACalc);
end;
Мы воспользовались методом GetInterface, который вышлядит так:
function TObject.GetInterface(const IID: TGUID; out Obj): Boolean;
этот возвращает в параметре Obj указатель на интерфейс, по указанному индификатору GUID. Допускается вместо переменной типа TGIUD поставить имя интерфейса - компилятор сам подставит его GUID если он ему известен.
Все. Выбрасывайте все внешнии функции, кроме GetInterface. Теперь нам придется сказать спасибо Borland'у и сделать несколько дополнительных действий. Дело в том, что по стандарту COM каждый COM объект должен имплементировать интерфейс IUnknown. Он содержит три метода и выглядит так:
IUnknown = interface
['{00000000-0000-0000-C000-000000000046}']
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;
Хочу еще раз отметить, что эти примеры пишутся для Делфи, однако суть от этого не меняется. Как бы не выглядил интерфейс в других средах разработки, он всегда остается таблицой с адресами функций. И если говорить о IUnkown, то он всегда должен содержать эти же методы, в этом же порядке. В С++ он например выглядит так:
struct IUnknown
{
HRESULT QueryInterface(REFIID iid, void ** ppvObject);
ULONG AddRef(void);
ULONG Release(void);
}
Так вот, в Delhpi все интерфейсы наследуются от IUnknown. Так что и наш интерфейс тоже содержит эти методы, а значит и компилятор потребует от вас их имплементации. Ну что ж. Добавтье пока пустые методы QueryInterface, _AddRef и _Release, позже мы их имплементируем правильно.
Теперь не забудтье поменять тип ICalc на интерфейс в тестере, и убедитесь, что все работает. :)
Продолжение следует...
Понятие о запросе (Query)
Понятие о запросе (Query)
Итак, это пожалуй почти всё, что мы можем "выжать" из компонента TTable. Почуствовали мощь и удобство работы с базами данных? - Ой, вряд ли! Скорее всего ощущение заумности, убогости и неудобства в сочетании с крайней медлительностью операций... Действительно доступ к базе данных через TTable является самым прямым и самым неудобным, какие же основные недостатки? Наверное уже многие задались вопросами:
1) А если мне надо 1000 записей изменить, так мне надо в цикле крутить приведенный код? Так это ж как долго!
2) Ну хорошо, у меня есть табличка на сотню тысяч записей, и мне нужно из неё выбрать только, например, 1000 записей касательно "Иванова", так мне прийдётся всю таблицу в цикле крутить пока не найду то что мне нужно?
Все эти проблемы решены, и решены великолепно - просто, очень эффективно и с минимальными затратами.
Рассмотрим в кратце общий алгоритм доступа к информации который был рассмотрен:
1.1) Передать данные из таблицы в программу
1.2) Программа сама занимается поиском данных
А что если изменить схему:
2.1) Отдать команду драйверу на поиск нужной информации
3.2) Драйвер найдёт инфу
2.3) Найденная информация будет возвращена программе.
На первый взгляд разница только в том что работу, которую делает программный код в первом случае, мы пробуем свалить на драйвера базы данных. Ну и зачем? Оказывается есть зачем! В первой схеме - есть несколько моментов на которые я бы хотел обратить внимание:
1) В любом случае манипулирование базой производится драйвером, следовательно код драйвера в любом случае работает. Драйвер написан под конкретную базу данных, и "знает" каким образом манипулировать с базой самым быстрым способом, а програмный код неизбежно подвергается "транслированию", многочисленным преобразованиям данных для обеспечения совместимости.
2) А если база данных находится на другом компьютере? Тогда программа вынуждена "вытащить" все данные на локальный компьютер перед манипулированием данными, что есть совсем не быстрая операция. Кстати пока мы тащим гигабайтную таблицу к себе, ваш сосед Вася уже успел там что-то поменять, и что теперь? Тащим заново, или посылаем Васю подальше, и не даём ему работать с базой пока сами не закончим?
А во втором способе всё будет куда лучше! Программа попросит данные и получет только те данные которые запрошены, а не всю таблицу, никаких трансляций данных - мы транслируем только те данные, которые уже отобраны, а не всё подряд, всю работу мы переложили на плечи драйвера, который был написан очень оптимально, который точно знает как работать именно с этой версией базы данных, а не со всеми подряд. А Вася нас тоже пока не интересует, драйвер сам разберётся как с ним поступать - нас это не касается (пока по крайней мере).
И как же это реализовано? Это реализовано с помощью языка запросов: SQL. Подробнее этот язык рассмотивается в разделе Базы данных, мы же не заостряя внимание на самих запросах, рассмотрим простейшие случаи как этот язык можно применить внутри программы на Дельфи и какие выгоды можем мы получить используя запросы.
Итак, из нашего тестового проекта удаляем компонент Table1. Вместо него ставим компонент TQuery. Устанавливаем Alias (DatabaseName) и связываем его с DataSource таким же образом как и таблицу.
Пока вы найдёте 2 радикальных отличия от TTable:
1) Нет свойства TableName
2) Открытие (Active:=true) квери приводит к ошибке
Query должна содержать запрос. Для этого есть свойство SQL, являющееся самым обыкновенным TStringList. Откроем это свойство и напишем примерно следующее:
Select * from biolife
Теперь можно попытаться открыть квери (установить Active в True) и вы получите точно тоже что и в первом примере - грид заполненный данными из таблицы Biolife.db. Мало того, всё что мы проделывали с таблицей - позиционирование строки, чтение и запись полей и т.п. вы можете с успехом сделать и с Query - причём синтаксис тот же самый! Пока мы только сделали замену компоненту TTable и не более того.
Я здесь не буду подробно останавливаться на синтаксисе SQL запроса, материал по этой теме вы найдёте здесь:
Однако простейшие приёмы работы я покажу. В нескольких дальнейших примерах мы будем менять свойство "SQL". Перед каждым изменением этого свойства Вы должны закрывать квери (в дизайне устанавливать Active в False). В run-time изменения SQL должны выглядеть примерно так:
Query1.active:=false;
Query1.sql.text:='Select * from biolife';
Query1.active:=true;
Понятия Instance, Database etc
Понятия Instance, Database etc
Автор: Nomadic
Перевод документации:
Что такое ORACLE Database?
Это данные которые будут обрабатываться как единое целое. Database состоит из файлов операционной системы. Физически существуют database files и redo log files. Логически database files содержат словари, таблицы пользователей и redo log файлы. Дополнительно database требует одну или более копий control file.
Что такое ORACLE Instance?
ORACLE Instance обеспечивает программные механизмы доступа и управления database. Instance может быть запущен независимо от любой database (без монтирования или открытия любой database). Один instance может открыть только одну database. В то время как одна database может быть открыта несколькими Instance.
Instance состоит из:
SGA (System Global Area), которая обеспечивает коммуникацию между процессами;
до пяти (в последних версиях больше) бэкграундовых процессов.
От себя добавлю - database включает в себя tablespace, tablespace включает в себя segments (в одном файле данных может быть один или несколько сегментов, сегменты не могут быть разделены на несколько файлов). segments включают в себя extents.
Взято из
Порты
Порты
Cодержание раздела:
См. также другие разделы:
См. также статьи в других разделах:
Посылаем нажатия клавиш другому приложению
Посылаем нажатия клавиш другому приложению
Автор: Gert v.d. Venis
Компонент Sendkeys:
unit SendKeys;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TSendKeys = class(TComponent)
private
fhandle:HWND;
L:Longint;
fchild: boolean;
fChildText: string;
procedure SetIsChildWindow(const Value: boolean);
procedure SetChildText(const Value: string);
procedure SetWindowHandle(const Value: HWND);
protected
public
published
Procedure GetWindowHandle(Text:String);
Procedure SendKeys(buffer:string);
Property WindowHandle:HWND read fhandle write SetWindowHandle;
Property IsChildWindow:boolean read fchild write SetIsChildWindow;
Property ChildWindowText:string read fChildText write SetChildText;
end;
procedure Register;
implementation
var temps:string;{й utilizado para ser acessivel pelas funcs q sao
utilizadas como callbacks}
HTemp:Hwnd;
ChildText:string;
ChildWindow:boolean;
procedure Register;
begin
RegisterComponents('Standard', [TSendKeys]);
end;
{ TSendKeys }
function PRVGetChildHandle(H:HWND; L: Integer): LongBool;
var p:pchar;
I:integer;
s:string;
begin
I:=length(ChildText)+2;
GetMem(p,i+1);
SendMessage(H,WM_GetText,i,integer(p));
s:=strpcopy(p,s);
if pos(ChildText,s)<>0 then
begin
HTemp:=H;
Result:=False
end else
Result:=True;
FreeMem(p);
end;
function PRVSendKeys(H: HWND; L: Integer): LongBool;stdcall;
var s:string;
i:integer;
begin
i:=length(temps);
if i<>0 then
begin
SetLength(s,i+2);
GetWindowText(H, pchar(s),i+2);
if Pos(temps,string(s))<>0 then
begin
Result:=false;
if ChildWindow then
EnumChildWindows(H,@PRVGetChildHandle,L)
else
HTemp:=H;
end
else
Result:=True;
end else
Result:=False;
end;
procedure TSendKeys.GetWindowHandle(Text: String);
begin
temps:=Text;
ChildText:=fChildText;
ChildWindow:=fChild;
EnumWindows(@PRVSendKeys,L);
fHandle:=HTemp;
end;
procedure TSendKeys.SendKeys(buffer: string);
var i:integer;
w:word;
D:DWORD;
P:^DWORD;
begin
P:=@D;
SystemParametersInfo( //get flashing timeout on win98
SPI_GETFOREGROUNDLOCKTIMEOUT,
0,
P,
0);
SetForeGroundWindow(fHandle);
for i:=1 to length(buffer) do
begin
w:=VkKeyScan(buffer[i]);
keybd_event(w,0,0,0);
keybd_event(w,0,KEYEVENTF_KEYUP,0);
end;
SystemParametersInfo( //set flashing TimeOut=0
SPI_SETFOREGROUNDLOCKTIMEOUT,
0,
nil,
0);
SetForegroundWindow(TWinControl(TComponent(Self).Owner).Handle);
//->typecast working...
SystemParametersInfo( //set flashing TimeOut=previous value
SPI_SETFOREGROUNDLOCKTIMEOUT,
D,
nil,
0);
end;
procedure TSendKeys.SetChildText(const Value: string);
begin
fChildText := Value;
end;
procedure TSendKeys.SetIsChildWindow(const Value: boolean);
begin
fchild := Value;
end;
procedure TSendKeys.SetWindowHandle(const Value:HWND);
begin
fHandle:=WindowHandle;
end;
end.
Описание:
Данный компонент получает хэндл(handle) любого запущенного окна и даёт возможность отправить по указанному хэндлу любые комбинации нажатия клавиш.
Совместимость: Все версии Delphi
Собственно сам исходничек:
После того, как проинсталируете этот компонент, создайте новое приложение и поместите на форму кнопку и сам компонент SendKeys. Добавьте следующий код в обработчик события OnClick кнопки:
procedure TForm1.Button1Click(Sender: TObject);
begin
// Запускаем Notepad, и ему мы будем посылать нажатия клавиш
WinExec('NotePad.exe', SW_SHOW);
// В параметре процедуры GetWindowHandle помещаем
// текст заголовка окна Notepad'а.
SendKeys1.GetWindowHandle('Untitled - Notepad');
// Если хэндл окна получен успешно, то отправляем ему текст
if SendKeys1.WindowHandle <> 0 then
SendKeys1.SendKeys('This is a test');
// Так же можно отправить код любой кнопки типа
// RETURN, используя следующий код:
// SendKeys1.SendKeys(Chr(13));
end;
---------------------------------
Неправда ли весело :)
Взято с Исходников.ru
Посылать и считывать данные с COM порта, а также менять параметры (биты данных, четность)
Посылать и считывать данные с COM порта, а также менять параметры (биты данных, четность)
Ниже представлен класс для работы с COM-портом. Протестирован в Windows 95. Класс выдернут из контекста, так что не ручаюсь в компиляции с первого раза, однако все функции работы с COM очевидны.
unitUnit1;
interface
uses
Windows;
type
TComPort = class
private
hFile: THandle;
public
constructor Create;
destructor Destroy; override;
function InitCom(BaudRate, PortNo: Integer; Parity: Char;
CommTimeOuts: TCommTimeouts): Boolean;
procedure CloseCom;
function ReceiveCom(var Buffer; Size: DWORD): Integer;
function SendCom(var Buffer; Size: DWORD): Integer;
function ClearInputCom: Boolean;
end;
implementation
uses
SysUtils;
constructor TComPort.Create;
begin
inherited;
CloseCom;
end;
destructor TComPort.Destroy;
begin
CloseCom;
inherited;
end;
function TComPort.InitCom(BaudRate, PortNo: Integer; Parity: Char;
CommTimeOuts: TCommTimeouts): Boolean;
var
FileName: string;
DCB: TDCB;
PortParam: string;
begin
result := FALSE;
FileName := 'Com' + IntToStr(PortNo); {имя файла}
hFile := CreateFile(PChar(FileName),
GENERIC_READ or GENERIC_WRITE, 0, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hFile = INVALID_HANDLE_VALUE then
exit;
//установка требуемых параметров
GetCommState(hFile, DCB); //чтение текущих параметров порта
PortParam := 'baud=' + IntToStr(BaudRate) + ' parity=' + Parity +
' data=8 stop=1 ' +
'octs=off';
if BuildCommDCB(PChar(PortParam), DCB) then
begin
result := SetCommState(hFile, DCB) and
SetCommTimeouts(hFile, CommTimeOuts);
end;
if not result then
CloseCom;
end;
procedure TComPort.CloseCom;
begin
if hFile < > INVALID_HANDLE_VALUE then
CloseHandle(hFile);
hFile := INVALID_HANDLE_VALUE;
end;
function TComPort.ReceiveCom(var Buffer; Size: DWORD): Integer;
var
Received: DWORD;
begin
if hFile = INVALID_HANDLE_VALUE then
raise Exception.Create('Не открыта запись в Com порт');
if ReadFile(hFile, Buffer, Size, Received, nil) then
begin
Result := Received;
end
else
raise Exception.Create('Ошибка приема данных: ' + IntToStr(GetLastError));
end;
function TComPort.SendCom(var Buffer; Size: DWORD): Integer;
var
Sended: DWORD;
begin
if hFile = INVALID_HANDLE_VALUE then
raise Exception.Create('Не открыта запись в Com порт');
if WriteFile(hFile, Buffer, Size, Sended, nil) then
begin
Result := Sended;
end
else
raise Exception.Create('Ошибка передачи данных: ' + IntToStr(GetLastError));
end;
function TComPort.ClearInputCom: Boolean;
begin
if hFile = INVALID_HANDLE_VALUE then
raise Exception.Create('Не открыта запись в Com порт');
Result := PurgeComm(hFile, PURGE_RXCLEAR);
end;
end.
Взято с
Посылка Raw IP-пакетов
Посылка Raw IP-пакетов
Автор:
Erwin MolendijkИспользуя данный исходник можно конструировать собственные пакеты содержащие внутри всё, что угодно. Можно самостоятельно указывать в пакете IP-адрес получателя и отправителя, порт назначения и т.д. Если Вы не знаете, что это такое, то лучше не эксперементировать. Единственный недостаток, то, что скорее всего данный пример будет работать только в Windows 2000. Так же исходник позволяет произвести SYN flood и IP spoofing.
Необходимо зайти в систему под Администратором.
Совместимость: Delphi 5.x (или выше)
{
Raw Packet Sender
using: Delphi + Winsock 2
Copyright (c) 2000 by E.J.Molendijk (xes@dds.nl)
----------------------------------------------------------------------
Перед использованием измените значения SrcIP+SrcPort+
DestIP+DestPort на нужные!
----------------------------------------------------------------------
}
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, OleCtrls, Registry;
Const
SrcIP = '123.123.123.1';
SrcPort = 1234;
DestIP = '123.123.123.2';
DestPort = 4321;
Max_Message = 4068;
Max_Packet = 4096;
type
TPacketBuffer = Array[0..Max_Packet-1] of byte;
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure SendIt;
end;
// Заголовок IP пакета
type
T_IP_Header = record
ip_verlen : Byte;
ip_tos : Byte;
ip_totallength : Word;
ip_id : Word;
ip_offset : Word;
ip_ttl : Byte;
ip_protocol : Byte;
ip_checksum : Word;
ip_srcaddr : LongWord;
ip_destaddr : LongWord;
end;
// Заголовок UDP пакета
Type
T_UDP_Header = record
src_portno : Word;
dst_portno : Word;
udp_length : Word;
udp_checksum : Word;
end;
// Некоторые объявления типов для Winsock 2
u_char = Char;
u_short = Word;
u_int = Integer;
u_long = Longint;
SunB = packed record
s_b1, s_b2, s_b3, s_b4: u_char;
end;
SunW = packed record
s_w1, s_w2: u_short;
end;
in_addr = record
case integer of
0: (S_un_b: SunB);
1: (S_un_w: SunW);
2: (S_addr: u_long);
end;
TInAddr = in_addr;
Sockaddr_in = record
case Integer of
0: (sin_family: u_short;
sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
1: (sa_family: u_short;
sa_data: array[0..13] of Char)
end;
TSockAddr = Sockaddr_in;
TSocket = u_int;
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
WSAData = record // !!! also WSDATA
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
TWSAData = WSAData;
// Определяем необходимые функции winsock 2
function closesocket(s: TSocket): Integer; stdcall;
function socket(af, Struct, protocol: Integer): TSocket; stdcall;
function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;
tolen: Integer): Integer; stdcall;{}
function setsockopt(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer; stdcall;
function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr }
function htons(hostshort: u_short): u_short; stdcall;
function WSAGetLastError: Integer; stdcall;
function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;
function WSACleanup: Integer; stdcall;
const
AF_INET = 2; // internetwork: UDP, TCP, etc.
IP_HDRINCL = 2; // включаем заголовок IP пакета
SOCK_RAW = 3; // интерфейс raw-протокола
IPPROTO_IP = 0; // dummy for IP
IPPROTO_TCP = 6; // tcp
IPPROTO_UDP = 17; // user datagram protocol
IPPROTO_RAW = 255; // raw IP пакет
INVALID_SOCKET = TSocket(NOT(0));
SOCKET_ERROR = -1;
var
Form1: TForm1;
implementation
// Импортируем функции Winsock 2
const WinSocket = 'WS2_32.DLL';
function closesocket; external winsocket name 'closesocket';
function socket; external winsocket name 'socket';
function sendto; external winsocket name 'sendto';
function setsockopt; external winsocket name 'setsockopt';
function inet_addr; external winsocket name 'inet_addr';
function htons; external winsocket name 'htons';
function WSAGetLastError; external winsocket name 'WSAGetLastError';
function WSAStartup; external winsocket name 'WSAStartup';
function WSACleanup; external winsocket name 'WSACleanup';
{$R *.DFM}
//
// Function: checksum
//
// Description:
// This function calculates the 16-bit one's complement sum
// for the supplied buffer
//
function CheckSum(Var Buffer; Size : integer) : Word;
type
TWordArray = Array[0..1] of Word;
var
ChkSum : LongWord;
i : Integer;
begin
ChkSum := 0;
i := 0;
While Size > 1 do begin
ChkSum := ChkSum + TWordArray(Buffer)[i];
inc(i);
Size := Size - SizeOf(Word);
end;
if Size=1 then ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]);
ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF);
ChkSum := ChkSum + (Chksum shr 16);
Result := Word(ChkSum);
end;
procedure BuildHeaders(
FromIP : String;
iFromPort : Word;
ToIP : String;
iToPort : Word;
StrMessage : String;
Var Buf : TPacketBuffer;
Var remote : TSockAddr;
Var iTotalSize : Word
);
Var
dwFromIP : LongWord;
dwToIP : LongWord;
iIPVersion : Word;
iIPSize : Word;
ipHdr : T_IP_Header;
udpHdr : T_UDP_Header;
iUdpSize : Word;
iUdpChecksumSize : Word;
cksum : Word;
Ptr : ^Byte;
procedure IncPtr(Value : Integer);
begin
ptr := pointer(integer(ptr) + Value);
end;
begin
// преобразуем ip адреса
dwFromIP := inet_Addr(PChar(FromIP));
dwToIP := inet_Addr(PChar(ToIP));
// Инициализируем заголовок IP пакета
//
iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage);
iIPVersion := 4;
iIPSize := sizeof(ipHdr) div sizeof(LongWord);
//
// IP version goes in the high order 4 bits of ip_verlen. The
// IP header length (in 32-bit words) goes in the lower 4 bits.
//
ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize;
ipHdr.ip_tos := 0; // IP type of service
ipHdr.ip_totallength := htons(iTotalSize); // Total packet len
ipHdr.ip_id := 0; // Unique identifier: set to 0
ipHdr.ip_offset := 0; // Fragment offset field
ipHdr.ip_ttl := 128; // время жизни пакета
ipHdr.ip_protocol := $11; // Protocol(UDP)
ipHdr.ip_checksum := 0 ; // IP checksum
ipHdr.ip_srcaddr := dwFromIP; // Source address
ipHdr.ip_destaddr := dwToIP; // Destination address
//
// Инициализируем заголовок UDP пакета
//
iUdpSize := sizeof(udpHdr) + length(strMessage);
udpHdr.src_portno := htons(iFromPort) ;
udpHdr.dst_portno := htons(iToPort) ;
udpHdr.udp_length := htons(iUdpSize) ;
udpHdr.udp_checksum := 0 ;
//
// Build the UDP pseudo-header for calculating the UDP checksum.
// The pseudo-header consists of the 32-bit source IP address,
// the 32-bit destination IP address, a zero byte, the 8-bit
// IP protocol field, the 16-bit UDP length, and the UDP
// header itself along with its data (padded with a 0 if
// the data is odd length).
//
iUdpChecksumSize := 0;
ptr := @buf[0];
FillChar(Buf, SizeOf(Buf), 0);
Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr));
IncPtr(SizeOf(ipHdr.ip_srcaddr));
iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr);
Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr));
IncPtr(SizeOf(ipHdr.ip_destaddr));
iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr);
IncPtr(1);
Inc(iUdpChecksumSize);
Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol));
IncPtr(sizeof(ipHdr.ip_protocol));
iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol);
Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length));
IncPtr(sizeof(udpHdr.udp_length));
iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length);
move(udpHdr, ptr^, sizeof(udpHdr));
IncPtr(sizeof(udpHdr));
iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr);
Move(StrMessage[1], ptr^, Length(strMessage));
IncPtr(Length(StrMessage));
iUdpChecksumSize := iUdpChecksumSize + length(strMessage);
cksum := checksum(buf, iUdpChecksumSize);
udpHdr.udp_checksum := cksum;
//
// Now assemble the IP and UDP headers along with the data
// so we can send it
//
FillChar(Buf, SizeOf(Buf), 0);
Ptr := @Buf[0];
Move(ipHdr, ptr^, SizeOf(ipHdr)); IncPtr(SizeOf(ipHdr));
Move(udpHdr, ptr^, SizeOf(udpHdr)); IncPtr(SizeOf(udpHdr));
Move(StrMessage[1], ptr^, length(StrMessage));
// Apparently, this SOCKADDR_IN structure makes no difference.
// Whatever we put as the destination IP addr in the IP header
// is what goes. Specifying a different destination in remote
// will be ignored.
//
remote.sin_family := AF_INET;
remote.sin_port := htons(iToPort);
remote.sin_addr.s_addr := dwToIP;
end;
procedure TForm1.SendIt;
Var
sh : TSocket;
bOpt : Integer;
ret : Integer;
Buf : TPacketBuffer;
Remote : TSockAddr;
Local : TSockAddr;
iTotalSize : Word;
wsdata : TWSAdata;
begin
// Startup Winsock 2
ret := WSAStartup($0002, wsdata);
if ret<>0 then begin
memo1.lines.add('WSA Startup failed.');
exit;
end;
with memo1.lines do begin
add('WSA Startup:');
add('Desc.: '+wsData.szDescription);
add('Status: '+wsData.szSystemStatus);
end;
try
// Создаём сокет
sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP);
if (sh = INVALID_SOCKET) then begin
memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError));
exit;
end;
Memo1.lines.add('Socket Handle = '+IntToStr(sh));
// Option: Header Include
bOpt := 1;
ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt));
if ret = SOCKET_ERROR then begin
Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError));
exit;
end;
// строим пакет
BuildHeaders( SrcIP, SrcPort,
DestIP, DestPort,
'THIS IS A TEST PACKET',
Buf, Remote, iTotalSize );
// Отправляем пакет
ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote));
if ret = SOCKET_ERROR then
Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError))
else
Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.');
// Закрываем сокет
CloseSocket(sh);
finally
// Закрываем Winsock 2
WSACleanup;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendIt;
end;
end.
Взято с Исходников.ru
Потоки и DLL
Потоки и DLL
Автор: Charles Calvert
Потоки и DLL-ки
Приведенный ниже текст подразумевает, что вы обладаете базовыми знаниями о принципе работы потоков и умеете создавать DLL.
Техническая сторона вопроса будет сфокусирована на потоках и функции DllEntryPoint. Функция DllEntryPoint не должна объявляться в ваших Delphi DLL. Фактически, большую часть, если не всю, Delphi DLL будет правильно работать и без вашего явного объявления DllEntryPoint. Тем не менее, я включил данный совет для тех Win32-программистов, которые понимают эту функцию и хотят связать с ней свое функциональное назначение, чтобы оно являлось частью DLL. Чтобы быть более конкрентым, это будет интересно тем программистам, которые хотят вызывать одну и ту же DLL из многочисленных потоков одной программы.
Исходный код данного проекта находится на FTP компании Borland.
Данный код также доступен на Compuserve в секции Borland в виде файла BI42.ZIP.
При первом вызове DLL сначала выполняется секция инициализации, расположенная в нижней части кода. При загрузке двух модулей, каждый из которых использует DLL, секция инициализации будет вызвана дважды, для каждого модуля. Вот пример минимального кода Delphi DLL, который компилится, но пока ничего не делает:
libraryMyDll;
// Здесь код
// экспорта
begin
// Расположенный здесь код выполняется в первую
// очередь при каждом вызове DLL любым exe-файлом.
end.
Как вы можете здесь увидеть, здесь нет традиционного DLLEntryPoint, имеющегося в стандартных C/C++ DLL. Для тех, кто только начал изучать Win32, я сообщу, что DLLEntryPoint берет начало от функций LibMain и WEP, работающих в Windows 3.1. LibMain и WEP теперь считаются устаревшими, вместо них необходимо использовать DLLEntryPoint.
Для явной установки DLLEntryPoint в Delphi, используйте следующий код-скелет, имеющий преимущество перед переменной DLLProc, объявленной глобально в SYSTEM.PAS:
library DllEntry;
procedure DLLEntryPoint(Reason: DWORD);
begin
// Здесь организуется блок Case для Dll_Process_Attach, и др.
end;
// Здесь реализация экспортируемых функций
// экспорт
begin
if DllProc = nil then begin
DllProc := @DLLEntryPoint;
DllEntryPoint(Dll_Process_Attach);
end;
end.
Данный код назначает объявленный пользователей метод с именем DLLEntryPoint объявленной глобально переменной Delphi с именем DllProc, в свою очередь объявленой в SYSTEM.PAS следующим образом:
var
DllProc: Pointer; { Вызывается каждый раз при вызове точки входа DLL }
Вы можете имитировать стандартную функциональность DLLEntryPoint, вызывая объявленный к тому времени локально DLLEntryPoint, и передавая ему Dll_Process_Attach в качестве переменной. В C/C++ DLL эта переменная должна передаваться определенной пользователем функции с именем DllEntryPoint автоматически при первом доступе к DLL из первой обратившейся к ней программы. В Delphi первый вызов этой функции может быть произведен вручную пользователем, но последующие вызовы происходят автоматически до тех пор, пока вы не назначите первый раз функцию переменной DllProc. Другими словами, вы можете форсировать первый вызов DllEntryPoint как показано выше, но последующие вызовы будут сделаны системой автоматически.
Dll_Process_Attach - одна из четырех возможных констант, которые система можете передавать функции DllEntryPoint. Эти константы объявлены в WINDOWS.PAS следующим образом:
DLL_PROCESS_ATTACH = 1; // Программа подключается к DLL
DLL_THREAD_ATTACH = 2; // Поток программы подключается к DLL
DLL_THREAD_DETACH = 3; // Поток "оставляет" DLL
DLL_PROCESS_DETACH = 0; // Exe "отсоединяется" от DLL
Более детальная скелетная конструкция DllEntryPoint с использованием приведенных констант:
procedure DLLEntryPoint(Reason: DWORD);
begin
case Reason of
Dll_Process_Attach:
MessageBox(DLLHandle, 'Подключение процесса', 'Инфо', mb_Ok);
Dll_Thread_Attach:
MessageBox(DLLHandle, 'Подключение потока', 'Инфо', mb_Ok);
Dll_Thread_Detach:
MessageBox(DLLHandle, 'Отключение потока', 'Инфо', mb_Ok);
Dll_Process_Detach:
MessageBox(DLLHandle, 'Отключение процесса', 'Инфо', mb_Ok);
end; // case
end;
В приведенном примере я просто вызываю диалог MessageBox в ответ на возможные параметры, передаваемые DLLEntryPoint. Тем не менее, вы могли бы найти более достойное применение данным константам или вовсе игнорировать их.
Работа с потоками
Приведенный ниже небольшой фрагмент кода достоин занять место в программе, вызывающей DLL. Он показывает как можно объявить функцию, экспортируемую из DLL, и как вызвать эту функцию из потока. Конечно, обычно нет необходимости вызывать функцию DLL из потока, я делаю это просто для того, чтобы показать функциональное назначение, связанное с обсуждаемыми выше константами Dll_Thread_Attach и Dll_Thread_Detach.
function MyFunc: ShortString; external 'DLLENTRY1' name 'MyFunc';
procedure ThreadFunc(P: Pointer); stdcall;
var
S: array[0..255] of Char;
begin
StrPCopy(S, MyFunc);
MessageBox(Form1.Handle, S, 'Инфо', mb_Ok);
end;
procedure TForm1.UseThreadClick(Sender: TObject);
var
ThreadID: DWORD;
HThread: THandle;
begin
HThread := CreateThread(nil, 0, @ThreadFunc,
nil, 0, ThreadID);
if HThread = 0 then ShowMessage('Нет потоков');
end;
Приведенный здесь код делится на три секции. В первой декларируется MyFunc, являющаяся простой реализацией функции в DLL. ThreadFunc сама располагается в отдельном потоке, создаваемом программой. Процедура UseThreadClick создает поток. Сразу после создания потока система вызывет процедуру ThreadFunc.
Вот декларация CreateThread:
var
DWORD = Integer;
function CreateThread(
lpThreadAttributes: Pointer; // атрибуты безопасности потока
dwStackSize: DWORD; // размер стека для потока
lpStartAddress: TFNThreadStartRoutine; // функция потока
lpParameter: Pointer; // аргумент для нового потока
dwCreationFlags: DWORD; // флаги создания
var lpThreadId: DWORD): // Возвращаемый идентификатор потока
THandle; // Возвращаемый дескриптор потока
В нормальной ситуации большинство параметров, передаваемых CreateThread, могут быть установлены в 0 или nil. Показан типичный пример вызова данной функции, но во многих случаях использование lpParameter неоправданно тяжело. Разумеется, любые переменные, установленные в данном параметре, передаются ThreadFunc в виде единственного аргумента.
Фактически, реализация функции потока очень проста, происходит вызов DLL и показывается информационный диалог, демонстрирующий строку, возвращаемую DLL.
Если вы создали программу с потоковой функцией как было показано выше, и создали DLL с функцией DLLEntryPoint, тоже показанной выше, то можно получить визуальное подтверждение того, как работает функция DLLEntryPoint. Поясняю: когда ваша программа загружается в память, DLL также должна быть автоматически загружена, тем самым вызывая MessageBox с текстом `Процесс подключен'. Диалоги появляются в зависимости от причины (Reason) вызова функции DllEntryPoint:
procedure DLLEntryPoint(Reason: DWORD);
begin
case Reason of
Dll_Process_Attach:
MessageBox(DLLHandle, 'Процесс подключен', 'Инфо', mb_Ok);
Dll_Thread_Attach:
MessageBox(DLLHandle, 'Поток подключен', 'Инфо', mb_Ok);
Dll_Thread_Detach:
MessageBox(DLLHandle, 'Поток отключен', 'Инфо', mb_Ok);
Dll_Process_Detach:
MessageBox(DLLHandle, 'Процесс отключен', 'Инфо', mb_Ok);
end; // case
end;
Если вы создали процедуру ThreadFunc, показанную выше, то должно появиться диалоговое окно (MessageBox) с надписью "Поток подключен". При завершении работы подпрограммы ThreadFunc появится окошко с надписью "Поток отключен". Наконец, при закрытии программы должна появиться надпись "Процесс отключен". Пример, демонстрирующий процесс, доступен в сети.
Довольно сложно иллюстрировать технические возможности Delphi. Не все программисты Delphi захотят так глубоко вникать в дебри Windows API. Тем не менее, те, которые хотят воспользоваться мощью Windows 95 и Windows NT на полную катушку, могут видеть, что все современные технологии доступны всем без исключения программистам на Delphi. Приведенный выше пример доступен в Compuserve в виде файла DLLENT.ZIP и также размещен на Интернет-сервере Borland по адресу www.borland.com.
Взято с
Поведение TAB в компоненте RadioGroup
Поведение TAB в компоненте RadioGroup
При перемещении фокуса ввода клавишей Tab чтобы переместить его в RadioGroup нужно нажать клавишу Tab дважды если какой нибудь пункт RadioGroup уже выбран, но только один раз если не выбран. Можно ли сделать поведение RadioGroup логичным?
Установка свойства RadioGroup'ы TabStop в false должна решить эту проблему - поскольку клавиша tab будет продолжать работать - перемещаясь сразу на выделенный пункт RadioGroup.
Позиция дочерних MDI-окон
Позиция дочерних MDI-окон
Автор: Richard Cox
Проблема, с котороя я столкнулся, заключается в том, что нижняя часть дочерней формы загораживает панель состояния родительской формы...
У меня была аналогичная проблема -- она проявлялась при условии, когда свойство главной формы WindowState устанавливалось на wsMinimized.
Вот мое решение: добавьте этот небольшой метод к вашей главной форме:
interface
procedureCMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
implementation
procedure TMainForm.CMShowingChanged(var Message: TMessage);
var
theRect: TRect;
begin
inherited;
theRect := GetClientRect;
AlignControls(nil, theRect);
end;
Это работает, поскольку вызов AlignControls (в TForm) делает две вещи:
выравнивает элементы управления (включая ваш проблемный StatusBar) и
вновь позиционирует окно клиента относительно главной формы (оно ссылается на ClientHandle) после того, как элементы управления будут выравнены... что, впрочем, мы и хотели.
Взято с
Позиция курсора в TRichEdit
Позиция курсора в TRichEdit
Так как вопрос давольно часто поднимается в форумах, то хотелось бы привести ответ на него. Итак, как же получить текущие координаты курсора (Row и Col) в TRichEdit ?
Вот пример решения данной проблемы:
Procedure TForm1.GetPosition(Sender: TRichEdit);
var
iX,iY : Integer;
TheRichEdit : TRichEdit;
begin
iX := 0; iY := 0;
TheRichEdit := TRichEdit(Sender);
iY := SendMessage(TheRichEdit.Handle, EM_LINEFROMCHAR, TheRichEdit.SelStart,
0);
iX := TheRichEdit.SelStart - SendMessage(TheRichEdit.Handle, EM_LINEINDEX,
iY, 0);
Panel1.Caption := IntToStr(iY + 1) + ':' + IntToStr(iX + 1) ;
end;
procedure TForm1.RichEditMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
GetPosition(RichEdit);
end;
procedure TForm1.RichEditKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
GetPosition(RichEdit);
end;
Взято с Исходников.ru
Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?
Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?
Позволяет ли QuickReport выгружать данные в формате Microsoft Excel?
Quick Report не позволяет выгружать данные в формате Microsoft Excel. Но последние его версии позволяют сохранять отчеты в формате CSV (Comma Separated Value) и HTML, и оба эти формата можно прочесть с помощью Excel.
Помимо этого, для генерации отчета можно использовать автоматизацию Excel (Automation, ранее назвалось OLE Automation. ? Прим. ред.), вообще не прибегая к использованию QuickReport.
Наталия Елманова
Взято с Исходников.ru
Правила для SetRange
Правила для SetRange
Я, похоже, обнаружил неплохое решение ранжирования данных - вам необходимо только установить различные начальный и конечный диапазоны последнего поля, определенного вашим индексом, после чего введенное в любое поле индекса значение будет проигнорировано. Также вы не сможете покинуть ранжируемое поле, если редактируемая запись пуста.
Попытаюсь изложить все попроще... Скажем, у меня есть индекс Field1; Field2; Field3, затем;
SetRangeStart;
Table1Field1.Value:= x1;
Table1Field2.Value := y1;
Table1Field3.Value := z1;
SetRangeEnd;
Table1Field1.Value := x2;
Table1Field2.Value := y2;
Table1Field3.Value := z2;
ApplyRange;
Правила...
x1 должен равняться x2, если y или z определен
y1 должен равняться y2, если z определен
x должен быть определен, если y или z определены
y должен быть определен, если x определен
если x1 = x2 и никаких других критериев не определено, тогда y1 и y2 должны быть соответственно min/max значениями y
если x1 = x2 и y1 = y2 и никаких других критериев не определено, тогда z1 и z2 должны быть соответственно min/max значениями z
Я не знаю, поняли вы это или нет, но надеюсь это поможет...
Взято из
Предопределённые константы условной компиляции
Предопределённые константы условной компиляции
Версии компилятора
Ver80
- Дельфи 1 Ver90 - Дельфи 2
Ver93 - С Buider 1
Ver100 - Дельфи 3
Ver110 - С Buider 3
Ver120 - Дельфи 4
Ver125 - С Buider 4
Ver130 - Дельфи 5
Ver140 - Дельфи 6
Ver150 - Дельфи 7
Ver160 - Дельфи 8
KYLIX - Kylix 1
KYLIX2 - Kylix 2
KYLIX3 - Kylix 3
KYLIX4 - Kylix 4
Платформа: (определена для Дельфи 6 и выше)
Linux
MSWindows
Среда разработки:
DELPHI
BCB
Взято с Vingrad.ru
Предпросмотр
Предпросмотр
Cодержание раздела:
Преобразование числа в двоичную запись
Преобразование числа в двоичную запись
Для преобразования числа в двоичную запись удобно использовать функции shl и and.
Эта функция преобразует число в строку из единиц и нулей. Количество цифр определяется параметром Digits.
function IntToBin(Value: integer; Digits: integer): string;
var
i: integer;
begin
result := '';
for i := 0 to Digits - 1 do begin
if Value and (1 shl i) > 0
then result := '1' + result
else result := '0' + result;
end;
end;
Вот пример использования этой функции:
procedure TForm1.Edit1Change(Sender: TObject);
begin
Form1.Caption := IntToBin(StrToIntDef(Edit1.Text, 0), 128);
end;
Взято с сайта
Преобразование цвета RGB <-> HLS
Преобразование цвета RGB <-> HLS
{ Максимальные значения }
Const
HLSMAX = 240;
RGBMAX = 255;
UNDEFINED = (HLSMAX*2) div 3;
Var
H, L, S : integer; { H-оттенок, L-яркость, S-насыщенность }
R, G, B : integer; { цвета }
procedure RGBtoHLS;
Var
cMax,cMin : integer;
Rdelta,Gdelta,Bdelta : single;
Begin
cMax := max( max(R,G), B);
cMin := min( min(R,G), B);
L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );
if (cMax = cMin) then begin
S := 0; H := UNDEFINED;
end else begin
if (L <= (HLSMAX/2)) then
S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
else
S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
/ (2*RGBMAX-cMax-cMin) );
Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
if (R = cMax) then H := round(Bdelta - Gdelta)
else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta)
else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
if (H < 0) then H:=H + HLSMAX;
if (H > HLSMAX) then H:= H - HLSMAX;
end;
if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;
if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;
end;
procedure HLStoRGB;
Var
Magic1,Magic2 : single;
function HueToRGB(n1,n2,hue : single) : single;
begin
if (hue < 0) then hue := hue+HLSMAX;
if (hue > HLSMAX) then hue:=hue -HLSMAX;
if (hue < (HLSMAX/6)) then
result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
else
if (hue < (HLSMAX/2)) then result:=n2 else
if (hue < ((HLSMAX*2)/3)) then
result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
else result:= ( n1 );
end;
begin
if (S = 0) then begin
B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
end else begin
if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
Magic1 := 2*L-Magic2;
R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
end;
if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;
if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;
if B<0 then B:=0; if B>RGBMAX then B:=RGBMAX;
end;
Зайцев О.В.
Владимиров А.М.
Взято с Исходников.ru
Преобразуем доменное имя в IP адрес
Преобразуем доменное имя в IP адрес
Автор: Lutfi Baran
Описывается функция, которая показывает, как вычислить IP адрес компьютера в интернете по его доменному имени.
Совместимость: Delphi 3.x (или выше)
Объявляем Winsock, для использования в функции
............
function HostToIP(Name: string; var Ip: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, Name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
if Assigned (hostEnt^.h_addr_list) then begin
addr := hostEnt^.h_addr_list^;
if Assigned (addr) then begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else begin
Result := False;
end;
finally
WSACleanup;
end
end;
................................
Вы можете разметстить на форме EditBox, Кнопку и Label и добавить к кнопке следующий обработчик события OnClick:
procedure TForm1.Button1Click(Sender: TObject);
var
IP: string;
begin
if HostToIp(Edit1.Text, IP) then Label1.Caption := IP;
Взято с Исходников.ru
Прерывание работы принтера
Прерывание работы принтера
При вызове Printer.Abort должен вызываться код
WinProcs.AbortProc(Printer.Handle)
но этого не происходит. Вызывайте это сами каждый раз при использовании Printer.Abort.
Взято из
Советов по Delphi от
Сборник Kuliba
При использовании BDE, попытка вызвать abort выдает ошибку компиляции
При использовании BDE, попытка вызвать abort выдает ошибку компиляции
При использовании модулей доступа к BDE (DbiTypes, DbiProcs, DbiErrs), любая попытка вызвать процедуру abort выдает ошибку при компиляции при вызове метода abort "Statement expected, but expression of type 'Integer' found". Я пытался найти DbiTypes.pas, DbiProcs.pas и DbiErrs.pas чтобы разобраться но не нашел этих файлов. Где расположены эти файлы и как обойти ошибку?
Модули DbiTypes, DbiProcs, DbiErrs это псевдонимы модуля "BDE", обьявлены в Projects->Options->Directories/Conditionals->Unit Aliases. Исходник модуля DBE находится в каталоге "doc" и называется "BDE.INT". В этом файле обьявленна константа ABORT со значением -2. Так как Вы хотите использовать процедуру Abort(), которая обьявлена в модуле SysUtils, Вам нужно добавить префикс SysUtils перед вызовом процедуры Abort.
SysUtils.Abort;
При использовании DOS DBF файлов - перекодировка между форматами
При использовании DOS DBF файлов - перекодировка между форматами
При использовании DOS DBF файлов можно сделать небольшую программку (или процедурку), которая произведет перекодировку между форматами. что-то типа:
functionupdate_dos(s:string):string;
var c:STRING;
I:INTEGeR;
l:byte;
dd:char;
begin
i:=1;
c:='';
while i< length(s)+1 do
begin
l:=ord(s[i]);
inc(i);
if (l>=128) and (l<=192)then l:=l+64 else
if (l>=224) and (l<240) then l:=l+16 else
if l=241 then l:=184 else
if l=240 then l:=168;
dd:=chr(l);
c:=c+dd;
end;
update_dos:=c;
end;
function update_win(s:string):string;
var c:STRING;
I:INTEGeR;
l:byte;
dd:char;
begin
i:=1;
c:='';
while i< length(s)+1 do
begin
l:=ord(s[i]);
inc(i);
if (l>=192) and (l<240)then l:=l-64 else
if (l>=240) and (l<256) then l:=l-16 else
if l=184 then l:=241 else
if l=168 then l:=240;
dd:=chr(l);
c:=c+dd;
end;
update_win:=c;
end;
это и туда и обратно, у меня работает на старых DBF. Осталось только вызвать в нужный момент.
Взято из
При попытке регистрации UDF возникает ошибка - udf not defined
При попытке регистрации UDF возникает ошибка - udf not defined
Автор: Nomadic
Располагайте DLL в каталоге Interbase/Bin, или в одном из каталогов, в которых ОС обязательно будет произведен поиск этой библиотеки (для Windows это %SystemRoot% и %Path%);
При декларировании функции не следует указывать расширение модуля (в Windows по умолчанию DLL):
declareexternal function f_SubStr
cstring(254), integer, integer
returns
cstring(254)
entry_point "Substr" module_name "UDF1"
Где UDF1 - UDF1.DLL.
Взято из
Придание MDI-формам большей трехмерности
Придание MDI-формам большей трехмерности
constructorTMainForm.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
SetWindowLong(ClientHandle, GWL_EXSTYLE,
GetWindowLong(ClientHandle,
GWL_EXSTYLE) or WS_EX_CLIENTEDGE);
SetWindowPos(ClientHandle, 0, 0, 0, 0, 0,
swp_DrawFrame or swp_NoMove or swp_NoSize
or swp_NoZOrder);
end;
Взято с
Приёмы работы с BDE
Приёмы работы с BDE
Те примеры с которыми мы работали использовали именно BDE. Давайте рассмотрим вопросы, напрямую связанные с BDE:
1) Где физически хранится моя база данных
2) Как создать базу данных
3) Как создать таблицу
Итак, где физически хранится моя база данных и собственно куда мы обращались в наших примерах? Если вы помните, в наших примерах мы свойство DatabaseName для Table установили в "DBDemos". Что же это такое "DBDemos"? - это название базы данных, или в терминологии BDE - Alias (перевод на русский язык "Псевдоним"). Alias - это некая "структура" BDE, которая указывает на физическое расположение файлов базы данных, а так же хранит некоторые свойства (параметры) доступа к базе данных. Эти параметры можно посмотреть, настроить, а также добавить или удалить Alias используя программу "BDE Administrator" которую можно найти в Control Panel (панель управления Windows). Запустите BDE Administrator и найдите в левом дереве DBDemos. Теперь на правой части можно увидеть его свойства, например там вы найдёте путь к базе данных. С помощью BDE можно удалить Alias или добавить новый.
Приёмы работы с BLOB (OLE/Memo) полями
Приёмы работы с BLOB (OLE/Memo) полями
Загрузка файла из TImage:
QAll.Edit;
QAll.FieldByName('Logo').assign(Image.Picture);
QAll.post;
Чтение файла из таблицы в TImage:
Image.Picture.assign(QAll.FieldByName('Logo'));
Загрузка данных в поле:
(Table1.DataSource2.Fields.Field[01] As TBlobField).LoadFromStream
Загрузка данных через параметры:
Запрос
Insert into MyTable (MyBlobField)
Values (:Something)
В коде:
(Query1.parameters.parambyname('Something') as TBlobField).LoadFromFile ...
(Query1.parameters.parambyname('Something') as TBlobField).LoadFromStream ...
(Query1.parameters.parambyname('Something') as TBlobField).assign ...
Автор:
VitВзято из
Приложение с различным разрешением монитора?
Приложение с различным разрешением монитора?
Из рассылки "Мастера DELPHI. Новости мира компонент, FAQ, статьи..."
Приложение, адекватно отображающееся на экранах с различным разрешением монитора?
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{Отлавливаем, сообщение о изменении разрешения экрана}
procedure WMDisplayChange(var message: TMessage); message WM_DISPLAYCHANGE;
public
W, H: integer;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Width := Round(Width * 1.5);
Height := Round(Height
* 1.5);
ScaleBy(150, 100)
end;
procedure TForm1.WMDisplayChange(var message: TMessage);
begin
inherited;
Width := Round(Width * LOWORD(message.LParam) / W);
Height := Round(Height * HIWORD(message.LParam) / H);
ScaleBy(LOWORD(message.LParam), W);
W := Screen.Width;
H := Screen.Height;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
W := Screen.Width;
H := Screen.Height;
end;
end.
Взято с Vingrad.ru
DbiAddFilter
Пример DbiAddFilter
Автор: Mark Erbaugh
type
TmyFilter = record
Expr: CANExpr;
Nodes: array[0..2] of CANNode;
literals: array[0..7] of char;
end;
const
myFilter: TMyFilter = (Expr:
(iVer: 1; iTotalSize: sizeof(TMyFilter); iNodes: 3;
iNodeStart: sizeof(CANExpr); iLiteralStart: sizeof(CANExpr) +
3 * sizeof(CANNode));
Nodes:
((canBinary: (nodeClass: nodeBinary; canOP: canEQ;
iOperand1: sizeof(CANNode); iOperand2: 2 * sizeof(CANNode))),
(canField: (nodeClass: nodeField; canOP: canField2;
iFieldNum: 0; iNameOffset: 0)),
(canConst: (nodeClass: nodeConst; canOP: canCONST2;
iType: fldZSTRING; iSize: 3; iOffset: 5)));
literals:
('T', 'Y', 'P', 'E', #0, 'I', 'N', #0));
var
dbResult: DBIResult;
hFilter, hFilter1: hDBIFilter;
begin (* procedure SetupFilter *)
dbResult := DbiAddFilter(tblAP_.Handle, 1, 1,
False, addr(myFilter), nil, hFilter);
dbResult := DbiActivateFilter(tblAP_.Handle, hFilter);
tblAP_.First;
myFilter.nodes[0].canBinary.canOp := canNE;
dbResult := DbiAddFilter(tblAP1_.Handle, 1, 1,
False, addr(myFilter), nil, hFilter1);
dbResult := DbiActivateFilter(tblAP1_.Handle, hFilter1);
tblAP1_.First;
myFilter.nodes[0].canBinary.canOp := canEQ;
end;
Этот пример устанавливает два фильтра. Первый (применяемый к tblAP_) выводит все записи, где ТИП поля имеет значение 'IN'. Второй (применяемый к tblAP1_) выводит все записи, где ТИП поля не имеет значения 'IN'.
Также необходимо включить в ваш файл файлы DBITYPES и DBIPROCS, где определены вызываемые функции и константы.
Взято из
EnumWindows
Пример EnumWindows
Создайте форму и разместите на ней два компонента ListBox.
Скопируйте код, показанный ниже.
Запустите SysEdit.
Запустите форму Delphi. Первый ListBox должен содержать список всех запущенных приложений. Дважды щелкните на SysEdit и нижний ListBox покажет дочернее MDI-окно программы SysEdit.
Paul Powers (Borland)
unitWintask1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
ListBox2: TListBox;
procedure FormCreate(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
private
function enumListOfTasks(hWindow: hWnd): Bool; export;
function enumListOfChildTasks(hWindow: hWnd): Bool; export;
end;
THoldhWnd = class(TObject)
private
public
hWindow: hWnd;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
enumWindows(@TForm1.EnumListOfTasks, Longint(Self));
if (ListBox1.Items.Count > 0) then
ListBox1.ItemIndex := 0;
end;
function TForm1.enumListOfTasks(hWindow: hWnd): Bool;
var
HoldString: PChar;
WindowStyle: Longint;
IsAChild: Word;
HoldhWnd: THoldhWnd;
begin
GetMem(HoldString, 256);
HoldhWnd := THoldhWnd.Create;
HoldhWnd.hWindow := hWindow;
WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
WindowStyle := WindowStyle and Longint(WS_VISIBLE);
IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);
{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
if (GetWindowText(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild = Word(nil)) then
ListBox1.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
else if (GetClassName(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild = Word(nil)) then
ListBox1.Items.AddObject(Concat('<', StrPas(HoldString), '>'), TObject(HoldhWnd));
FreeMem(HoldString, 256);
HoldhWnd := nil;
Result := TRUE;
end;
function TForm1.enumListOfChildTasks(hWindow: hWnd): Bool;
var
HoldString: PChar;
WindowStyle: Longint;
IsAChild: Word;
HoldhWnd: THoldhWnd;
begin
GetMem(HoldString, 256);
HoldhWnd := THoldhWnd.Create;
HoldhWnd.hWindow := hWindow;
WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
WindowStyle := WindowStyle and Longint(WS_VISIBLE);
IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);
{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
if (GetWindowText(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild <> Word(nil)) then
ListBox2.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
else if (GetClassName(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild = Word(nil)) then
ListBox2.Items.AddObject(Concat('<', StrPas(HoldString), '>'), TObject(HoldhWnd));
FreeMem(HoldString, 256);
HoldhWnd := nil;
Result := TRUE;
end;
procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
enumChildWindows(THoldhWnd(ListBox1.Items.Objects[ListBox1.ItemIndex]).hWindow, @TForm1.enumListOfChildTasks, Longint(Self));
ListBox2.RePaint;
end;
end.
Дополнение
В Kuliba1000.chm Win32 API/Разное/Пример EnumWindows есть принципиальная ошибка в коде:
ЛЮБАЯ callback ( обратного вызова ) функция в Delphi должна сопровождаться директивой stdcall.
Предоставленный пример просто не работает.
Определение класса формы должно выглядеть как-то так:
type
TForm1 = class(TForm)
ListBox1: TListBox;
ListBox2: TListBox;
procedure FormCreate(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
private
function enumListOfTasks(hWindow: hWnd): Bool; stdcall;
function enumListOfChildTasks(hWindow: hWnd): Bool; stdcall;
end;
Директивы export (это написано в Help'е) просто не работают (игнорируются) под Win 32 :(
С наилучшими пожеданиями
Андрей Бреслав
Взято из
Советов по Delphi от
Сборник Kuliba
