Определение установленных версий .NET Framework в системе
Определение установленных версий .NET Framework в системе
/// <summary>
/// Enumerates all installed Common Language Runtime Engines.
/// </summary>
/// <param name="Index">Zero-based index of looked runtime
record.</param>
/// <returns>True if runtime with specified index found.</returns>
function EnumInstalledRuntimes(Index: Integer; out VersionName: String):
Boolean;
var
hkey: Windows.HKEY;
hsubkey: Windows.HKEY;
I: Cardinal;
J: Cardinal;
NameBuf: array[0..MAX_PATH] of Char;
CNameBuf: Cardinal;
lwt: TFileTime;
vt: DWORD;
AnyFound: Boolean;
begin
Result := False;
VersionName := '';
if ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE,
PChar('SOFTWARE\Microsoft\.NETFramework\policy'), 0,
KEY_ENUMERATE_SUB_KEYS, hkey) then
try
I := 0;
while True do
begin
AnyFound := False;
CNameBuf := MAX_PATH + 1;
if ERROR_SUCCESS <> RegEnumKeyEx(hkey, I, @NameBuf[0], CNameBuf,nil, nil, nil, @lwt) then
begin
Break;
end;
if (NameBuf[0] = 'v') and (NameBuf[1] in ['1'..'9']) then
begin
VersionName := String(NameBuf);
if ERROR_SUCCESS = RegOpenKeyEx(hkey, @NameBuf[0], 0,KEY_QUERY_VALUE, hsubkey) then
try
J := 0;
while true do
begin
CNameBuf := MAX_PATH + 1;
if ERROR_SUCCESS <> RegEnumValue(hsubkey, J, @NameBuf[0],CNameBuf, nil, @vt, nil, nil) then
begin
Break;
end;
if (vt = REG_SZ) and (NameBuf[0] <> #0) then
begin
VersionName := VersionName + '.' + String(NameBuf);
AnyFound := True;
Break;
end;
Inc(J);
end;
finally
RegCloseKey(hsubkey);
end;
end;
Inc(I);
if AnyFound then
begin
if Index = 0 then
begin
Result := True;
Break;
end;
Dec(Index);
end;
end;
finally
RegCloseKey(hkey);
end;
end;
Автор Акжан Абдулин
Взято с сайта
Определить, занят ли порт сокета
Определить, занят ли порт сокета
varSockAddrIn : TSockAddrIn;
FSocket : TSocket;
...
If bind(FSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 Then
begin
обрабатываем WSAGetLastError
end;
Взято с
Оптимизация программы для работы в фоновом режиме
Оптимизация программы для работы в фоновом режиме
Я пишу программу в Delphi, которая каждый час должна проверять размер файла. Это также предполагает, что в случае неактивности приложения оно должно работать сторожевым псом в фоновом режиме win 95 и NT. Как мне сделать это...?? Вот некоторый исходный код, который должен делать то, что вы хотите. Я его только что создал и еще не успел проверить, но что-то подобное я уже делал, так что это должно работать. Код допускает одно предположение, о котором вы должны отдавать себе отчет. Оно заключается в том, что приложение должно запускатьтся одновременно с Windows (может быть из группы автозапуска), так как код использует GetTickCount, возвращающий в миллисекундах время с момента старта системы, это необходимо для ежечасной инициализац ии кода выполнения задачи. По-моему это то, что вам нужно. Величина, возвращаемая GetTickCount имеет тип DWORD, но Delphi ее хранит как LongInt, поэтому большие значения могут иметь отрицательную величину (после примерно 25 дней). Данный эффект в алгоритм е проверки наступления часа неопределен (я действительно не считал это). Аналогично, значение будет повторяться в цикле каждые 49.7 дней и может появиться другой эффект, когда раз в 49.7 дней в одном реальном часе алгоритм сработает дважды. Надеюсь это ни как не скажется на вашей задаче. Во всяком случае разве это не то, что вы хотели? Успехов!
programProject1;
uses Messages, Windows;
{$R *.RES}
function KeepRunning: Boolean;
var
Msg: TMsg;
begin
Result := True;
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
begin
if (Msg.Message = WM_QUIT) then
Result := False;
DispatchMessage(Msg);
end;
end;
function OnTheHour: Boolean;
begin
{ Это действительно проверяется в течение одной секунды }
{ (или меньше) для проверки наступления нового часа, }
{ когда нам необходимо запустить нашу задачу на выполнение }
Result := (GetTickCount mod
(1 {hr} * 60 {min} * 60 {sec} * 1000 {msec}) < 1000);
end;
const
filetocheck = 'c:\somedir\somefile.ext';
magicsize = 1000000;
var
f: file;
size: longint;
begin
{ проверка наступления нового часа с момента запуска системы }
while keeprunning do
begin
{ проверяем наступление часа }
if onthehour then
begin
{ открываем файл с размером записи 1 байт }
{ и проверяем его размер }
assignfile(f, filetocheck);
reset(f, 1);
size := filesize(f);
closefile(f);
{ теперь проверяем изменение размера файла }
if (size >= MAGICSIZE) then
begin
{ Предпринимаем какие-то действия }
end;
{ Теперь "сидим" в этом участке кода }
{ и ожидаем очередного часа, здесь можно }
{ предусмотреть выход из программы или иное действие }
while (KeepRunning and OnTheHour) do
{ничего};
end;
end;
end.
Взято с
Оптимизация скинов для окошек сложной формы
Оптимизация скинов для окошек сложной формы
Автор: Бочаров Александр
Немного предистории: надо было мне создать скиновое окошко. Вроде несложно, исходников по этому делу везде лежит навалом, бери да делай. Проблема организовалась в том, что для сложных фигур просчет такого окна из растра занимает достаточно много времени. А когда окон несколько? Короче, я решил все это дело написать самостоятельно, причем отказавшись от таких вещей, как GetPixel() и CombineRgn(). Получилось вроде здорово и быстро.
Далее следует исходный код с комментариями:
unit RgnUnit;
interface
uses
Windows, SysUtils, Classes;
function CreateBitmapRgn(DC : hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn;
{
Данная функция создает регион, используя для этого растр Bitmap
и исключая из него цвет TransClr. Все расчеты производятся для
устройства DC.
данная функция состоит из двух частей:
первая часть выделяет память и копирует туда исходное изображение в формате
24 бита на точку, без палитры, т.е. фактически в каждых трех байтах
данного раздела памяти будет записан цвет точки исходного изображения.
Данный формат был выбран из удобства его обработки
(нет необходимости создавать палитру), к тому же нет потери качества
при конвертации исходного изображения. Однако, теоретически можно использовать
любой формат.
Для выделения памяти под конвертируемое изображение используется функция
WinAPI CreateDIBSection. Данная функция выделяет память и создает
независмый растр. Для вызова данной функции необходимо заполнить структуру
BITMAPINFO, что достаточно не сложно.
Внимание! для изображений Windows Bitmap используется разрешение в формате
dots per metr (pixels per metr), стандартному разрешению 72dpi соответствует
2834dpm.
Фактически, данную функция можно не использовать, вручную выделив память
для последующего переноса исходного изображения.
Для конвертации и переноса исходного изображения в выделнную память
используется функция WinAPI GetDIBits. Функции передаются следуюшие параметры:
исходное изображение, количество рядов для переноса, указатель на память,
куда следует перенести изображение, структура BITMAPINFO с заполнеными первыми
шестью членами (именно здесь задяются параметры для конвертирования
изображения). Фактически, данная функция может перевести любой исходный растр
в любой необходимый растр.
вторая чать описываемой функции проходится по области памяти, куда было
занесено конвертируемое изображение, отсекает ненужные области и содает регион.
Для создания региона используется функция WinAPI ExtCreateRegion. Для вызова
данной функции необходимо заполнить структуру RGNDATA, состоящую из структуры
RGNDATAHEADER и необходимого количества структур RECT. в Дельфи структура
RGNDATA описана так:
_RGNDATA = record
rdh: TRgnDataHeader;
Buffer: array[0..0] of CHAR;
Reserved: array[0..2] of CHAR;
end;
RGNDATA = _RGNDATA;
Скорее всего, поле Reserved было введено программистами Дельфи только для того,
чтобы в нее умещался хотя бы один прямоугольник, т.к. в Microsoft Platfrom SDK
этого поля нет. Однако, данная структура нам не подходит, т.к. нам необходимо
учитывать сразу несколько прямоугольников. Для решения этой задачи приходится
выделять память вручную, с учетом RGNDATAHEADER и количества прямоугольников,
необходимых нам, заносить туда прямоугольники (после RGNDATAHEADER),
создавать указатель на структуру RGNDATA и ставить его на выделнную память.
Следовательно, придется два раза пройтись по растру: первый раз - для расчета
количества прямоугольников, а второй - для уже фактического их занесения
в выделенную память.
Есть несколько способов для избежания двойного прохода растра, но все они
имеют свои недостатки и здесь не рассматриваются. В любом случае, даже для
больших и сложных изображений эти два прохода достаточно быстры.
по окнчании работы функции освобождается память, выделенная на конвертируемый
растр и структуру RGNDATA.
}
implementation
//создает регион из растра Bitmap для DC с удалением цвета TransClr
//внимание! TColorRef и TColor не одно и тоже.
//Для перевода используется функция ColorToRGB().
function CreateBitmapRgn(DC: hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn;
var
bmInfo: TBitmap; //структура BITMAP WinAPI
W, H: Integer; //высота и ширина растра
bmDIB: hBitmap; //дискрептор независимого растра
bmiInfo: BITMAPINFO; //структура BITMAPINFO WinAPI
lpBits, lpOldBits: PRGBTriple; //указатели на структуры RGBTRIPLE WinAPI
lpData: PRgnData; //указатель на структуру RGNDATA WinAPI
X, Y, C, F, I: Integer; //переменные циклов
Buf: Pointer; //указатель
BufSize: Integer; //размер указателя
rdhInfo: TRgnDataHeader; //структура RGNDATAHEADER WinAPI
lpRect: PRect; //указатель на TRect (RECT WinAPI)
begin
Result:=0;
if Bitmap=0 then Exit; //если растр не задан, выходим
GetObject(Bitmap, SizeOf(bmInfo), @bmInfo); //узнаем размеры растра
W:=bmInfo.bmWidth; //используя структуру BITMAP
H:=bmInfo.bmHeight;
I:=(W*3)-((W*3) div 4)*4; //определяем смещение в байтах
if I<>0 then I:=4-I;
//Пояснение: растр Windows Bitmap читается снизу вверх, причем каждая строка
//дополняется нулевыми байтами до ее кратности 4.
//для 32-х битный растров такой сдвиг делать не надо.
//заполняем BITMAPINFO для передачи в CreateDIBSection
bmiInfo.bmiHeader.biWidth:=W; //ширина
bmiInfo.bmiHeader.biHeight:=H; //высота
bmiInfo.bmiHeader.biPlanes:=1; //всегда 1
bmiInfo.bmiHeader.biBitCount:=24; //три байта на пиксель
bmiInfo.bmiHeader.biCompression:=BI_RGB; //без компрессии
bmiInfo.bmiHeader.biSizeImage:=0; //размер не знаем, ставим в ноль
bmiInfo.bmiHeader.biXPelsPerMeter:=2834; //пикселей на метр, гор.
bmiInfo.bmiHeader.biYPelsPerMeter:=2834; //пикселей на метр, верт.
bmiInfo.bmiHeader.biClrUsed:=0; //палитры нет, все в ноль
bmiInfo.bmiHeader.biClrImportant:=0; //то же
bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); //размер структруы
bmDIB:=CreateDIBSection(DC, bmiInfo, DIB_RGB_COLORS,
Pointer(lpBits), 0, 0);
//создаем независимый растр WxHx24, без палитры, в указателе lpBits получаем
//адрес первого байта этого растра. bmDIB - дискрептор растра
//заполняем первые шесть членов BITMAPINFO для передачи в GetDIBits
bmiInfo.bmiHeader.biWidth:=W; //ширина
bmiInfo.bmiHeader.biHeight:=H; //высота
bmiInfo.bmiHeader.biPlanes:=1; //всегда 1
bmiInfo.bmiHeader.biBitCount:=24; //три байта на пиксель
bmiInfo.bmiHeader.biCompression:=BI_RGB; //без компресси
bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); //размер структуры
GetDIBits(DC, Bitmap, 0, H-1, lpBits, bmiInfo, DIB_RGB_COLORS);
//конвертируем исходный растр в наш с его копированием по адресу lpBits
lpOldBits:=lpBits; //запоминаем адрес lpBits
//первый проход - подсчитываем число прямоугольников, необходимых для
//создания региона
C:=0; //сначала ноль
for Y:=H-1 downto 0 do //проход снизу вверх
begin
X:=0;
while X<W do //от 0 до ширины-1
begin
//пропускаем прзрачный цвет, увеличивая координату и указатель
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)=TransClr) and (X<W) do
begin
Inc(lpBits);
X:=X+1;
end;
//если нашли не прозрачный цвет, то считаем, сколько точек в ряду он идет
if RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr then
begin
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr) and (X<W) do
begin
Inc(lpBits);
X:=X+1;
end;
C:=C+1; //увиличиваем счетчик прямоугольников
end;
end;
//ряд закончился, необходимо увеличить указатель до кратности 4
PChar(lpBits):=PChar(lpBits)+I;
end;
lpBits:=lpOldBits; //восстанавливаем значение lpBits
//Заполняем структуру RGNDATAHEADER
rdhInfo.iType:=RDH_RECTANGLES; //будем использовать прямоугольники
rdhInfo.nCount:=C; //их количество
rdhInfo.nRgnSize:=0; //размер выделяем памяти не знаем
rdhInfo.rcBound:=Rect(0, 0, W, H); //размер региона
rdhInfo.dwSize:=SizeOf(rdhInfo); //размер структуры
//выделяем память для струтуры RGNDATA:
//сумма RGNDATAHEADER и необходимых на прямоугольников
BufSize:=SizeOf(rdhInfo)+SizeOf(TRect)*C;
GetMem(Buf, BufSize);
lpData:=Buf; //ставим указатель на выделенную память
lpData.rdh:=rdhInfo; //заносим в память RGNDATAHEADER
//Заполдяенм память прямоугольниками
lpRect:=@lpData.Buffer; //первый прямоугольник
for Y:=H-1 downto 0 do
begin
X:=0;
while X<W do
begin
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)=TransClr) and (X<W) do
begin
Inc(lpBits);
X:=X+1;
end;
if RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr then
begin
F:=X;
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr) and (X<W) do
begin
Inc(lpBits);
X:=X+1;
end;
lpRect^:=Rect(F, Y, X, Y+1); //заносим координаты
Inc(lpRect); //переходим к следующему
end;
end;
PChar(lpBits):=PChar(lpBits)+I;
end;
//после окночания заполнения структуры RGNDATA можно создавать регион.
//трансформации нам не нужны, ставим в nil, указываем размер
//созданной структуры и ее саму.
Result:=ExtCreateRegion(nil, BufSize, lpData^); //создаем регион
FreeMem(Buf, BufSize); //теперь структура RGNDATA больше не нужна, удаляем
DeleteObject(bmDIB); //созданный растр тоже удаляем
end;
end.
Взято с Исходников.ru
Я использую среду Delphi. Ошибка,
Ошибка BDE32 2104
Автор: Pat Ritchey
Пример, приведенный для функции dbiGetDatabaseDesc в файле BDE32.HLP, неверен. Такой же пример содержится в файле TI3100.ASC. Я пробовал это на 3 разных компьютерах. Я использую среду Delphi. Ошибка, которую я получаю при попытке использования функции, выглядит следующим образом:
EDBEngineError с сообщением 'Возникла ошибка при попытке инициализации Borland Database Engine (ошибка $2104).'
При вызове любой из функций BDE, если вы не пользуетесь компонентами для работы с базами данных, вам необходимо инициализировать BDE вызовом dbiInit(nil).
Взято из
Ошибка: lock manager out of room
Ошибка: lock manager out of room
Go to the interbase/bin directory (Windows) or /usr/interbase (Unix) and locate the configuration file isc_config. By default your configuration file will look like this:
#V4_LOCK_MEM_SIZE98304
#ANY_LOCK_MEM_SIZE 98304
#V4_LOCK_SEM_COUNT 32
#ANY_LOCK_SEM_COUNT 32
#V4_LOCK_SIGNAL 16
#ANY_LOCK_SIGNAL 16
#V4_EVENT_MEM_SIZE 32768
#ANY_EVENT_MEM_SIZE 32768
I increased the V4_LOCK_MEM_SIZE entry from 98304 to 198304 and things were fine then.
!!! Important !!!
By default all lines in the config file are commented out with the leading # sign. Make sure to remove the # sign in any line that you change - the default config file just shows the default parameters.
Взято с
Delphi Knowledge BaseОшибка о файле SAA.AAA
Ошибка о файле SAA.AAA
The 'SAA.AAA' file is a temporary file used in processing a query.
A failure involving this file generally means that InterBase has run out of disk space processing the query.
(Remember that this will be a temporary file on the server, so the server is out of disk space, not your local machine!)
Взято с
Delphi Knowledge BaseЭтот файл является временным, и создается когда при выполнении запроса возникает необходимость в сортировке результата. Ошибка может возникать при нехватке дискового пространства на томе, куда указывает TEMP. Для NT при работе IB в режиме сервиса необходимо изменить переменную TEMP для System (см. My Computer/Properties/Environment). Для IB 5.x и 6.0 (в архитектуре SuperServer только!) можно указать диски и размер временных файлов в файле конфигурации IBCONFIG, или в переменной окружения INTERBASE_TMP (см. Operations Guide, стр92). Например:
TMP_DIRECTORY "c:\" 10000000
TMP_DIRECTORY "e:\temp\" 100000000
Может быть указано несколько дисков или каталогов, которые будут использоваться последовательно. Размер должен быть указан в байтах. Кавычки для имени диска и каталога обязательны.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко
Ошибка при установке Internal error near IBcheck
Ошибка при установке Internal error near IBcheck
Эта ошибка вызвана порчей ключа registry инсталлятором Delphi 4. Исправить ее можно, запустив RegEdit и проверив ключ HK_CURRENT_USER/Environment. Значение PATH должно быть строкового типа. Если это не так, то PATH надо поменять (или пересоздать) на строковое значение.
Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко
Ошибка совместного доступа к базе данных
Ошибка совместного доступа к базе данных
Подскажите как на дельфи создаются базы данных с которыми можно работать на нескольких компьютерах одновременно (таблицы Paradox). Как буфиризировать таблицы Paradox? Использую компонент DataBase со стандарным драйвером, указываю сетевой путь к БД, но при обращении сразу нескольких пользователей возникает сообщение что каталог заблокирован другим .NET файлом.
Решение:
Control Panel->BDE Administrator->закладка Configuration->Drivers->Native->Paradox
Сделайте где нибудь в сетке каталог доступный со всех компьютеров, Опция Net Dir должна указывать на всех компьютерах должна указывать на этот каталог - в нём будут хранится файлы которые обеспечивают раздельный доступ.
Автор ответа: Vit
Взято с Vingrad.ru
Ошибка создания дескриптора курсора
Ошибка создания дескриптора курсора
Вы должны использовать ExecSql вместо Open. К примеру, если имя вашего запроса UpdateStudent, то при необходимости обновления STUDENT.DB вы должны использовать следующий код:
Begin
.....
UpdateStudent.ExecSql;
.....
End;
Ваш запрос является Passtrough-запросом, который не может возвратить установленный результат, так что это не может быть открыто, а должно быть 'ВЫПОЛНЕНО'.
Взято из
Ошибки связанные с работой среды Дельфи
Ошибки связанные с работой среды Дельфи
Cодержание раздела:
Ошибки в Дельфи
Ошибки в Дельфи
Cодержание раздела:
См. также статьи в других разделах:
См. также другие разделы:
Основное отличие EXE-файлов созданных Delphi и Visual Basic
Основное отличие EXE-файлов созданных Delphi и Visual Basic
Основное отличие EXE-файлов созданных Delphi и Visual Basic
Существует два важных различия между файлами EXE, созданными в Delphi, и файлами EXE, созданными VB. Delphi создает чисто машинный код, непосредственно исполняемый компьютером, в то время как VB транслирует исходный код в промежуточную форму (р-код). Файл EXE, сгенерированный VB, в действительности является программой-интерпретатором р-кода с добавленным в конце р-кодом программы пользователя.
"Библиотека времени выполнения" (run-time library) стандартных функций для всех программ VB хранится в файле VBRUN300.DLL. Каждая программа VB, попавшая к конечному пользователю, должна включать этот файл, либо приходится расчитывать, что такой файл у пользователя уже есть. Дистрибутивный комплект программы должен также содержать файлы VBX для каждого управляющего средства VB, не включенного в VBRUN300.DLL.
Программы Delphi включают необходимую часть библиотеки времени выполнения Delphi, а также используемые компоненты. В результате EXE-файл Delphi обычно больше по объему, чем эквивалентный EXE-файл VB, но он не зависит ни от каких внешних файлов.
Источник:
Основы 3D математики - Векторные и матричные преобразования
Основы 3D математики - Векторные и матричные преобразования
Векторы
Вектор - направленный отрезок, имеющий направление и длину. Векторы обозначаются так: a = (x,y,z), например, b = (0,1,-2). Еще одно представление вектора : AB = (x,y,z).
AB= (x,y,z) = (bx-ax,by-ay,bz-az),
где A и B - 2 точки, A(ax,ay,az) и B(bx,by,bz), A - начало вектора, B - конец вектора.
Длина вектора
Длина вектора, |a|, считается так:
|a| = sqrt(ax2+ay2+az2).
Сложение векторов.
a + b = c;
a + b = (ax + bx, ay + by, az + bz).
т. е. как результат мы получаем вектор.
Вычитание векторов.
c - a = b;
c - a = (cx - ax, cy - ay, cz - az).
как результат - также мы получаем вектор.
Cкалярное произведение векторов.(dot)
Скалярное произведение 2х векторов - произведение длин 2х векторов на cos угла между ними. Скалярное произведение векторов - это длина проекции вектора a на вектор b.
a . b = |a| |b| cos ?;
или
a . b = axbx + ayby + azbz;
Следствие: ? - угол между двумя векторами: cos ? = a . b / (|a| |b|);
Проекция одного вектора на другой.
Для того, чтобы вычислить проекцию вектора b на вектор а требуется просто произвести скалярное умножение этих векторов, а затем получить произведение получившегося результата на вектор b. Обозначим искомый вектор как c. тогда:
c = (a . b) b;
фактически, мы находим длину проекции и, умножая ее на вектор, проекцию которого мы нашли, маштабируем его до нужного размера.
Умножение вектора на вектор.(cross)
Умножая вектор a на вектор b, мы получим вектор, перпендикулярный плоскости, которую определяют вектора a и b.
a x b = ( aybz - byaz , azbx - bzax , axby - bxay );
фактически, таким образом находиться вектор нормали к полигонам.
Матрицы
Здесь я постарался вкратце изложить то, что мы будем делать с матрицами.
скалярное произведение векторов:
[ a ] [ d ]
[ b ] * [ f ] = a*d + b*f + c*g
[ c ] [ g ]
Векторное произведение:
[ a ] [ d ] [ b*f - c*e ]
AxB = [ b ] x [ e ] = [ c*d - a*f ]
[ c ] [ f ] [ a*e - b*d ]
Сложение матриц:
[ 1 2 3 ] [ 10 11 12 ] [ 1+10 2+11 3+12 ]
[ 4 5 6 ] + [ 13 14 15 ] = [ 4+13 5+14 6+15 ]
[ 7 8 9 ] [ 16 17 18 ] [ 7+16 8+17 9+18 ]
Умножение матриц:
[ 1 2 3 ] [ 10 11 12 ] [ 1*10+2*13+3*16 1*11+2*14+3*17 1*12+2*15+3*18 ]
[ 4 5 6 ] * [ 13 14 15 ] = [ 4*10+5*13+6*16 4*11+5*14+6*17 4*12+5*15+6*18 ]
[ 7 8 9 ] [ 16 17 18 ] [ 7*10+8*13+9*16 7*11+8*14+9*17 7*12+8*15+9*18 ]
Очень важным является тот факт, что (A*B)*С = A*(B*C)
Векторные и матричные преобразования
Параллельный перенос:
Переносим точку (x,y,z) на вектор (dx,dy,dz), в результате получим точку с координатами (x+dx, y+dy, z+dz);
Поворот:
Поворачиваем точку (x,y) на угол ? :
x'= x cos ? - y*sin ?
y' = x sin ? + y*cos ?
для трехмерного случая - аналогично для каждой плоскости.
ясно, что если нам потребуется (а нам потребуется :) ) проводить для каждой точки в пространстве параллельный перенос + поворот в пространстве, то придеться сделать огромное количество преобразований.
можно построить матрицы преобразований, помножив точку - вектор на которую, мы получим результат - координаты искомой точки.
матрица параллельного переноса:
[ 1 0 0 0 ]
[ 0 1 0 0 ]
[ 0 0 1 0 ]
[ x y z 1 ]
матрица растяжения/сжатия:
[ z 0 0 0 ]
[ 0 y 0 0 ]
[ 0 0 x 0 ]
[ 0 0 0 1 ]
матрица поворота вокруг оси x:
[ 0 0 0 0 ]
[ 0 cos ? sin ? 0 ]
[ 0 -sin ? cos ? 0 ]
[ 0 0 0 1 ]
матрица поворота вокруг оси y:
[ cos ? 0 -sin ? 0 ]
[ 0 1 0 0 ]
[ sin ? 0 cos ? 0 ]
[ 0 0 0 1 ]
матрица поворота вокруг оси z:
[ cos ? sin ? 0 0 ]
[-sin ? cos ? 0 0 ]
[ 0 0 1 0 ]
[ 0 0 0 1 ]
теперь - зачем нужны матрицы в 3D-програмировании, если можно все сделать с помощью векторов, и если, например, поворот точки с помощью векторов занимает меньше операций, чем используя матрицы.
например, мы отодвигаем камеру и поворачиваем ее. для этого требуется произвести серию операций (переносов, поворотов) с точками (вершинами полигонов) в 3D-сцене. т.е. для каждой точки произвести сначала параллельный перенос, а затем - повороты по всем осям. при использовании векторов мы просто проведем все эти операции отдельно для каждой точки... что весьма ресурсоемко. или - матричные параллельные переносы, повороты.... еще более ресурсоемко, но вспомним:
(A*B)*C = A*(B*C)
для матриц.. а нам требуется провести такие преобразования: a*A*B*C*D, где - а-точка-вектор, над которым требуется произвести действия, а A,B,C,D - матрицы переноса и поворотов. Мы вполне можем не последовательно умножать точку-вектор a на матрицы переносов, а сначала перемножить эти матрицы, а затем просто умножать получившуюся матрицу на каждую точку, которую требуется сместить - перемножение 4х матриц, а затем умножение 1 вектора на 1 матрицу на каждую точку по сравнению с подвержением каждой точки векторным преобразованиям - весьма и весьма значительное сокращение производимых операций.
Взято с
Основы многопоточности и COM
Основы многопоточности и COM
Многопоточность в COM очень легко понять. На самом деле! Нужно всего лишь потратить время на освоение большого количества новой информации! Одной из "непростительных" причин того, что изучение многопоточности в COM столь трудно, является страх перед хорошо звучащими (но непонятными) словечками, такими как:
подразделения (apartments), однопоточные подразделения (STAs), многопоточные подразделения (MTAs), свободное использование потоков (free threading), маршалинг интерфейса (interface marshaling) и т.д.
Но это все только громко звучащие слова и ничего более. В действительности же имеется множество хорошо определенных правил, которым очень легко следовать для полного понимания многопоточности в COM. Все, что Вам нужно - это знать, что это за правила, выучить их, а затем действительно использовать их в своих приложениях. Я бы хотел начать разговор о первом и наиболее общем правиле, а затем идти дальше и дальше к специфическим правилам далее в этой статье.
Правило #1: Каждое приложение, использующее COM, должно сообщить COM, как оно будет управлять потоками исполнения (никаких если, никаких но). Это правило является важным, так как для того, чтобы COM могла бы взаимодействовать с Вашим приложением или Ваше приложение могло бы взаимодействовать с другими приложениями посредством COM, COM должна знать как правильно делать вызовы объектов Вашего приложения на уровне той потоковой модели, которую Вы указали.
Это имеет смысл, так как COM является тем клеем, который используется приложениями для взаимодействия друг с другом и обеспечивает корректность взаимодействия многопотоковых приложений. COM, по крайней мере, должен знать, как приложения, которые он связывает вместе, управляют многопоточностью. Этот уровень "потоковой трудности" называется потоковой моделью COM.
Для целей этой статьи мы определим 3 потоковых модели. В действительности нет никакой разницы, как их назвать. И так как мы понимаем, что каждая из них представляет из себя, я не буду больше беспокоиться о том, как Вам хотелось бы их называть.
Однопотоковая модель (the single-threaded model)
Если приложение работает в однопотоковой модели, то это означает, что в этом приложении имеется только один поток (thread) исполнения, в котором приложение взаимодействует с COM. Это подразумевает, что COM будет гарантировать взаимодействие с Вашим приложением (производить обращения к нему) таким образом, что не будет одновременных обращений в разных потоках. Когда COM хочет чего-либо от Вашего приложения, он будет производить это только в главном потоке Вашего приложения.
Это также подразумевает, что если у Вас есть однопотоковый сервер COM, который сейчас имеет, скажем, 50 объектов, используемых (разделяемых) 50-ю клиентами и, если все 50 клиентов пытаются вызвать метод каждого объекта в одно и то же время, то COM вмешается и не позволит выполниться 50 потокам на Вашем сервере одновременно. Вместо этого COM сделает так, что вызовы методов будут произведены в одном потоке один после другого, пока все 50 объектов не удовлетворят вызовы 50 методов (и, конечно же, каждый метод будет возвращать результат работы непосредственно после своего завершения).
Как Вы видите в этом примере приведен крайне неэффективный сервер для такого режима его использования. Представьте себе, что каждый метод требует 1 секунду времени для своего завершения. Потребуется, по крайней мере, 50 секунд для обслуживания 50 одновременных обращений и, что еще хуже, пока не будет обслужен первый вызов, никакие другие вызовы обслуживаться не будут.
Верите или нет, но Delphi 3 технически может создавать только однопотоковые внутренние и внешние сервера COM. Хотя это не может выглядеть ограничением для внутренних серверов (DLL), но, поверьте мне, это очень плохо работает в случае с внешними серверами (EXE), когда множество клиентов должны обслуживаться одновременно с разумным временем отклика.
Модель однопотокового подразделения (the single-threaded apartment model - STA)
Не вдаваясь в подробности сейчас (эта модель будет полностью объяснена позже), эта модель позволяет COM взаимодействовать с Вашим приложением в нескольких подразделениях (apartment), каждое из которых содержит в точности один поток(thread). Вы можете подумать: Ух ты! Что за чертовщина это подразделение? Простейшее определение, которое я видел, звучит так: подразделение - это хорошо определенная инкапсуляция того, как потоки и объекты COM взаимодействуют друг с другом. Когда я говорю "инкапсуляция", я подразумеваю, что некоторый поток и некоторый объект, которые должны что-то делать совместно с COM определены в понятии "подразделение", в котором они "живут". Другими словами, Вы не можете описать как поток и объект COM взаимодействуют друг с другом без определения сначала понятия "подразделение", которое содержит как поток, так и объект.
Когда я говорю "хорошо определенная", я подразумеваю, что взаимодействие между данным потоком и данным объектом COM связано набором правил, определяемых типом подразделения, в котором этот поток и этот объект размещены. Мы перейдем к изучению этих правил позже в этой статье, но сейчас давайте просто скажем, что эти правила имеют хорошо определенные спецификации в COM. Давайте сделаем это более понятным путем определения другого правила:
Правило #2: Каждый поток в Вашем приложении, использующий COM, сначала должен войти в подразделение или инициализировать его (никаких если, никаких но).
Если поток вошел в подразделение или инициализировал его, он должен покинуть его до того как завершится сам (никаких если, никаких но). Просто полагайте, что подразделение - это то место, где "живет" поток.
Причиной того, почему поток, использующий COM, должен войти в подразделение, является тот факт, что COM должен внутренне инициализировать себя таким образом, чтобы знать, как правильно взаимодействовать с потоком.
Причиной того, что поток должен покинуть подразделение до своего завершения, является тот факт, что это единственный способ уведомить COM о том, что поток больше не желает использовать это подразделение и что COM теперь может делать все, что ему нужно, чтобы освободить ресурсы, использовавшиеся подразделением.
Если поток входит в подразделение и затем создает объект COM, то этот объект описывается как "расположенный" или "живущий" в этом подразделении (в действительности это не совсем аккуратное определение, но для целей простоты и легкости понимания подразделений давайте сейчас предполагать, что это так). Теперь, если различные потоки (каждый из которых может быть, а может и не быть потоком, первоначально создавшим объект) пытаются манипулировать этим объектом, COM может вмешиваться в их работу с полной уверенностью, что доступ к этому объекту производится именно тем способом, который определяется типом подразделения, в котором он живет.
В чем же заключаются правила однопотокового подразделения? Очень просто!
Во-первых, однопотоковое подразделение (STA) - это подразделение, содержащее только один поток, взаимодействующий с COM.
Во-вторых, если различные потоки пытаются взаимодействовать с STA или, точнее, с объектом COM, живущим в STA, COM будет гарантировать, что все потоки будут обслуживаться по принципу "только один одновременно", единственным потоком, который первым вошел или, что существенно, создал это подразделение.
В-третьих, если Ваше приложение желает использовать модель однопотокового подразделения и потребуется взаимодействие нескольких потоков с COM, то Ваше приложение будет вынуждено создать несколько однопотоковых подразделений, каждое из которых соответствует единственному потоку. Чтобы легче было запомнить эти правила, давайте я приведу пример.
Пусть Вы создали объект COM X в потоке STA. Пусть X имеет один метод с именем Method1. Теперь, если два или более потоков (очевидно, что каждый из них живет в своем STA) пытаются одновременно вызвать X.Method1 в одном экземпляре X, COM в соответствии с моделью STA, будет гарантировать, что X в действительности не бомбардируется одновременными вызовами Method1 в разных потоках. Вместо этого COM обеспечит, что X.Method1 будет вызван первым запросившим потоком, затем следующим, затем еще следующим и т.д. пока ВСЕ вызовы не будут обслужены одним потоком, который первоначально создал подразделение, в котором живет X.
Другими словами, вызовы методов объекта COM, живущего в STA, гарантировано будет следовать последовательно один после другого вне зависимости от того, откуда пришел этот поток.
Теперь, если Вы создадите два экземпляра объекта X, каждый в отдельном STA и вызовите метод X.Method1 в обоих экземплярах одновременно, COM позволит обоим вызовам исполняться одновременно, так как каждый раздельный STA имеет свой собственный поток.
Поэтому основная разница между моделью STA и однопотоковой моделью заключается в том, что при однопотоковой модели может быть только один поток на все приложение, в то время как в модели STA Вы можете иметь несколько потоков, каждый из которых исполняется в собственном STA. Если Вы немного подумаете, то придете к выводу, что однопотоковая модель - это все лишь дегенеративный вариант модели STA, в которой имеется только один STA на все приложение.
Модель многопотокового подразделения (the multithreaded apartment model - MTA)
Модель многопотокового подразделения (MTA) просто является расширением модели STA. Если Вы еще способны следить за мной, легко сделать вывод, что MTA является подразделением, в котором могут размещаться несколько потоков, в то время как в STA в подразделении может размещаться только один поток.
Основная разница между моделями STA и MTA заключается в том, что если Вы создаете объект в MTA и используете его из нескольких потоков, COM осуществляет одновременный доступ к нему в отличие от модели STA, при которой осуществляется последовательный доступ к объекту. Как я уже говорил ранее, тип подразделения определяет, каким образом потоки взаимодействуют с объектами COM, живущими в этом подразделении. Если Вы создаете объект в MTA, COM будет гарантировать, что поступающие вызовы методов могут происходить одновременно из нескольких потоков.
Как Вы можете видеть, программирование объектов, которые Вы собираетесь использовать в модели MTA, должно осуществляться таким образом, чтобы они могли обрабатывать поступающие запросы от любого потока в любое время и, в то же время, сохранять свою целостность. Другое правило, которое Вы должны всегда помнить, заключается в том, что один процесс, взаимодействующий с COM, может содержать только один MTA. Это означает, что если Вам необходимо создать несколько потоков, взаимодействующих с COM в MTA, то каждый из этих потоков должен входить в единственный MTA Вашего процесса.
Мы только что определили 3 различных типа потоковых моделей, доступных в COM.
Однопотоковая модель может быть описана как самая слабая из всех, когда дело касается использования потоков в приложении, т.е. она не позволяет обрабатывать одновременные запросы COM из разных потоков.
Модель однопотокового подразделения (модель STA) немного сложнее, чем однопотоковая модель. Это выражается в том, что она позволяет взаимодействовать COM с несколькими потоками, но может сделать это только путем создания нескольких подразделений. Это подразумевает, что STA не является существенно более сложной, чем однопотоковая модель. При этом каждый STA имеет только один поток, который и будет обрабатывать все взаимодействие с COM в пределах подразделения.
MTA, с другой стороны, является наиболее сложным из всех перечисленных в смысле взаимодействия с COM нескольких потоков. Другими словами, объект, живущий в MTA, говорит внешнему миру "Я сложно устроен! Я могу работать с потоками где угодно и в любое время!".
Перед тем, как продолжить дальше, я бы хотел отметить некоторые термины.
Модель STA часто называется проще как "работающие в одном потоке" (apartment-threaded), а модель MTA как "работающие во многих потоках" (free-threaded). Хотя мне и не хочется использовать эти термины в своей статье, но чувствуйте себя свободно и подменяйте названия моделей STA и MTA на них, если они понятнее для Вас. Это только слова и ничего более!
Правило #3: Объекты COM создаются в потоках, потоки живут в подразделениях, а подразделения живут в процессах.
Первое интуитивно понятно: объект COM может существовать только в том случае, если он создан, объект COM может быть создан только в том случае, если поток желает создать его.
Второе легко понять, применив Правило #2, т.е., если каждый поток, который нуждается во взаимодействии с COM, должен войти в подразделение или инициализировать его, то, следовательно, это подразделение, так сказать, является вместилищем потока.
Третье, подразделения живут в процессах, может не очень легко "визуализовать" до тех пор, пока Вы не начнете писать код, взаимодействующий с подразделениями. Не беспокойтесь, что Вы пока не согласны со мной в том, что подразделения живут в процессах, это придет позже, когда у Вас появится некоторый опыт, а сейчас просто запомните это правило, так как оно понадобится для понимания нижеследующих концепций.
Правило #4: Если клиентское приложение COM задает потоковую модель, не того типа, т.е. несовместимую с типом потоковой модели сервера COM, сам COM гарантирует, что клиент и сервер будут все равно правильно взаимодействовать друг с другом. Другими словами, COM будет учитывать мнение клиента о том, как он может управлять потоками, и также COM будет учитывать мнение сервера о том, как он может управлять потоками. COM возьмет на себя ответственность за "бесшовную" совместную работу клиента с сервером без каких-либо дополнительных усилий по разработке со стороны программиста. Но Вы можете спросить, как COM может делать это? В действительности ответ очень прост:
Правила #1 и #2 предполагают, что если Вы однажды определили потоковую модель и тип подразделения (подразделений), с которыми работает Ваше приложение, то Вы тем самым заключили обоюдное соглашение с COM в том, что Вы и COM должным образом все подготовили в соответствии с правилами. Например, если Вы говорите COM, что Вы хотите поддерживать только однопотоковую модель, то Вы говорите "Эй, COM. Я гарантирую тебе, что я могу обрабатывать любые запросы только в одном потоке. Если ты нуждаешься во мне, ты можешь делать все только в одном потоке. Не допускай ко мне множественные потоки, так как я не готов обрабатывать их!" COM принимает эти слова как молитву и будьте уверены без дополнительных вопросов, что все Ваши запросы будут удовлетворены. Это означает, что если есть два приложения, клиент и сервер, каждое из которых сказал COM, что он может и что не может делать, то COM обезопасит Вас от кровавых разборок между ними, обеспечив тем самым, что запросы будут правильно восприниматься с обоих сторон, когда они начнут взаимодействовать друг с другом. Если COM не делал бы этого, то потоковая работа COM была бы сущим кошмаром. Подумайте об этом!
Так, где это мы сейчас? Мы установили очень важные базовые правила поведения потоков в COM. Если Вы успели заметить, все это было чистой теорией. Я умышленно сделал это, так как когда я исследовал и изучал эту тему, мне пришлось пройти через большое количество программного кода, который не имел никакого смысла. Поверьте мне, Вы не хотите этого делать и даже использовать его до тех пор, пока Вы не поймете наконец, что этот код делает. Если Вы делали это, то Вы уже познакомились с потенциальными проблемами в Ваших приложениях, и Вы можете насчитать множество часов, проведенных за отладкой, пока Вы однажды не открыли для себя, что использование потоков в COM чревато трудно находимыми ошибками. В конце концов я понял, что следует усвоить основы прежде, чем написать некий код, который будет что-либо делать с потоками в COM. Теперь я бы хотел, чтобы Вы внимательно перечитали все то, что мы уже узнали, чтобы быть уверенным, что Вы, по крайней мере, поняли, о чем же идет речь. Если Вы чувствуете себя уверенно после изучения первых четырех правил, то Вы должны быть готовы двигаться дальше к следующим частям, где мы сконцентрируемся на специфических деталях, окружающих первые четыре правила. Готовы?
Модель однопотокового подразделения (
the Single Threaded Apartment Model - STA) В предварительном обсуждении мы установили, что модель STA позволяет Вам разрабатывать многопотоковые приложения COM, в которых каждый поток должен инициализироваться/содержаться внутри своего собственного подразделения. Мы также поняли, что для того, чтобы поток правильно взаимодействовал с COM, он должен сначала войти в подразделение или инициализировать его. Так как же именно поток входит в STA? COM предоставляет функцию CoInitializeEx API для входа потока в подразделение. Синтаксис CoInitializeEx (определенный в ActiveX.pas) следующий:
function CoInitializeEx (pvReserved : pointer; coInit : longint) : HResult; stdcall;
Параметр pvReserved в данном случае бесполезен и должен быть равен NIL. Параметр coInit определяет тип подразделения, в который поток желает войти. Для модели STA Вы должны передавать в качестве этого параметра константу COINIT_APARTMENTTHREADED. Короче, следует писать следующий вызов:
CoInitializeEx (NIL, COINIT_APARTMENTTHREADED);
который позволяет потоку Вашего приложения войти в подразделение STA (инициализировать его). Мы также уже знаем, что если поток вошел в подразделение, то он должен выйти из него до своего завершения. Для выхода из подразделения COM предлагает следующий вызов CoUninitialize API, имеющий следующий синтаксис.
procedure CoUninitialize; stdcall;
Если поток производит вызов CoInitializeEx дважды подряд, то в первом случае возвращается код завершения функции (HResult), равный S_OK. Во второй раз (и во все последующие) будет возвращено значение S_FALSE, при этом никаких действий не производится. Хотя некоторые авторы и не рекомендуют производить лишние вызовы CoInitializeEx (Прим. перев. - так у автора; вероятно должно быть CoUninitialize), мои исследования показывают, что Вам все равно следует обращаться к CoUninitialize ДЛЯ КАЖДОГО вызова CoInitializeEx вне зависимости от того, вернул ли предыдущий вызов S_OK или S_FALSE. Это склоняет меня к мысли, что исполняющая система COM ведет счетчик количества входов в STA одного и того же потока, и позволяет потоку успешно покинуть STA только в том случае, если счетчик входов равен нулю. Например:
begin
// вход в STA
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
// этот второй вызов организует повторный вход в текущий STA
// (возвращает код завершения )
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
// этот вызов закрывает последний CoInitializeEx,
// но выход из STA не производится
CoUninitialize;
// этот вызов закрывает первый CoInitializeEx
// и окончательно покидает STA CoUninitialize;
end;
После входа потока в подразделение недопустимо изменять (или входить по-другому) подразделения до тех пор, пока поток не покинет это подразделение. Это означает, что если поток вошел в STA, а затем производит вызов CoInitializeEx, осуществляющий вход в MTA (вход в MTA обсуждается позже в данной статье), последний вызов CoInitializeEx не будет успешным и вернет код своего завершения, равный RPC_E_CHANGED_MODE ($80010106), означающий "Нельзя изменять тип потока после того, как он был установлен" ("Cannot change thread mode after it is set"). В этом случае Вы не должны производить вызов соответствующего CoUninitialize. Другими словами вызов CoUninitialize должен производиться только в том случае, если вызов CoInitializeEx вернул S_OK или S_FALSE. Если он вернул что-либо другое Вы не должны вызывать CoUninitialize. COM предлагает и более ранний вызов API - CoInitialize, который функционально эквивалентен CoInitializeEx(NIL, COINIT_APARTMENTTHREADED). Синтаксис CoInitialize следующий:
function CoInitialize (pvReserved : pointer) : HResult; stdcall;
Таким образом, следующий вызов очень похож на вызов CoInitializeEx, показанный ранее: CoInitialize(NIL); Другая пара ранних вызовов API, достойная внимания - это OleInitialize и OleUninitialize. OleInitialize эквивалентен CoInitialize, но он инициализирует также и подсистему пользовательского интерфейса COM (такую как "тащи и бросай - drag-and-drop" OLE). OleUninitialize эквивалентен вызову CoUninitialize, но он дополнительно деинициализирует подсистему пользовательского интерфейса COM, инициализировавшуюся вызовом OleInitialize. Это означает, что если Ваше приложение COM использует, скажем, OLE drag-and-drop вызов CoInitialize непригоден; Вам необходимо использовать вызов OleInitialize.
Одно Вам необходимо запомнить. Вызов CoInitializeEx возможен только в DCOM для Windows NT4 или если установлено расширение DCOM для Windows 95. Если Вы производите вызовы CoInitializeEx на машине, не поддерживающей указанных расширений DCOM, Вы будете получать сообщение об ошибке, что данный вызов не поддерживается, а Ваша программа не будет работать. Следовательно, если Вы интересуетесь только моделью STA, использование пары вызовов CoInitialize/CoUninitialize будет давать хорошие результаты вне зависимости от того, установлены у Вас расширения DCOM или нет. Если Вы удивляетесь, почему Вам никогда не требовалось производить вызовы CoInitialize/CoUninitialize в Ваших однопотоковых приложениях на Delphi, то это потому, что они уже были выполнены за Вас модулем ComObj.pas. Модуль ComObj производит вызов CoInitialize(NIL) во время своей инициализации, а вызов CoUninitialize - во время финализации. Это означает, что главный поток Вашего приложения всегда живет в STA.
Важно отметить, что если Вам необходимо создавать другие потоки STA в Вашем приложении, взаимодействующем с COM, то Вы должны делать вызовы CoInitialize/CoInitializeEx/CoUninitialize явно, как это было описано выше. Если Вы забываете сделать это, то получаете ошибочный код завершения CO_E_NOTINITIALIZED ($800401F0), означающий "Не был вызван CoInitialize" ("CoInitialize has not been called") из потока, начинающего взаимодействие с COM.
Мы узнали, что STA должен содержать в точности один поток, и, что в случае попытки множества потоков взаимодействовать с объектом COM, живущим в STA, COM будет уверен, что эти потоки могут обслуживаться только одним потоком, живущим в этом STA, в данный момент времени. Проще, COM всегда будет осуществлять все вызовы в потоке STA последовательно. Этот последовательный процесс возможен потому, что (для STA) COM автоматически создает скрытое системное окно, управляющее всеми системными вызовами для каждого ассоциированного STA. Так в действительности, когда нескольким потокам необходимо произвести одновременные обращения к объекту, живущему в STA, COM странслирует эти вызовы в окно сообщений и поставит эти сообщения в очередь один за другим, т.е. в очередь сообщений одного потока, живущего в Вашем STA. Таким образом, сообщения в очереди могут быть проверены и исполнены по одному Вашим потоком STA. Ваш поток будет всего-навсего пропускать (или передавать) эти сообщения скрытому окну для дальнейшей обработки. Это подводит нас к наиболее важному правилу для STA:
Правило #5: Для того, чтобы сервер STA работал бы правильно, его поток должен включать в себя цикл, непрерывно проверяющий наличие оконных сообщений (windows messages) и, соответственно, их обрабатывающий. Другими словами, следующий фрагмент показывает основы реализации работающего потока STA:
var
rMsg: TMsg;
begin
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
{ главный цикл сообщений потока }
while (GetMessage(rMsg, 0, 0, 0)) do
DispatchMessage(rMsg);
CoUninitialize;
end;
Если Вы планируете создать поток STA, не имеющий цикла обработки оконных сообщений, Вы должны учитывать, что если Вы пытаетесь получить доступ к объекту, созданному в этом STA, из других потоков (очевидно, в других STA), Ваши вызовы не будут успешно выполнены и Ваш вызывающий поток "зависнет". Очевидно, что причина происходящего кроется в том, что мы только что узнали. Я бы хотел подчеркнуть также, что цикл сообщений необходим только с той точки зрения, что Ваш поток STA собирается обслуживать объекты для потоков в других подразделениях. Действительная цель цикла обработки оконных сообщений заключается в том, что COM может выстраивать последовательно все вызовы, приходящие от всех потоков. Другими словами, если Вы собираетесь создать поток STA, который работает с объектами COM внутри того же самого потока, то нет абсолютно никакой нужды в цикле сообщений. Например, если клиентское приложение создает поток STA и внутри этого потока создает объект COM, работает с ним и затем завершает, то нет никакого смысла в цикле сообщений вообще, т.е.
procedure TMySTAThread.Execute;
var
pObject1: IObject1;
begin
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
// Создает объект object1, делает с ним что-то (something) и завершается
pObject1 := CreateOleObject('Server.Object1') as IObject1;
pObject1.DoSomething;
pObject1.DoSomeOtherThing;
pObject1 := nil;
// Цикл сообщений не нужен, так как мы уже все сделали
CoUninitialize;
end;
Очевидно, что если Вы планируете использовать модель STA в Вашем приложении, то по существу говоря это приложение является многопоточным, в котором каждый поток живет в отдельном STA. Это означает, что для COM имеется возможность делать одновременные вызовы Вашего приложения, если оно создает несколько STA (отметьте существенную разницу: для каждого STA вызовы выстраиваются последовательно, но в целом приложение может иметь несколько STA, вызовы к которым могут поступать одновременно). Это приводит нас к другому правилу, весьма важному для STA:
Правило #6: Благодаря модели STA Ваши объекты STA могут защищать некоторые глобальные (в масштабах приложения) данные, которые могут быть разрушены при одновременном доступе множества объектов из раздельных потоков. Любые данные, характерные для данного экземпляра (обычно это поля, содержащиеся в объявлении класса Вашего объекта), уже являются потоково-безопасными и не нуждаются в защите. Для иллюстрации сказанного рассмотрим следующее:
var
iGlobal: integer;
type
TObject1 = class(TAutoObject)
protected
FLocal: integer;
procedure AccessGlobal;
procedure AccessLocal;
end;
procedure TObject1.AccessGlobal;
begin
// Если создается несколько экземпляров TObject1 в раздельных STA и
// AccessGlobal вызывается в каждом из них одновременно, то возможно,
// что iGlobal будет испорчена
// делаем что-либо с глобальной переменной
iGlobal := iGlobal + 1;
end;
procedure TObject1.AccessLocal;
begin
// Если создается один экземпляр TObject1 в STA и множество потоков
// пытаются вызвать AccessLocal в этом единственном экземпляре,
// то локальная переменная гарантировано не будет испорчена, так как
// COM обеспечит, что вызовы AccessLocal следуют последовательно
// друг за другом в пределах одного потока, живущего в этом STA
// делаем что-либо с локальной переменной
FLocal := FLocal + 1;
end;
Следовательно, правильным способом исправить TObject1.AccessGlobal является сделать переменную iGlobal защищенной от одновременного доступа из нескольких потоков STA. Простейший способ сделать это - это использовать критические секции Win32, которые обслуживаются операционной системой для таких случаев (я буду полагать, что Вы уже знаете некоторые основы потоков и функций работы с ними, существующие в Win32. Вы должны обратиться к книгам, если Вы чувствуете пробел в своих познаниях в этом месте. Вот книга, которую я нашел достаточно полезной "Win32 Multithreaded Programming"; Cohen и Woodring, O`Reilly, ISBN 1-56592-296-4).
Тогда TObject1.AccessGlobal может быть переписана следующим образом:
uses
SyncObjs;
var
csGlobal: TCriticalSection;
iGlobal: integer;
procedure TObject1.AccessGlobal;
begin
// вход и выход из критической секции теперь гарантирует, что доступ
// к iGlobal может быть осуществлен одним потоком единовременно и
// невозможно разрушение при доступе из различных потоков
csGlobal.Enter;
try
// делаем что-либо с глобальной переменной
iGlobal := iGlobal + 1;
finally
csGlobal.Leave;
end; { finally }
end;
initialization
csGLobal := TCriticalSection.Create;
finalization
csGlobal.Free;
end.
Стороннее замечание
. Delphi предоставляет в Ваше распоряжение класс TCriticalSection, являющийся оболочкой для примитивов критической секции Win32. TCriticalSection располагается в модуле SyncObjs, который, как я знаю, существует только в версии клиент/сервер Delphi. Если Вы не располагаете приобретенной копией клиент-серверной версии Delphi (как я), не все потеряно:Вы можете использовать класс TCriticalSection из библиотеки ThreadComLib этой статьи или, если Вы чувствуете в этом силу, использовать вызовы Win32 API.
Подведем небольшой итог. Я как всегда отмечаю, что к объекту COM, живущему в STA можно получить доступ из множества потоков, живущих в других STA и что в случае одновременного доступа к нему все потоки выстраиваются в очередь вне зависимости от того, откуда этот поток пришел. Я Вам еще не сказал, что это гарантируется самим COM, но для того, чтобы COM имел возможность правильно исполнить эту возможность, Вы со своей стороны должны проделать некоторую работу.
Для ясности в будущем, давайте предположим, что Вы имеете два потока STA в Вашем клиентском приложении и Вы создаете объект COM в первом потоке. Если Вы хотите, чтобы второй поток имел возможность доступа к этому же объекту (созданному в первом потоке), то Вы не можете просто получить указатель на интерфейс к объекту (созданному из первого потока) и начать вызывать его методы. Что Вы должны делать или, что более важно, COM позволяет делать Вам - это получить указатель на интерфейс и каким-то образом транслировать его из потока 1 в поток 2 так, чтобы когда поток 2 попытается получить доступ к этому интерфейсу COM знал бы, что этот интерфейс действительно используется вторым (отличным от первого) потоком и, таким образом, чтобы он знал о необходимости установления очередности с первым STA. Чтобы не забыть, сформулируем это в виде правила:
Правило #7: Для обеспечения корректного доступа к объектам COM множества потоков в РАЗДЕЛЬНЫХ подразделениях, указатель на интерфейс к этому объекту должен маршалироваться (транслироваться) из подразделения, в котором этот объект живет, в подразделение, в котором должен производиться доступ. Конечно, если доступ к объекту производится из своего собственного подразделения, то нет нужды ни в каком маршалинге, хотя это и не повредит. Причина этого заключается в том, как мы уже говорили ранее, что подразделение имеет хорошо определенный набор правил, как следует предоставлять доступ к объектам, живущим в нем. Для того, чтобы доступ к объекту потоками из других подразделений осуществлялся должным образом, Вы должны, когда понадобится доступ к объекту из другого подразделения, явно объявить COM, что правила доступа к этому объекту установлены корректно. Если Вы забываете производить маршалинг через подразделения при доступе к объектам COM и пытаетесь манипулировать простым указателем на интерфейс, COM выдаст Вам ошибку с кодом RPC_E_WRONG_THREAD ($8001010E), означающую "Приложение вызвало интерфейс, маршалированный для другого потока" ("The application called an interface that was marshaled for a different thread").
Когда Вы маршалируете указатель на интерфейс из подразделения источника в целевое подразделение, Вы экспортируете указатель из подразделения источника и затем импортируете тот же указатель в целевое подразделение. Такой процесс экспорта-импорта приводит к тому, что целевое подразделение получает нечто, называемое заместителем или прокси (proxy) интерфейсным указателем на оригинальный указатель на интерфейс. Для всех целей прокси ведет себя точно так же, как и оригинальный указатель на интерфейс, т.е. Вы можете вызывать методы через прокси так же, как это производится и через настоящий указатель на интерфейс. Единственная разница, которую Вам потребуется знать, заключается в том, что вызовы через прокси делаются медленнее (иногда существенно медленнее), чем вызовы, производимые через настоящий указатель не интерфейс. Экспорт и импорт указателя на интерфейс в действительности не столь сложен. COM предлагает две простых функции API для маршалинга указателей на интерфейс:
CoMarshalInterThreadInterfaceInStream - для экспорта/маршалинга и
CoGetInterfaceAndReleaseStream - для импорта/демаршалинга.
Демаршалинг Вам необходимо производить потому, что процесс маршалинга записывает указатель на интерфейс в поток (stream) (вместе с другой информацией, однозначно иденцифицирующей размещение объекта COM, на который ссылается указатель), а следовательно, Вам придется изымать его оттуда (демаршалировать) в допустимый прокси указатель на интерфейс.
Синтаксис CoMarshalInterThreadInterfaceInStream следующий:
function CoMarshalInterThreadInterfaceInStream (const iid: TIID; unk: IUnknown; out stm: IStream): HResult; stdcall;
IID
идентификатор интерфейса (ID), который Вы хотите маршалировать.Unk - это указатель на интерфейс IUnknown объекта, чей интерфейс Вы хотите маршалировать.
Stm - это переменная IStream, в которой будет содержаться указатель на маршалируемый интерфейс, Вы не должны запрашивать какую-либо память для Stm, так как COM сделает это за Вас.
Синтаксис CoGetInterfaceAndReleaseStream следующий:
function CoGetInterfaceAndReleaseStream (stm:IStream; const iid:TIID; out pv) : HResult; stdcall;
Stm
- это переменная IStream, которая используется Вами при маршалинге указателя на интерфейс; COM автоматически освобождает память Stm после завершения вызова.IID идентификатор интерфейса (ID), который Вы хотите маршалировать.
Pv - переменная, в которой хранится прокси указатель интерфейса до успешного завершения демаршалинга. Следующий фрагмент иллюстрирует, как маршалируется указатель на IDispatch из потока 1 в поток 2 различных STA:
var pStream : pointer;
В потоке 1:
procedure DoMarshal;
var pObject1: IDispatch;
begin
pObject1 := CreateOleObject('Server.Object1'); CoMarshalInterThreadInterfaceInStream(IDispatch, pObject1 as IUnknown, IStream(pStream));
end;
В потоке 2:
procedure DoUnmarshal;
var pObject1 : IDispatch;
begin
CoGetInterfaceAndReleaseStream(IStream(pStream), IDispatch, pObject1); pObject1.DoSomething;
end;
Отметьте, что в маршалинге важна последовательность производимых действий:
сначала указатель на интерфейс должен быть маршалирован в потоковой переменной, и только после этого второй поток может демаршалировать его. Я также объявил pStream как указатель вместо IStream и делаю явное преобразование типов IStream (pStream), так как мы хотим предотвратить автоматический подсчет ссылок в Delphi, из-за которого у нас могли бы возникнуть проблемы - функции маршалинга Win32 API неявно создают и освобождают указатель на IStream (pStream).
Теперь, когда мы приколотили основные идеи модели STA, мы готовы двигаться дальше к следующей ступени понимания: как клиенты COM и сервера взаимодействуют между собой во владениях модели STA. Этот шаг приводит к теме, возможно, являющейся одной из самых важных (и наиболее неподдающейся пониманию) тем в потоковой модели COM. Поэтому я буду предполагать, что Вы замедлили чтение на этом месте. Постарайтесь восстановить в памяти полную картину прочитанного и, если необходимо, перечитайте еще раз.
Внешний (EXE) сервер, поддерживающий модель STA, обычно создает несколько потоков STA для своих объектов. Простейшей реализацией сервера STA является создание раздельных потоков STA для каждого экземпляра каждого объекта, создающихся средствами этого сервера. Другими словами, если клиент 1 создает Server.Object1, а клиент 2 создает Server.Object2, оба с помощью одного сервера STA, то сервер может просто создать два потока STA: первый, в котором будет жить объект Object1, и второй, в котором будет жить Object2. Таким образом, если клиент 1 и клиент 2 одновременно вызывают методы объектов Object1 и Object2 соответственно, то сервер в действительности будет обслуживать одновременно оба вызова к обоим объектам в двух потоках STA. Простейшим способом для сервера создать по потоку STA на каждый экземпляр является запуск некоего процесса, в котором COM попросил бы сервер создать новый экземпляр объекта. Запустив такой процесс, сервер может затем породить новый поток STA, имея такой поток - создать экземпляр во время исполнения его метода Execute, а затем вернуть указатель на этот экземпляр COM (а следовательно, и клиенту). Для объектов автоматизации Delphi этот процесс может быть воспроизведен в методе TAutoObjectFactory.CreateInstance, использующемся при реализации IClassFactory.CreateInstance. Следующий псевдокод иллюстрирует этот процесс:
type
TSTAAutoObjectFactory = class(TAutoObjectFactory, IClassFactory)
function CreateInstance;
end;
TSTAThread = class(TThread)
procedure Execute; override;
end;
function TSTAAutoObjectFactory.CreateInstance;
begin
Создает и порождает новый экземпляр TSTAThread;
Заставляет поток STA создать затребованный объект
Ждет, пока поток STA успешно создаст объект
Возвращает созданный экземпляр в качестве результата этого метода
end;
procedure TSTAThread.Execute;
begin
// Вход в STA
CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
Создает экземпляр, затребованный TSTAAutoObjectFactory;
Сигнализирует потоку TSTAAutoObjectFactory.CreateInstance, что экземпляр теперь доступен
Вход в цикл сообщений STA
// Выход из STA
CoUninitialize;
end;
Этот процесс теоретически очень прост, но что Вы могли еще не разглядеть, так это то, что каждый поток STA должен знать, как и когда необходимо прекращать существование всех уже несуществующих объектов COM, живущие в нем, т.е. уже не имеют ссылок к ним от клиентов. Причина этого очевидна: потоки потребляют системные ресурсы и, следовательно, должны быть приняты все меры для того, чтобы каждый поток в приложении завершался бы должным образом, если в нем больше нет нужды. Под "завершался должным образом" я подразумеваю, что Вы должны использовать вызов TerminateThread Win32 API для завершения потоков и выполнить все проверки, убеждаясь, что метод Execute Вашего наследника TThread полностью завершился, так как в противном случае часть использовавшихся ресурсов окажется не освобожденной. Одним из способов решения этой проблемы является организация счетчика всех объектов на поток STA, на самом деле на подразделение. Кто-то также должен отслеживать состояние этого счетчика при создании и ликвидации объектов в этом подразделении. При этом, как только счетчик станет равным нулю, мы можем безопасно прекращать все потоки, живущие в данном подразделении. Вот псевдокод для этого процесса:
type
TSTAAutoObject = class(TAutoObject)
procedure Initialize; override;
destructor Destroy; override;
end;
procedure TSTAAutoObject.Initialize;
begin
inherited;
Увеличение счетчика объектов для STA, в котором живет экземпляр;
end;
destructor TSTAAutoObject.Destroy;
begin
inherited;
Уменьшение счетчика объектов для STA, в котором живет экземпляр;
Если счетчик объектов STA = 0
то сигнализировать потоку STA о необходимости завершения;
end;
Для серверов STA создание нового потока STA для экземпляра не всегда может быть лучшим выбором. Как я уже говорил ранее потоки потребляют некоторые системные ресурсы, и если, например, клиенты могут создавать одновременно тысячи экземпляров объектов (а, стало быть, и тысячи потоков STA), то, соответственно, производительность компьютера, на котором работает Ваш сервер, существенно "провалится". Одним из способов гарантировать, что такое не произойдет с сервером STA, является определение каким-то образом максимального числа потоков STA, а затем, когда этот максимум превышен, начать повторное использование существующих потоков STA для обслуживания потребностей новых объектов. Такая технология называется "пул потоков STA" (STA thread pooling). При этом устанавливается предопределенное максимальное количество потоков STA и, когда количество созданных потоков STA превышает это число, новые экземпляры создаются путем использования уже существующих потоков STA из пула. Этот процесс иллюстрируется следующим псевдокодом:
type
TSTAAutoObjectFactory = class(TAutoObjectFactory, IClassFactory)
function CreateInstance;
end;
function TSTAAutoObjectFactory.CreateInstance;
begin
if (Количество потоков STA в сервере < макс.допустимого числа потоков STA) then
Создать и породить новый экземпляр TSTAThread
else
Выбрать произвольный поток STA из пула существующих;
Здесь поток STA создает затребованный объект
Ждет, пока поток STA успешно создаст объект
Возвращает созданный экземпляр в качестве результата этого метода
end;
Для клиента STA, взаимодействующего с внешним сервером STA, все намного проще. Все, что нужно делать клиенту, это создавать объекты в любых, созданных клиентом потоках STA, а сервер STA будет заботиться о деталях того, как создавать или размещать потоки STA, в которых в действительности живут объекты. Необходимо заметить важную деталь: когда клиент создает объект из сервера STA, в действительности имеются два подразделения, один на сервере, где собственно находится объект, и второй - в клиенте, где размещаются другие клиентские STA, "ощущаемые" как объекты. В действительности клиентский STA содержит прокси, маршалирующий кросс-процесс от сервера к клиентскому приложению. Если клиентский поток STA создает объект из внешнего сервера STA и передает указатель на этот объект (очевидно в режиме маршалинга) второму клиентскому потоку STA, COM будет уверен, что второй STA будет использовать объект по правилам подразделения внешнего сервера, откуда обычно создается этот объект.
Если Вы сейчас находитесь в замешательстве, то имеется простой технический прием, который очень просто расскажет Вам, в каком подразделении живет этот объект. Посмотрите на объект, живущий в подразделении с той точки зрения, откуда пришел оригинальный указатель на интерфейс. Так, если в своем клиентском приложении Вы создаете объект в потоке 1 STA и затем используете этот объект из потока 2 STA, то говорят, что объект размещается в STA, в котором живет поток 1, так как оригинальный указатель на интерфейс к этому объекту получаем из этого подразделения. Но, если этот серверный объект размещается во внешнем сервере, то говорят, что объект размещается в STA внешнего сервера, где он располагался первоначально. Всегда помните это технический прием с указателем на интерфейс, так как Вам придется пользоваться им каждый раз, когда у Вас не будет уверенности, в каком из подразделений живет объект.
Мы до сих пор говорили в основном о внешних серверах, давайте теперь поговорим о внутренних серверах (DLL). Обычно STA внутренних серверов не создают явно потоков STA для своих объектов. Причина этого в том, что DLL фактически является просто пассивной библиотекой кода (и данных), отображенной в адресное пространство Вашего клиентского приложения. Поэтому внутренний сервер в действительности эквивалентен любому другому модулю Вашего приложения, однажды отображенным в адресное пространство приложения и, следовательно, все STA, создаваемые клиентом есть то же самое, что и STA, видимые из внутреннего (DLL) сервера. Другими словами, внутреннему серверу вовсе нет нужды активно создавать подразделения и потоки для того, чтобы обслуживать клиента. Что, однако, необходимо, так это (см. Правило #1) объяснить COM, какую потоковую модель он поддерживает или какие типы подразделений его объекты могут обслуживать. STA внутреннего сервера сообщает COM свою потоковую модель путем использования входов системного реестра (registry) для CLSID, регистрируемых для их компонентных классов CoClasses. Точнее, объект во внутреннем сервере, способный размещаться в STA должен добавить строковый параметр "ThreadingModel=Apartment" к параметру HKCR\CLSID\\InprocServer32. Таким образом внутренний сервер, содержащий Object1, поддерживающий STA, должен иметь следующие входы реестра:
[HKCR\CLSID\\InprocServer32](Default)=Server.dll
[HKCR\CLSID\\InprocServer32]ThreadingModel=Apartment
Что же делает строка "ThreadingModel=Apartment"? Все просто! Указывая ThreadingModel как Apartment сообщаем COM, что когда COM (или клиент) создает Object1, COM может и будет безопасно создавать Object1 непосредственно в том STA, в которое поступил запрос клиента на создание. Это означает, что если клиент создает два потока STA, каждый из которых использует Object1, COM будет счастливо создавать каждый экземпляр так, чтобы он жил в клиентском STA, затребовавшем его создание. Отметьте различия с внешним сервером: внешний сервер явно создает потоки STA, в которых будут жить объекты, в то время как внутренний сервер полагается на COM при определении, в каком STA (или в каком подразделении) необходимо создать объект. Поэтому в действительности внутреннему серверу необходимо иметь строковый параметр ThreadingModel в системном реестре, так как при этой схеме отсутствуют структуры, ответственные за создание потоков STA для их объектов. Следовательно, они должны сказать кому-то, кто отвечает за это (в нашем случае COM), как и где эти объекты могут безопасно жить. Для иллюстрации значимости параметра ThreadingModel, давайте взглянем, что делает Delphi для Ваших внутренних серверов.
Если Вы попробуете посмотреть параметр InprocServer32 для Вашего внутреннего сервера, сделанного на Delphi, Вы увидите, что параметр ThreadingModel отсутствует (у Delphi 3 ThreadingModel отсутствует в COM VCL, в Delphi 4 эта возможность включена). Что это значит?
Ну, одно, что можно сказать уверенно, это то, что он не поддерживает потоковую модель STA, однако можно указать "ThreadingModel=Apartment". Так что же случится, если Ваше клиентское приложение создает два потока STA, каждый из которых создает экземпляр, скажем, объекта Object1, который не имеет определенного параметра ThreadingModel? Опять все просто! Отсутствие строкового параметра ThreadingModel означает, что Ваш внутренний сервер поддерживает только однопотоковый режим работы для своих объектов. Другими словами, если имеются два клиентских потока STA, каждый из которых пытается создать экземпляр объекта Object1, COM будет видеть, что Object1 может поддерживать только однопотоковый режим работы и не будет создавать каждый экземпляр непосредственно в каждом клиентском потоке. Что COM будет делать, так это создавать оба экземпляра в одном STA (один STA является техническим определением и реализацией однопотокового режима, в котором имеется только одно подразделение и только один поток в этом одном подразделении) и затем маршалировать (вспомните маршалинг...) указатель на каждый экземпляр из этого STA к STA клиентов, затребовавшим создание этого объекта. Теперь возникает вопрос: COM создает новый STA для содержания обих (и всех прочих) экземпляров или COM только использует один из существующих STA в Вашем клиенте и этот STA используется везде, где необходимо создавать объекты? В этом случае, так как клиент работает на основе STA, COM будет использовать один из STA Вашего клиента, причем это будет главный STA, для доступа ко всем объектам внутреннего сервера. STA, который "зацепит" COM для этой цели - это первый STA, который создает клиентское приложение. Первый STA, создаваемый Вашим клиентским приложением называется главным STA. И последнее, что я бы хотел отметить в связи со строковым параметром ThreadingModel. Строковый параметр ThreadingModel - это только способ, с помощью которого внутренний сервер говорит COM, что он может безопасно поддерживать конкретную потоковую модель. Это означает, что ни при каких обстоятельствах нельзя играть (или даже думать об этом), изменяя параметр ThreadingModel на какое-либо другое значение, до тех пор, пока Вы не будете совершенно уверены, что Ваши объекты могут безопасно обслуживать тот режим, который Вы указали. Поверьте мне, что если Вы поступаете так и думаете, что Ваш внутренний сервер продолжает прекрасно работать, то Вы будете сильно огорчены, услышав, что у Ваших клиентов Ваше приложение начало сбоить, выдавая случайные сообщения о нарушениях защиты памяти, а у Вас не будет никаких мыслей по этому поводу. Другими словами, если Delphi (Delphi 3) не помещает параметр ThreadingModel в системный реестр, то на это имеются причины, и Вы должны сначала определить, что это за причины, прежде, чем Вы начнете изменять параметр ThreadingModel на "Apartment." Из последнего абзаца Вы могли заметить, что каждый клиентский поток STA получает заместителя (proxy), если сервер является однопотоковым. Когда поток подразделения получает заместителя указателя на интерфейс к объекту, это означает две вещи: первое, любой доступ, производимый к этому объекту, замедляется с использованием заместителей (proxy) в сравнении с прямым доступом и, второе, если этот заместитель предназначен для объекта, живущего в STA, то есть большие шансы того, что производительность этого объекта будет очень плохой, если в том же самом STA живут еще несколько объектов. Причина этого в том, что вызовы в этом единственном STA выстраиваются последовательно, и если, скажем, Вы имеете 50 клиентских потоков STA, и они одновременно обращаются к объектам, живущим в одном серверном STA (в случае DLL, 49 клиентов в действительности пользуются заместителями и только один имеет прямой указатель, потому что он является главным STA клиента), COM будет вмешиваться и обслуживать этим единственным потоком STA все вызовы всех потоков один за одним последовательно. Именно в этом кроется причина, почему модель STA, разрешающая Вам создавать много потоков STA, была введена в качестве средства повысить производительность однопотоковых приложений COM. Теперь, когда мы твердо усвоили, что такое STA, давайте перейдем к следующей части, в которой мы узнаем, как модель MTA продвигает нас дальше к новым возможностям потоков для увеличения производительности наших объектов COM.
Модель многопотокового подразделения (the Multithreaded Apartment Model - MTA)
Если Вы полностью разобрались в модели STA, то можно быть уверенным, что изучение модели MTA будет просто кусочком торта. Мы говорили ранее, что модель MTA, подобно модели STA, также позволяет разрабатывать многопотоковые приложения COM. Единственно, в чем заключается основная разница между моделью MTA и другими моделями, это то, что модель MTA разработана для получения максимальной производительности Ваших приложений COM. Я должен предупредить Вас, что модель MTA предоставляет Вам максимальную производительность в обмен на большую ответственность со стороны программиста в том, что объекты в действительности могут работать в архитектуре MTA. Следовательно, как и в случае с STA, я не буду, повторяю, не буду рекомендовать разрабатывать приложения COM, поддерживающие модель MTA, до тех пор, пока у Вас не появится совершенно точное понимание того, как работает модель MTA. В соответствии с этим, я имею в виду, что если Вы думаете, что это крутая штука и просто переключаете Ваш работающий сервер STA в режим MTA (простой заменой вызовов CoInitializeEx или изменением строкового параметра ThreadingModel) в надежде, что это будет лучше, то лучше приготовьтесь потерять какое-то время на основательную повторную отладку своего сервера. Первое, что Вам необходимо знать, это то, как поток входит в MTA. Поток, запрашивающий вход в MTA или его инициализацию, использует тот же вызов CoInitializeEx API, но теперь нам необходимо использовать константу COINIT_MULTITHREADED вместо константы COINIT_APARTMENTTHREADED, использовавшейся для STA. Следующий вызов позволяет потоку войти в MTA:
CoInitializeEx (NIL, COINIT_MULTITHREADED);
Из Правила #2 мы уже знаем, что если нам необходимо создать несколько потоков, использующих MTA, то каждый из этих потоков должен вызвать CoInitializeEx(NIL,COINIT_MULTITHREADED). Архитектура MTA спроектирована таким образом, что может быть только один MTA на процесс, и, если несколько потоков входят в MTA, все они живут в этом самом единственном MTA. Почему так?
Правило #8: Модель MTA позволяет достичь максимальной производительности предоставляя потокам возможность управлять объектами COM непосредственно (т.е. без использования прокси/заместителей) в силу того, что объекты живут в MTA и потоки также живут в том же MTA. Другими словами, если есть 50 потоков, входящих в MTA, и один из них создает объект COM (поддерживающий модель MTA), то, по определению модели MTA, все 50 потоков могут непосредственно и одновременно получать доступ к этому одному объекту без необходимости маршалинга указателя на интерфейс объекта из одного потока в другой. Теперь, если Вы оглянетесь назад на Правило #7, то увидите, что я специально указывал, что маршалинг необходим только в случае, когда производится доступ к объекту из одного подразделения в другое, и поэтому Правило #7 остается справедливым и для случая модели MTA, так как множество потоков, живущих в MTA, на самом деле находится в одном подразделении и, следовательно, не происходит кросс-доступ между подразделениями. Правило #8 является гарантией COM для MTA. Эта гарантия означает, что Вы можете держать пари, что COM будет производить все вызовы Вашего объекта в разных потоках в одно и то же время, и, следовательно, Вы должны быть уверены, что Вам удастся удержать целостность Вашего объекта в то время, когда он бомбардируется вызовами, приходящими из различных потоков. Чтобы выделить это, сформулируем следующее правило:
Правило #9: Объект MTA не может делать никаких предположений о том, когда и какими потоками он будет вызван. Следовательно, Ваш объект MTA должен обеспечивать защиту как глобальных, так и специфических для экземпляра данных, которые потенциально могут быть разрушены в результате одновременного доступа к объектам различных потоков. В качестве простого примера рассмотрим сервер MTA, содержащий объект Object1, имеющий метод Method1. Если клиент создает объект Object1 и производит два вызова метода Method1, то уже для второго вызова может случиться так, что он придет из потока, отличного от того, в котором был выполнен первый вызов. Жуть, не так ли? Т.е. Вы видите, что отсутствие последовательности вызовов обеспечивает максимум производительности, но отсутствие последовательности же вызовов означает больше работы для обеспечения целостности объекта.
Из Правил #8 и #9 очень легко заметить, что поддержка модели MTA практически применима лишь в ситуации, когда Ваши объекты являются чисто служебными объектами, т.е. они не работают интенсивно с какими-то глобальными или специфичными для экземпляра данными, или когда большинство вызываемых/используемых методов Вашего объекта не требует какого-либо кода для защиты данных от разрушения при взаимодействии нескольких потоков. Я хочу сказать, что выбор модели MTA должен быть результатом осознанного решения, основанного на том, как будут использоваться Ваши объекты. Если Ваши объекты не могут обслуживать одновременный доступ из нескольких потоков к одному экземпляру объекта на достаточном уровне для использования выгоды в скорости, предоставляемой моделью MTA, а Вы думаете об использовании модели MTA, то это значит, что Вы либо не знаете, что Вы делаете, либо имеете уйму времени на занятия бессмыслицей. Конечно, Вы всегда можете взять объект STA, просмотреть все методы и защитить от совместного доступа все поля и глобальные переменные критическими секциями и тогда переключить его в режим MTA. Но
Ваш объект MTA будет работать так же, как и в "старом" варианте STA
Вы вынуждены будете написать существенно больше кода.
Другая важная вещь, которую Вы должны знать об MTA заключается в том, что COM не будет выстраивать последовательно вызовы к потоку MTA. Это означает, что нет скрытого окна, как в случае с STA, и, следовательно, Ваш MTA не нуждается в цикле обработки сообщений для своег функционирования. В действительности внешнему серверу MTA, содержащему только объекты MTA, нет необходимости иметь цикл обработки сообщений ни в каком из потоков, даже в главном. Что, однако, необходимо, так это сохранить себя в рабочем состоянии, если имеется хотя бы одна ссылка к какому-либо из экземпляров объекта, т.е. значение блокирующего счетчика больше нуля, и способ сигнализировать главному потоку о том, что счетчик стал равен нулю. Вне зависимости от того, какой из способов Вы предпочтете для реализации этого, всегда необходимо помнить, что поток MTA не нуждается в цикле обработки сообщений.
Теперь, когда мы крепко усвоили основы MTA, давайте посмотрим, как клиентское и серверное приложения взаимодействуют друг с другом в условиях модели MTA. Процесс создания объектов MTA во внешнем сервере намног проще, чем в модели STA. Когда бы клиент не затребовал у внешнего сервера MTA создание объекта, у сервера нет необходимости порождать новый поток и делегировать создание этого объекта этому потоку, как это мы делали для сервера STA. Причина этого в том, что COM создает пул потоков, который будет использоваться для управления вызовами Ваших объектов MTA.
Этот пул потоков, иногда называемый пулом потоков RPC (удаленный вызов процедуры - Remote Procedure Call - низкоуровневая реализация вызовов COM времени исполнения для межпроцессного взаимодействия), внутренне создается и управляется COM и не зависит от того, как реализован Ваш сервер MTA. Другими словами главному потоку Вашего сервера MTA достаточно только вызвать при запуске CoInitializeEx(NIL, COINIT_MULTITHREADED) и нет нужды вмешиваться в процесс "обживания" объекта, что означает, что Вам достаточно правильно создать объекты в главном потоке, в который входит MTA. Теперь, хотя Ваш объект и был создан в главном потоке Вашего сервера, нет необходимости, чтобы Ваш объект принимал поступающие вызовы в этом потоке. COM будет использовать внутренний пул RPC при распределении запросов клиента к Вашему объекту. Это и есть та причина, почему объекты MTA не могут делать никаких предположений о том, какой поток сейчас производит вызов какого-то метода.
Внутренний сервер MTA сообщает COM, что его объекты могут жить в MTA, обозначив строковый параметр в системном реестре как "ThreadingModel=Free." Таким образом, внутренний сервер, содержащий объект Object1, поддерживающий MTA должен содержать следующий входы системного реестра:
[HKCR\CLSID\\InprocServer32](Default)=Server.dll
[HKCR\CLSID\\InprocServer32]ThreadingModel=Free
Назначив параметру ThreadingModel значение Free, сервер, в основном, сообщает COM, что когда бы клиентский поток MTA не захотел создать объект Object1, COM может двигаться вперед и создавать экземпляр Object1 прямо в клиентском MTA. Под "прямо" я подразумеваю, что клиентский поток получит непосредственно указатель на интерфейс (а не заместителя) объекта Object1. Все остальные потоки, входящие в MTA позже, могут свободно осуществлять доступ к объекту Object1, как будто они сами создали объект Object1, т.е. они все управляют объектом Object1, используя прямые ссылки. Это означает, что все клиентские потоки в MTA гарантируют максимальную производительность объекта Object1 при использовании модели MTA.
Заметьте, что я сказал максимум производительности потому, что все потоки могут одновременно делать вызовы к методам объекта Object1, а объект Object1 может счастливо обслуживать все вызовы одновременно в противоположность последовательному процессу (который делает "одновременное" обслуживание нескольких клиентов существенно медленнее), производимому COM, если бы Object1 жил в STA.
К этому моменту мы уже посмотрели на STA, изучили MTA и узнали, как клиентское и серверное приложения взаимодействуют в условиях моделей STA и MTA. Но прежде, чем Вы назовете себя гуру потоковых моделей COM, имеется еще одна штука, которую необходимо принять во внимание: как клиенты и сервера различных потоковых моделей взаимодействуют между собой. Если Вы вспомните, Правило #4 устанавливает, что COM работает аккуратно, гарантируя, что два приложения с несовместимыми потоковыми моделями могут и будут правильно взаимодействовать друг с другом. Что я Вам еще не сказал, так это как в действительности COM устраивает это. Для того, чтобы понять весь процесс целиком, давайте пройдем через несколько сценариев комбинаций потоковых моделей и посмотрим, как COM поступает при каждом из этих сценариев.
Особенности работы события onActivate
Особенности работы события onActivate
Наверное многие заметили, что событие onActivate формы ведет себя по странному, иногда происходит его активация просто при приобретении формой фокуса, а иногда событие происходит только в случае, когда форма становится видимой?
Виной тому виндовые API. Помните начиная с 98 виндов возникла фича - когда активация окна приводит к мельканию заголовка в таскбаре. Под win95/NT4 событие формы onActivate происходит только в момент показа формы (Show, ShowModal), а в остальных осях может возникать и просто при попадании фокуса на форму (уж не знаю почему, но не всегда). Есть хороший способ избавиться от такого поведения и заставить это событие возникать только 1 раз при активации формы и в дальнейшем только тогда когда это нужно.
Procedure TForm1.Form1OnActivate(Sender:TObject);
begin
OnActivate:=nil;
{здесь ваш код обработки события}
end;
Чтоб подготовить обработку события если она ожидается надо вновь присвоить событию процедуру обработки
OnActivate:=Form1OnActivate;
Автор ответа: Vit
Взято с Vingrad.ru
Открытие MDI-окон определенного размера
Открытие MDI-окон определенного размера
var
ProjectWindow: TWndProject;
begin
If ProjectActive=false then
begin
LockWindowUpdate(ClientHandle);
ProjectWindow:=TWndProject.Create(self);
ProjectWindow.Left:=10;
ProjectWindow.Top:=10;
ProjectWindow.Width:=373;
ProjecTwindow.Height:=222;
ProjectWindow.Show;
LockWindowUpdate(0);
end;
end;
Используйте LockWindowUpdate перед созданием окна и после того, как создание будет завершено.
Взято с
Отладка экспертов
Отладка экспертов
Debug Delphi 3 experts with Delphi 3
Delphi 3 has a new feature "debug DLLs". It can be used to debug experts with the internal debugger. Just follow these simple steps, and debugging an expert can be fun:
Make sure that the expert is not installed. If there is this entry
\CURRENT_USER\software\Delphi\3.0\experts,
myexpert=\projects\myexpert\expert.dll
rename this entry to "expert.xxx". (don't delete it, you'll need it later).
Otherwise, you cannot compile a new version.
Run Delphi, open your expert's project as used, compile it and set the break points you think you need.
Go to the menu item run | parameters. This is the new Delphi 3 feature mentioned above.
Surprise: the host application is Delphi itself! So, next to the field "host app", enter something like e:\Programs\delphi3\bin\delphi32.exe (with path)
Second trick: now we install the expert... If you have "expert.xxx" installed, rename that to "expert.dll". This will be used by any Delphi instance started from now on.
Run "your application" (= Delphi 3) using menu item run | run.
If you have enough RAM, Delphi is loaded and this instance will have your expert installed.
Activate the expert, you'll have the possibility to use the comfort of the first instance's internal debugger.
Close the right instance of Delphi - and you can modify/ recompile etc. your expert.
Взято с сайта
Отображаем текст в System Tray.
Отображаем текст в System Tray.
Автор: Ruslan Abu Zant
Данный код сперва конвертирует Ваш текст в DIB, а затем DIB в иконку и далее в ресурс. После этого изображение иконки отображается в System Tray.
Вызов просходит следующим образом....
StringToIcon('This Is Made By Ruslan K. Abu Zant');
N.B>> Не забудьте удалить объект HIcon, после вызова функции...
unit MainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
function StringToIcon(const st: string): HIcon;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
ICONIMAGE = record
Width, Height, Colors: DWORD; // Ширина, Высота и кол-во цветов
lpBits: PChar; // указатель на DIB биты
dwNumBytes: DWORD; // Сколько байт?
lpbi: PBitmapInfoHeader; // указатель на заголовок
lpXOR: PChar; // указатель на XOR биты изображения
lpAND: PChar; // указатель на AND биты изображения
end;
function CopyColorTable(var lpTarget: BITMAPINFO; const lpSource:
BITMAPINFO): boolean;
var
dc: HDC;
hPal: HPALETTE;
pe: array[0..255] of PALETTEENTRY;
i: Integer;
begin
result := False;
case (lpTarget.bmiHeader.biBitCount) of
8:
if lpSource.bmiHeader.biBitCount = 8 then
begin
Move(lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof(RGBQUAD));
result := True
end
else
begin
dc := GetDC(0);
if dc <> 0 then
try
hPal := CreateHalftonePalette(dc);
if hPal <> 0 then
try
if GetPaletteEntries(hPal, 0, 256, pe) <> 0 then
begin
for i := 0 to 255 do
begin
lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
end;
result := True
end
finally
DeleteObject(hPal)
end
finally
ReleaseDC(0, dc)
end
end;
4:
if lpSource.bmiHeader.biBitCount = 4 then
begin
Move(lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof(RGBQUAD));
result := True
end
else
begin
hPal := GetStockObject(DEFAULT_PALETTE);
if (hPal <> 0) and (GetPaletteEntries(hPal, 0, 16, pe) <> 0) then
begin
for i := 0 to 15 do
begin
lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
end;
result := True
end
end;
1:
begin
i := 0;
lpTarget.bmiColors[i].rgbRed := 0;
lpTarget.bmiColors[i].rgbGreen := 0;
lpTarget.bmiColors[i].rgbBlue := 0;
lpTarget.bmiColors[i].rgbReserved := 0;
i := 1;
lpTarget.bmiColors[i].rgbRed := 255;
lpTarget.bmiColors[i].rgbGreen := 255;
lpTarget.bmiColors[i].rgbBlue := 255;
lpTarget.bmiColors[i].rgbReserved := 0;
result := True
end;
else
result := True
end
end;
function WidthBytes(bits: DWORD): DWORD;
begin
result := ((bits + 31) shr 5) shl 2
end;
function BytesPerLine(const bmih: BITMAPINFOHEADER): DWORD;
begin
result := WidthBytes(bmih.biWidth * bmih.biPlanes * bmih.biBitCount)
end;
function DIBNumColors(const lpbi: BitmapInfoHeader): word;
var
dwClrUsed: DWORD;
begin
dwClrUsed := lpbi.biClrUsed;
if dwClrUsed <> 0 then
result := Word(dwClrUsed)
else
case lpbi.biBitCount of
1: result := 2;
4: result := 16;
8: result := 256
else
result := 0
end
end;
function PaletteSize(const lpbi: BitmapInfoHeader): word;
begin
result := DIBNumColors(lpbi) * sizeof(RGBQUAD)
end;
function FindDIBBits(const lpbi: BitmapInfo): PChar;
begin
result := @lpbi;
result := result + lpbi.bmiHeader.biSize + PaletteSize(lpbi.bmiHeader)
end;
function ConvertDIBFormat(var lpSrcDIB: BITMAPINFO; nWidth, nHeight, nbpp: DWORD; bStretch: boolean):
PBitmapInfo;
var
lpbmi: PBITMAPINFO;
lpSourceBits, lpTargetBits: Pointer;
DC, hSourceDC, hTargetDC: HDC;
hSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap:
HBITMAP;
dwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize: DWORD;
begin
result := nil;
// Располагаем и заполняем структуру BITMAPINFO для нового DIB
// Обеспечиваем достаточно места для 256-цветной таблицы
dwTargetHeaderSize := sizeof(BITMAPINFO) + (256 * sizeof(RGBQUAD));
GetMem(lpbmi, dwTargetHeaderSize);
try
lpbmi^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := nWidth;
lpbmi^.bmiHeader.biHeight := nHeight;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := nbpp;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0; // Заполняем в таблице цветов
if CopyColorTable(lpbmi^, lpSrcDIB) then
begin
DC := GetDC(0);
hTargetBitmap := CreateDIBSection(DC, lpbmi^, DIB_RGB_COLORS,
lpTargetBits, 0, 0);
hSourceBitmap := CreateDIBSection(DC, lpSrcDIB, DIB_RGB_COLORS,
lpSourceBits, 0, 0);
try
if (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then
begin
hSourceDC := CreateCompatibleDC(DC);
hTargetDC := CreateCompatibleDC(DC);
try
if (hSourceDC <> 0) and (hTargetDC <> 0) then
begin
// Flip the bits on the source DIBSection to match the source DIB
dwSourceBitsSize := DWORD(lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader);
dwTargetBitsSize := DWORD(lpbmi^.bmiHeader.biHeight) *
BytesPerLine(lpbmi^.bmiHeader);
Move(FindDIBBits(lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize);
// Select DIBSections into DCs
hOldSourceBitmap := SelectObject(hSourceDC, hSourceBitmap);
hOldTargetBitmap := SelectObject(hTargetDC, hTargetBitmap);
try
if (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then
begin
// Устанавливаем таблицу цветов для DIBSections
if lpSrcDIB.bmiHeader.biBitCount <= 8 then
SetDIBColorTable(hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors);
if lpbmi^.bmiHeader.biBitCount <= 8 then
SetDIBColorTable(hTargetDC, 0, 1 shl
lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors);
// If we are asking for a straight copy, do it
if (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then
BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY)
else if bStretch then
begin
SetStretchBltMode(hTargetDC, COLORONCOLOR);
StretchBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
lpbmi^.bmiHeader.biHeight,
hSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth, lpSrcDIB.bmiHeader.biHeight,
SRCCOPY)
end
else
BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY);
GDIFlush;
GetMem(result, Integer(dwTargetHeaderSize + dwTargetBitsSize));
Move(lpbmi^, result^, dwTargetHeaderSize);
Move(lpTargetBits^, FindDIBBits(result^)^, dwTargetBitsSize)
end
finally
if hOldSourceBitmap <> 0 then SelectObject(hSourceDC, hOldSourceBitmap);
if hOldTargetBitmap <> 0 then SelectObject(hTargetDC, hOldTargetBitmap);
end
end
finally
if hSourceDC <> 0 then DeleteDC(hSourceDC);
if hTargetDC <> 0 then
DeleteDC(hTargetDC)
end
end;
finally
if hTargetBitmap <> 0 then DeleteObject(hTargetBitmap);
if hSourceBitmap <> 0 then DeleteObject(hSourceBitmap);
if dc <> 0 then
ReleaseDC(0, dc)
end
end
finally
FreeMem(lpbmi)
end
end;
function DIBToIconImage(var lpii: ICONIMAGE; var lpDIB: BitmapInfo;
bStretch: boolean): boolean;
var
lpNewDIB: PBitmapInfo;
begin
result := False;
lpNewDIB := ConvertDIBFormat(lpDIB, lpii.Width, lpii.Height, lpii.Colors,
bStretch);
if Assigned(lpNewDIB) then
try
lpii.dwNumBytes := sizeof(BITMAPINFOHEADER) // Заголовок
+ PaletteSize(lpNewDIB^.bmiHeader) // Палитра
+ lpii.Height * BytesPerLine(lpNewDIB^.bmiHeader) // XOR маска
+ lpii.Height * WIDTHBYTES(lpii.Width); // AND маска
// Если здесь уже картинка, то освобождаем её
if lpii.lpBits <> nil then
FreeMem(lpii.lpBits);
GetMem(lpii.lpBits, lpii.dwNumBytes);
Move(lpNewDib^, lpii.lpBits^, sizeof(BITMAPINFOHEADER) + PaletteSize
(lpNewDIB^.bmiHeader));
// Выравниваем внутренние указатели/переменные для новой картинки
lpii.lpbi := PBITMAPINFOHEADER(lpii.lpBits);
lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2;
lpii.lpXOR := FindDIBBits(PBitmapInfo(lpii.lpbi)^);
Move(FindDIBBits(lpNewDIB^)^, lpii.lpXOR^, lpii.Height * BytesPerLine
(lpNewDIB^.bmiHeader));
lpii.lpAND := lpii.lpXOR + lpii.Height * BytesPerLine
(lpNewDIB^.bmiHeader);
Fillchar(lpii.lpAnd^, lpii.Height * WIDTHBYTES(lpii.Width), $00);
result := True
finally
FreeMem(lpNewDIB)
end
end;
function TForm1.StringToIcon(const st: string): HIcon;
var
memDC: HDC;
bmp: HBITMAP;
oldObj: HGDIOBJ;
rect: TRect;
size: TSize;
infoHeaderSize: DWORD;
imageSize: DWORD;
infoHeader: PBitmapInfo;
icon: IconImage;
oldFont: HFONT;
begin
result := 0;
memDC := CreateCompatibleDC(0);
if memDC <> 0 then
try
bmp := CreateCompatibleBitmap(Canvas.Handle, 16, 16);
if bmp <> 0 then
try
oldObj := SelectObject(memDC, bmp);
if oldObj <> 0 then
try
rect.Left := 0;
rect.top := 0;
rect.Right := 16;
rect.Bottom := 16;
SetTextColor(memDC, RGB(255, 0, 0));
SetBkColor(memDC, RGB(128, 128, 128));
oldFont := SelectObject(memDC, font.Handle);
GetTextExtentPoint32(memDC, PChar(st), Length(st), size);
ExtTextOut(memDC, (rect.Right - size.cx) div 2, (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect, PChar(st), Length(st), nil);
SelectObject(memDC, oldFont);
GDIFlush;
GetDibSizes(bmp, infoHeaderSize, imageSize);
GetMem(infoHeader, infoHeaderSize + ImageSize);
try
GetDib(bmp, SystemPalette16, infoHeader^, PChar(DWORD(infoHeader) + infoHeaderSize)^);
icon.Colors := 4;
icon.Width := 32;
icon.Height := 32;
icon.lpBits := nil;
if DibToIconImage(icon, infoHeader^, True) then
try
result := CreateIconFromResource(PByte(icon.lpBits), icon.dwNumBytes, True, $00030000);
finally
FreeMem(icon.lpBits)
end
finally
FreeMem(infoHeader)
end
finally
SelectObject(memDC, oldOBJ)
end
finally
DeleteObject(bmp)
end
finally
DeleteDC(memDC)
end
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Application.Icon.Handle := StringToIcon('0');
Timer1.Enabled := True;
Button1.Enabled := False;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
const i: Integer = 0;
begin
Inc(i);
if i = 100 then i := 1;
Application.Icon.Handle := StringToIcon(IntToStr(i));
end;
end.
Взято с Исходников.ru
Отображения величин в Watch List
Отображения величин в Watch List
В BP 7.0 возможно было регулировать форму отображения величин
в процессе отладки в окне ""Watch List"". Возможно ли такое в Delphi?
Такой эффект можно достичь используя следующие спецификации формата отображения (практически совпадающие с BP 7.0), которые указываются через запятую после идентификатора инспектируемой величины:
Символ Применяется к типу Функциональность
-------- ------------------------------------------------------------------
H или X Integers Отображает целые величины в 16-ричном формате
с префиксом 0x
C Char,strings Показывает специальные символы (ASCII 0..31).
По умолчанию они отображаются в виде
esc-последовательности (/n , /t , и т.п.)
D Integers Отображает целые величины в десятичном формате.
Fn Floating point Показывает n десятичных знаков
(где n = 2..18, по умолчанию 7 )
nM All Дамп памяти, где n задает количество отображаемых
байт памяти, начиная с адреса величины.
По умолчанию каждый байт представляется двумя
16-ричными цифрами, но возможно также совместное
использование nM с другими форматами.
P Pointers Отображает величину, как указатель в формате seg:ofs.
R Records, classes, Показывает не только величины полей,
objects но и сами поля, напрмер, как (X:2; Y:5)
вместо (2, 5).
S Char,strings Показывает любые неотображаемые ASCII символы в виде #nn.
Используется вместе с nM.
Автор: StayAtHome
Отследить завершение работы, (перезагрузку, смену пользователя) в Windows.
Отследить завершение работы, (перезагрузку, смену пользователя) в Windows.
Очень часто мы сталкиваемся с проблемой, когда наша программа будучи запущенная в фоне и/или свёрнутая, например, в панель задач должна что-то сделать, когда Windows выключается, перезагружается или просто меняется пользователь.
Если мы не будем отслеживать такую ситуацию, то в худшем случае у нас могут просто потеряться какие-либо данные или Windows просто не сможет выполнить перезагрузку до конца. Ей будет мешать наша программа. Не нужно думать, что Windows перед перезагрузкой рассылает приложениям сообщения о закрытии, так чтобы у тех выпаолнились обработчкики TForm.onCloseQuery/onClose.
ОС Windows отсылает перед перезагрузкой, выключением или сменой пользователя сообщения WM_QUERYENDSESSION, а потом по его успешному завершению WM_ENDSESSION. Наше приложение должно поймать эти сообщения и отреагировать так чтобы дать понять, что мы согласны перезагружаться. В частности на сообщение WM_QUERYENDSESSION мы должны вернуть не 0:
The WM_QUERYENDSESSION message is sent when the user chooses to end the Windows session or when an application calls the ExitWindows function. If any application returns zero, the Windows session is not ended. Windows stops sending WM_QUERYENDSESSION messages as soon as one application returns zero.
Практически мы уже здесь можем завершить свою программу.
В случае если те действия, которые выполняются при наступлении перезагрузки не велики по величине времени их выполнения, можно не обрабатывать WM_QUERYENDSESSION, а обойтись просто сообещением WM_ENDSESSION. В параметре WParam этого сообщения поступает как раз тот результат, который мы вернули (или не вернули) из сообщения WM_QUERYENDSESSION:
protectedprocedure IsWindowsShutDown(var Msg: TMessage);WM_ENDSESSION;
..
procedure TForm1.IsWindowsShutDown(var Msg: TMessage);
begin
inherited;
if Msg.WParam = 1 then MainForm.Close; // выгружаем приложение
End;
Если нам нужно что-то сделать ещё (например удалить какой-либо файл или записать какую-нибудь информацию), применительно для вышеприведённого примера это можно сделать в обработчиках onCloseQuery/onClose формы.
Процедуру IsWindowsShutDown() мы должны описать в классе того окна, которое будет принимать данное сообщение т.е. формы.
Автор:
SongВзято из
Отслеживаем позицию курсора в EditBox.
Отслеживаем позицию курсора в EditBox.
В форму добавляются TEditBox и TLabel, при этом TLabel постоянно показывает позицию курсора в элементе редактирования.
procedure TForm1.Edit1Change(Sender: TObject);
begin
CurPos := Edit1.SelStart;
Label1.Caption := IntToStr(CurPos);
end;
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
If Key = VK_LEFT then dec(CurPos);
if Key = VK_RIGHT then inc(CurPos);
Label1.Caption:= IntToStr(CurPos);
end;
Взято с Исходников.ru
Override/Vitual/Dynamic - методы
Override/Vitual/Dynamic - методы
Если метод в классе предка объявлен как виртуальный (virtual) или динамический (dynamic), вам необходимо перекрыть его во всех классах-наследниках. Если вы объявляете унаследованный метод виртуальным или динамическим, вы начинаете строить его новое виртуальное/динамическое дерево наследования. Допустим, у нас есть следующая иерархия: A (родитель) - B - C - D. Если вы объявляете метод как виртуальный (или динамический) в A, перекрываете в B, создаете виртуальным в C и перекрываете в D, вот что получается:
фактический класс, используемый класс, использующий
классдля доступа к методу метод
-----------+---------------------+--------------------
D D D
D C D
D B B
D A B
C C C
C B B
C A B
B B B
B A B
Вывод: работа виртуального/динамического наследования прекращается в момент создания одноименного виртуального/динамического метода наследниками класса.
Mark
Взято из
Советов по Delphi от
Сборник Kuliba
PageControl, TabControl, Notebook
PageControl, TabControl, Notebook
Cодержание раздела:
Panel, ToolBar, CoolBar
Panel, ToolBar, CoolBar
Cодержание раздела:
См. также статьи в других разделах:
Панель управления
Панель управления
Cодержание раздела:
В файловой системе win95 существует
Paradox и неверные индексы Win95
Автор: David W. Husch
Сообщение об ошибке: В файловой системе win95 существует ошибка, "микширующая" блокировку записи Paradox и механизм обновления. В хост-файлах Paradox в Windows 95 для работы нескольких пользователей измените следующие значения:
Select Control Panel
System (icon)
Performance (Tab)
File System (Button)
Troubleshooting (Tab)
"Disable New File Sharing and Locking Semantics" (щелкните) (нажмите OK)
(Выключить общий доступ к новым файлам и семантику блокировки)
Взято из
Парсинг строк
Парсинг строк
unitsplitfns;
interface
uses Classes, Sysutils;
function GetNextToken
(Const S: string;
Separator: TSysCharSet;
var StartPos: integer): String;
{Returns the next token (substring)
from string S, starting at index
StartPos and ending 1 character
before the next occurrence of
Separator (or at the end of S,
whichever comes first).}
{StartPos returns the starting
position for the next token, 1
more than the position in S of
the end of this token}
procedure Split
(const S: String;
Separator: TSysCharSet;
MyStringList: TStringList);
{Splits a string containing designated
separators into tokens and adds
them to MyStringList NOTE: MyStringList
must be Created before being passed to this
procedure and Freed after use}
function AddToken
(const aToken, S: String;
Separator: Char;
StringLimit: integer): String;
{Used to join 2 strings with a
separator character between them and
can be used in a Join function}
{The StringLimit parameter prevents
the length of the Result String
from exceeding a preset maximum}
implementation
function GetNextToken
(Const S: string;
Separator: TSysCharSet;
var StartPos: integer): String;
var Index: integer;
begin
Result := '';
{Step over repeated separators}
While (S[StartPos] in Separator)
and (StartPos <= length(S))do
StartPos := StartPos + 1;
if StartPos > length(S) then Exit;
{Set Index to StartPos}
Index := StartPos;
{Find the next Separator}
While not (S[Index] in Separator)
and (Index <= length(S))do
Index := Index + 1;
{Copy the token to the Result}
Result := Copy(S, StartPos, Index - StartPos);
{SetStartPos to next Character after the Separator}
StartPos := Index + 1;
end;
procedure Split
(const S: String;
Separator: TSysCharSet;
MyStringList: TStringList);
var Start: integer;
begin
Start := 1;
While Start <= Length(S) do
MyStringList.Add
(GetNextToken(S, Separator, Start));
end;
function AddToken (const aToken, S: String;
Separator: Char;
StringLimit: integer): String;
begin
if Length(aToken) + Length(S) < StringLimit then
begin
{Add a separator unless the
Result string is empty}
if S = '' then
Result := ''
else Result := S + Separator;
{Add the token}
Result := Result + aToken;
end
else
{if the StringLimit would be
exceeded, raise an exception}
Raise Exception.Create('Cannot add token');
end;
end.
пример использования:
...
data:= TStringList.Create;
splited:=TStringList.Create;
data.LoadFromFile(s);
Split(data.Text,[',',' ',#10,#13,';','\"','.','!','-','+','*','/','\',
'(',')','[',']','{','}','<','>','''','"','?','"','#',#0],splited);
for i:= 0 to splited.Count-1 do
begin
if not words.Find(splited.Strings,adr) then
words.Add(splited.Strings[i]);
application.processmessages;[i]//make program to respond to user commands while processing in case of very long string.
end;
...
Автор:
SongВзято из
Паскалевский метод доступа
Паскалевский метод доступа
Для более тонких операций над текстовыми файлами прийдется освоить очень древний паскалевский способ.
Итак, для доступа к текстовым файлам используется переменная типа TextFile. До сих пор не совсем понимаю что это такое физически - что-то типа "внутреннего" паскалевского Handle на файл.
Итак чтобы ассоциировать файл на диске с переменной надо проделать следующие опрерации:
1) Определяем файловую переменную:
var f:TextFile;
2) Ассоциируем ее:
AssignFile(F, 'c:\MyFile.txt');
3) Теперь надо этот файл открыть, есть 3 варианта:
- файла нет или он должен быть перезаписан, открытие для записи:
Rewrite(f)
- файл есть и его надо открыть для чтения (с первой строки)
Reset(f)
- файл есть и его надо открыть для дописования строк в конец
Append(f)
Как видите не хватает очень полезных функций таких как открытия файла для чтения с произвольной строки и для записи в файл произвольной строки. Но надо учесть, что так как длины строк разные, не существует никакого способа узнать физическое место начала например 1000 строки, не прочитав всю тысячу строк. Для записи ситуация еще сложнее - вставить строку означает перезаписать всю информацию после этой строки заново. Таким образом варианты только следующие:
- Перезаписать весть файл
- Читать с первой строки
- Дописать что-то в конец
- Читать и писать файл целиком (см. выше работу через TStrings)
В конце работы открытый файл нужно закрыть:
CloseFile(f);
Теперь пусть у нас есть строковая переменная s для чтения строки из файла
Чтение предварительно открытого файла:
ReadLn(f, s) - будет прочитанна текущая строка и позиция чтения переведена на следующую позицию.
А как прочитать весь файл?
While not eof(f) do
begin
ReadLn(f, s);
{здесь делаем что-то с прочитанной строкой}
end;
Хорошо, а если файл несколько метров есть ли способ поставить какой-нибудь ProgressBar или Gauge чтобы показывал сколько считанно? Есть, но не совсем прямой - не забыли, сколько строк в файле заранее мы не знаем, узнать можно только прочитав его весь, но показометер мы все-таки сделаем:
var Canceled:Boolean;
Function GetFileSize(FIleName:String):integer;
var f: File of Byte;
begin
try
AssignFile(f, FileName);
Reset(f);
result:=filesize(F);
CloseFile(f);
except
result:=-1;
end;
end;
Procedure ReadMyFile;
Var i,j:integer;
Begin
ProgressBar1.Max:=GetFileSize('c:\MyFile.txt');
ProgressBar1.position:=0;
assignfile(f,'c:\MyFile.txt');
Canceled:=False;
reset(f);
i:=0;j:=0;
while not eof(f) do
begin
inc(j);
readln(f,s);
i:=i+length(s)+2;
if (j mod 1000)=0 then
begin
ProgressBar1.position:=i;
Application.ProcessMessages;
if canceled then break;
end;
{здесь мы что-то делаем с прочитанной строкой}
end;
CloseFile(f);
End;
Теперь комментарии к коду.
1) Функию GetFileSize я рсссмотрю после, она немного по другому подходит к чтению файла (кстати я знаю еще по крайней мере 3 способа ее реализации, поэтому не нужно указывать что это можно сделать легче, быстрее или просто по другому - просто давайте разберем это позже)
2) Переменная i - все время указывает на количество байт которое мы считали - мы определяем длину каждой строки и прибавляем 2 (символы конца строки). Зная длину файла в байтах и сколько байт прочитано можно оценить и прогресс, но
3) Если ставить изменение прогресса после каждой строки, то это очень сильно тормознет процесс. Поэтому вводим переменную j и обновляем прогресс например 1 раз на 1000 прочитанных строк
4) Переменная Canceled - глобальная переменная. Поставьте на форму кнопку, в обработчике нажатия поставьте Canceled:=True; и нажатие кнопки прервет чтение файла.
Теперь как писать в текстовый файл:
Запись целой строки:
Writeln(f,s);
Запись кусочка строки(те следующая операция записи будет произведена в ту же строку):
Write(f,s);
Если переменная s содержит больше 255 символов (т.е. является длинной строкой), то таким способом ни фига не запишится, в файл вместо строки попадут 4 байта указателя на нее. Надо делать так:
Writeln(f,pointer(s)^);
PChar-->Integer
PChar-->Integer
Many Windows functions claim to want PChar parameters in the
documentation, but they are defined as requiring LongInts.
Is this a bug?
No, this is where "typecasting" is used. Typecasting allows you to
fool the compiler into thinking that one type of variable is of
another type for the ultimate in flexibility. The last parameter of
the Windows API function SendMessage() is a good example. It is
documented as requiring a long integer, but commonly requires a PChar
for some messages (WM_WININICHANGE). Generally, the variable you are
typecasting from must be the same size as the variable type you are
casting it to. In the SendMessage example, you could typecast a PChar
as a longint, since both occupy 4 bytes of memory:
var
s : array[0..64] of char;
begin
StrCopy(S, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;
Печать
Печать
Cодержание раздела:
См. также статьи в других разделах:
Печать Dos-файла в порт напрямую
Печать Dos-файла в порт напрямую
При печати Dos-файла в порт напрямую можно это сделать.
Например, напечатать за 2 прохода:
ESC @ - инициализация принтера
ESC G - включение режима печати за 2 прохода
ESC H - выключение режима печати за 2 прохода
Var FileOut : TextFile;
filename : String [128];
....
Filename:='PRN';
AssignFile(Fileout,Filename);
...
Write(FileOut,Chr(27)+'@');
Str1:=AnToAs(chr(27)+'G'+'Double'+chr(27)+'H');
Writeln(FileOut,Str1);
...
{преобразование Ansi to Ascii}
function AnToAs(s: String) : String;
Var i,kod : Integer;
begin
Result:=s;
for i:=1 to length(s) do
begin
kod:=Ord(s[i]);
if kod 13 then Result[i]:=' ';
if ( kod>=192) and ( kod=239) then
Result[i]:=Chr(kod-64);
if ( kod>=240) and ( kod=255) then
Result[i]:=Chr(kod-16);
if kod=168 then Result[i]:=Chr(240);
if kod=184 then Result[i]:=Chr(241);
end;
end;
Взято с сайта
Печать ячеек
Печать ячеек
У кого-нибудь есть пример кода печати в заданной ячейке? Типа PrintAt(row,col,"Text")?
Вот некоторый код, который я нашел после блужданий в группах новостей. Правда сам я его не проверял, но источник утверждает, что он работает. Так что будьте внимательны!
ProcedureTForm1.PrintTableClick(Sender: TObject);
var
xcord: integer;
ycord: integer;
recordbuffer: string;
begin
xcord := 10;
ycord := 10;
Table1.First;
Printer.BeginDoc;
Printer.Canvas.Font.Name := 'Courier New';
while not Table1.EOF do
begin
recordbuffer := concat((Table1.Fields[0].AsString), ' ', (Table1.Fields[1].AsString));
recordbuffer := recordbuffer + concat(' ', (Table1.Fields[2].AsString);
{пока все поля не будут в recordbuffer}
Printer.Canvas.TextOut(xcord, ycord, recordbuffer);
ycord := ycord + 50;
Table1.next;
end;
Printer.Enddoc;
end;
Буду рад, если помог.
Lloyd Linklater <Sysop>
Delphi Technical Support
Взято из
Советов по Delphi от
Сборник Kuliba
Печать повернутого текста
Печать повернутого текста
procedureAngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);
var
LogFont: TLogFont;
SaveFont: TFont;
begin
SaveFont := TFont.Create;
SaveFont.Assign(CV.Font);
GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);
with LogFont do
begin
lfEscapement := angle * 10;
lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;
end; {with}
CV.Font.Handle := CreateFontIndirect(LogFont);
SetBkMode(CV.Handle, TRANSPARENT);
CV.TextOut(x, y, sText);
CV.Font.Assign(SaveFont);
SaveFont.Free;
end;
procedure TextOutVertical(var bitmap: TBitmap; x, y: Integer; s: string);
var b1, b2: TBitmap;
i, j: Integer;
begin
with bitmap.Canvas do
begin
b1 := TBitmap.Create;
b1.Canvas.Font := lpYhFont;
b1.Width := TextWidth(s) + 1;
b1.Height := TextHeight(s) + 1;
b1.Canvas.TextOut(1, 1, s);
b2 := TPackedBitmap.Create;
b2.Width := TextHeight(s);
b2.Height := TextWidth(s);
for i := 0 to b1.Width - 1 do
for j := 0 to b1.Height do
b2.Canvas.Pixels[j, b2.Height + 1 - i] := b1.Canvas.Pixels[i, j];
Draw(x, y, b2);
b1.Free;
b2.Free;
end
end;
functionCreateMyFont(degree: Integer): HFONT;
begin
CreateMyFont := CreateFont(
-30, 0, degree, 0, 0,
0, 0, 0, 1, OUT_TT_PRECIS,
0, 0, 0, szFontName);
end;
....и затем использовал любую функцию рисования для вывода текста.
procedureTForm1.TextUp(aRect: tRect; aTxt: string);
var LFont: TLogFont;
hOldFont, hNewFont: HFont;
begin
GetObject(Canvas.Font.Handle, SizeOf(LFont), Addr(LFont));
LFont.lfEscapement := 900;
hNewFont := CreateFontIndirect(LFont);
hOldFont := SelectObject(Canvas.Handle, hNewFont);
Canvas.TextOut(aRect.Left + 2, aRect.Top, aTxt);
hNewFont := SelectObject(Canvas.Handle, hOldFont);
DeleteObject(hNewFont);
end;
Взято из
Советов по Delphi от
Сборник Kuliba
Печать, работа с принтером
Печать, работа с принтером
Cодержание раздела:
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
Печать с масштабированием
Печать с масштабированием
procedureTForm1.Button1Click(Sender: TObject);
// © Song
Var ScaleX, ScaleY: Integer;
Begin
Printer.BeginDoc;
With Printer Do
try
ScaleX:=GetDeviceCaps(Handle,LogPixelsX) div PixelsPerInch;
ScaleY:=GetDeviceCaps(Handle,LogPixelsY) div PixelsPerInch;
Canvas.StretchDraw(Rect(0,0,Image1.Picture.Width*ScaleX,Image1.Picture.Height*ScaleY),Image1.Picture.Graphic);
finally
EndDoc;
end;
End;
Автор:
SongВзято из
Печать содержимого DBGrid через QuickReport
Печать содержимого DBGrid через QuickReport
Автор: Rafael Ribas Aguilу
Частенько у пользователя возникает необходимость распечатать отчёт из базы данных. Естественно, что он начинает просить Вас добавить такую возможность в приложение. Как оказалось, при помощи TQuickRep данную задачу можно очень легко решить.
Итак, приступим. Для начала создайте новую форму, назвав её TGridReport, и поместите на неё TQuickRep. Переименуйте QuickRep в GridRep. Затем сделайте следующию процедуру, которая получает в качестве параметра DBGrid:
procedure TGridReport.Preview(Grid: TDBGrid);
var
i, CurrentLeft, CurrentTop : integer;
BMark: TBookmark;
begin
GridRep.Dataset:=Grid.DataSource.DataSet;
if not GridRep.Bands.HasColumnHeader then
GridRep.Bands.HasColumnHeader:=true;
if not GridRep.Bands.HasDetail then
GridRep.Bands.HasDetail:=true;
GridRep.Bands.ColumnHeaderBand.Height:=Abs(Grid.TitleFont.Height) + 10;
GridRep.Bands.DetailBand.Height:=Abs(Grid.Font.Height) + 10;
CurrentLeft := 12;
CurrentTop := 6;
{Запись, на которой пользователь останавливается в DBGrid}
BMark:=Grid.DataSource.DataSet.GetBookmark;
{Запретим мерцание грида в процессе работы отчёта}
Grid.DataSource.DataSet.DisableControls;
try
for i:=0 to Grid.FieldCount - 1 do
begin
if (CurrentLeft + Canvas.TextWidth(Grid.Columns[i].Title.Caption)) >
(GridRep.Bands.ColumnHeaderBand.Width) then
begin
CurrentLeft := 12;
CurrentTop := CurrentTop + Canvas.TextHeight('A') + 6;
GridRep.Bands.ColumnHeaderBand.Height := GridRep.Bands.ColumnHeaderBand.Height +
(Canvas.TextHeight('A') + 10);
GridRep.Bands.DetailBand.Height := GridRep.Bands.DetailBand.Height +
(Canvas.TextHeight('A') + 10);
end;
{Создадим заголовок отчёта при помощи QRLabels}
with TQRLabel.Create(GridRep.Bands.ColumnHeaderBand) do
begin
Parent := GridRep.Bands.ColumnHeaderBand;
Color := GridRep.Bands.ColumnHeaderBand.Color;
Left := CurrentLeft;
Top := CurrentTop;
Caption:=Grid.Columns[i].Title.Caption;
end;
{Создадим тело отчёта при помощи QRDBText}
with TQRDbText.Create(GridRep.Bands.DetailBand) do
begin
Parent := GridRep.Bands.DetailBand;
Color := GridRep.Bands.DetailBand.Color;
Left := CurrentLeft;
Top := CurrentTop;
Alignment:=Grid.Columns[i].Alignment;
AutoSize:=false;
AutoStretch:=true;
Width:=Grid.Columns[i].Width;
Dataset:=GridRep.Dataset;
DataField:=Grid.Fields[i].FieldName;
CurrentLeft:=CurrentLeft + (Grid.Columns[i].Width) + 15;
end;
end;
lblPage.Left := bdTitle.Width - lblPage.Width - 10;
lblDate.Left := bdTitle.Width - lblDate.Width - 10;
{Далее вызовем метод предварительного просмотра из QuickRep}
GridRep.PreviewModal; {либо, если желаете, то PreviewModal}
finally
with Grid.DataSource.DataSet do
begin
GotoBookmark(BMark);
FreeBookmark(BMark);
EnableControls;
end;
end;
end;
Взято с Исходников.ru
Печать содержимого TMemo или TListbox.
Печать содержимого TMemo или TListbox.
Следующая функция имеет один параметр в виде объекта TStrings и печатает каждую строку на принтер, установленный в системе по умолчанию. Так как эта функция использует TStrings, то она будет работать с различными компонентами, которые содержат свойство типа TStrings, такие как TDBMemo или TOutline:
uses Printers;
procedure PrintStrings(Strings: TStrings);
var
Prn: TextFile;
i: word;
begin
AssignPrn(Prn);
try
Rewrite(Prn);
try
for i := 0 to Strings.Count - 1 do
writeln(Prn, Strings.Strings[i]);
finally
CloseFile(Prn);
end;
except
on EInOutError do
MessageDlg('Error Printing text.', mtError, [mbOk], 0);
end;
end;
Чтобы распечатать содержимое TMemo или TListbox, используйте следующие команды:
PrintStrings(Memo1.Lines);
или
PrintStrings(Listbox1.Items);
Взято с Исходников.ru
Печать содержимого TMemo/TListbox
Печать содержимого TMemo/TListbox
Как мне вывести на печать все строки компонента TMemo или TListbox?
Нижеприведенная функция в качестве параметра акцептует объект TStrings и распечатывает все строки на принтере, установленном в системе по умолчанию.Поскольку функция использует TStrings, то она может работать с любыми типами компонентов, имеющими свойство типа TStrings, например TDBMemo или TOutline.
usesPrinters;
procedure PrintStrings(Strings: TStrings);
var
Prn: TextFile;
i: word;
begin
AssignPrn(Prn);
try
Rewrite(Prn);
try
for i := 0 to Strings.Count - 1 do
writeln(Prn, Strings.Strings[i]);
finally
CloseFile(Prn);
end;
except
on EInOutError do
MessageDlg('Ошибка печати текста.', mtError, [mbOk], 0);
end;
end;
Для печати содержимого TMemo или TListbox используйте следующий код:
PrintStrings(Memo1.Lines);
или
PrintStrings(Listbox1.Items);
Взято из
Советов по Delphi от
Сборник Kuliba
Печать структуры таблицы Paradox
Печать структуры таблицы Paradox
procedureTForm1.Button1Click(Sender: TObject);
const
FieldTypes: array[0..16] of string[10] = ('Unknown', 'String', 'Smallint',
'Integer', 'Word', 'Boolean', 'Float', 'Currency', 'BCD', 'Date', 'Time',
'DateTime', 'Bytes', 'VarBytes', 'Blob', 'Memo', 'Graphic');
var
i, nX, nY, nHeight, nWidth: Integer;
rtxtMetric: TTextMetric;
s: array[0..3] of string[10];
begin
with Table1.FieldDefs, Printer do
begin
Update;
PrinterIndex := -1;
Title := 'Структура ' + Table1.TableName;
BeginDoc;
nX := 0;
nY := 0;
WinProcs.GetTextMetrics(Canvas.Handle, rtxtMetric);
nHeight := rtxtMetric.tmHeight;
nWidth := rtxtMetric.tmAveCharWidth;
for i := 0 to Count - 1 do
begin
s[0] := IntToStr(Items[i].FieldNo) + #9;
s[1] := Items[i].Name + #9;
s[2] := FieldTypes[Ord(Items[i].DataType)] + #9;
s[3] := IntToStr(Items[i].Size);
Canvas.TextOut(nX, nY, s[0]);
Inc(nX, Length(s[0]) * nWidth);
Canvas.TextOut(nX, nY, s[1]);
Inc(nX, Length(s[1]) * nWidth);
Canvas.TextOut(nX, nY, s[2]);
Inc(nX, Length(s[2]) * nWidth);
Canvas.TextOut(nX, nY, s[3]);
nX := 0;
nY := i * nHeight;
end;
EndDoc;
end;
end;
Взято из
Советов по Delphi от
Сборник Kuliba
Печать текста в обход Windows
Печать текста в обход Windows
ОТкройте файл типа TextFile и пишите в него напрямую:
var
Lst: TextFile;
begin
AssignFile(Lst, 'LPT1');
Rewrite(Lst);
WriteLn(Lst, 'Здравствуй, мир!');
Close(Lst);
end.
При этом вы должны помнить, что при данной технологии вы не можете в это же время печатать из другой программы, иначе наступит конец света, а ваша распечатка будет похожа на "запутанный беспорядк".
Если вы планируете посылать на принтер управляющие коды, вызывайте следующую функцию немедленно после перезаписи файла:
procedure SetBinaryMode(var F: Text); assembler;
asm
mov ax,$4400
les di,F
mov bx,word ptr es:[di]
int $21
or dl,$20
xor dh,dh
mov ax,$4401
int $21
end;
-Steve
Взято из
Советов по Delphi от
Сборник Kuliba
Печать всей формы
Печать всей формы
unitPrintF;
{Печатает TLabel, TEdit, TMemo, TStringGrid, TShape и др. DB-компоненты.
Установите Form H & V ScrollBar.Ranges на 768X1008 для страницы 8X10.5.
Примечание: это не компонент. Успехов. Bill}
interface
uses
SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
Forms, Grids, Printers, StdCtrls, ExtCtrls, Mask;
function PrintForm(AForm: TForm; ATag: Longint): integer;
{используйте: PrintForm(Form2, 0);
AForm - форма, которую необходимо напечатать. Если вы, к примеру,
печатаете Form2 из обработчика события Form1, то используйте Unit2
в списке используемых модулей в секции implementation молуля Unit1.
ATag - поле Tag компонента, который необходимо печатать или 0 для всех.
Если Tag компонента равен 14 (2+4+8), он буден напечатан в случае,
когда ATag равен 0, 2, 4 или 8.
Функция возвращает количество напечатанных компонентов. }
implementation
var ScaleX, ScaleY, I, Count: integer;
DC: HDC;
F: TForm;
function ScaleToPrinter(R: TRect): TRect;
begin
R.Top := (R.Top + F.VertScrollBar.Position) * ScaleY;
R.Left := (R.Left + F.HorzScrollBar.Position) * ScaleX;
R.Bottom := (R.Bottom + F.VertScrollBar.Position) * ScaleY;
R.Right := (R.Right + F.HorzScrollBar.Position) * ScaleY;
Result := R;
end;
procedure PrintMComponent(MC: TMemo);
var C: array[0..255] of char;
CLen: integer;
Format: Word;
R: TRect;
begin
Printer.Canvas.Font := MC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
R := ScaleToPrinter(MC.BoundsRect);
if (not (F.Components[I] is TCustomLabel)) and (MC.BorderStyle = bsSingle) then Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
Format := DT_LEFT;
if (F.Components[I] is TEdit) or (F.Components[I] is TCustomMaskEdit) then
Format := Format or DT_SINGLELINE or DT_VCENTER
else
begin
if MC.WordWrap then Format := DT_WORDBREAK;
if MC.Alignment = taCenter then Format := Format or DT_CENTER;
if MC.Alignment = taRightJustify then Format := Format or DT_RIGHT;
R.Bottom := R.Bottom + Printer.Canvas.Font.Height;
end;
CLen := MC.GetTextBuf(C, 255);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, CLen, R, Format);
inc(Count);
end;
procedure PrintShape(SC: TShape);
var H, W, S: integer;
R: TRect;
begin {PrintShape}
Printer.Canvas.Pen := SC.Pen;
Printer.Canvas.Pen.Width := Printer.Canvas.Pen.Width * ScaleX;
Printer.Canvas.Brush := SC.Brush;
R := ScaleToPrinter(SC.BoundsRect);
W := R.Right - R.Left; H := R.Bottom - R.Top;
if W < H then
S := W
else
S := H;
if SC.Shape in [stSquare, stRoundSquare, stCircle] then
begin
Inc(R.Left, (W - S) div 2);
Inc(R.Top, (H - S) div 2);
W := S;
H := S;
end;
case SC.Shape of
stRectangle, stSquare:
Printer.Canvas.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H);
stRoundRect, stRoundSquare:
Printer.Canvas.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S div 4);
stCircle, stEllipse:
Printer.Canvas.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H);
end;
Printer.Canvas.Pen.Width := ScaleX;
Printer.Canvas.Brush.Style := bsClear;
inc(Count);
end; {PrintShape}
procedure PrintSGrid(SGC: TStringGrid);
var J, K: integer;
Q, R: TRect;
Format: Word;
C: array[0..255] of char;
CLen: integer;
begin
Printer.Canvas.Font := SGC.Font;
DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
Format := DT_SINGLELINE or DT_VCENTER;
Q := SGC.BoundsRect;
Printer.Canvas.Pen.Width := SGC.GridLineWidth * ScaleX;
for J := 0 to SGC.ColCount - 1 do
for K := 0 to SGC.RowCount - 1 do
begin
R := SGC.CellRect(J, K);
if R.Right > R.Left then
begin
R.Left := R.Left + Q.Left;
R.Right := R.Right + Q.Left + SGC.GridLineWidth;
R.Top := R.Top + Q.Top;
R.Bottom := R.Bottom + Q.Top + SGC.GridLineWidth;
R := ScaleToPrinter(R);
if (J < SGC.FixedCols) or (K < SGC.FixedRows) then
Printer.Canvas.Brush.Color := SGC.FixedColor
else
Printer.Canvas.Brush.Style := bsClear;
if SGC.GridLineWidth > 0 then
Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
StrPCopy(C, SGC.Cells[J, K]);
R.Left := R.Left + ScaleX + ScaleX;
WinProcs.DrawText(DC, C, StrLen(C), R, Format);
end;
end;
Printer.Canvas.Pen.Width := ScaleX;
inc(Count);
end;
function PrintForm(AForm: TForm; ATag: Longint): integer;
begin {PrintForm}
Count := 0;
F := AForm;
Printer.BeginDoc;
try
DC := Printer.Canvas.Handle;
ScaleX := WinProcs.GetDeviceCaps(DC, LOGPIXELSX) div F.PixelsPerInch;
ScaleY := WinProcs.GetDeviceCaps(DC, LOGPIXELSY) div F.PixelsPerInch;
for I := 0 to F.ComponentCount - 1 do
if TControl(F.Components[I]).Visible then
if (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) then
begin
if (F.Components[I] is TCustomLabel) or (F.Components[I] is TCustomEdit) then
PrintMComponent(TMemo(F.Components[I]));
if (F.Components[I] is TShape) then
PrintShape(TShape(F.Components[I]));
if (F.Components[I] is TStringGrid) then
PrintSGrid(TStringGrid(F.Components[I]));
end;
finally
Printer.EndDoc;
Result := Count;
end;
end; {PrintForm}
end.
unit Rulers;
{ Добавьте в файл .DCR иконки для двух компонентов.
Успехов, Bill}
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms;
type
THRuler = class(TGraphicControl)
private
{ Private declarations }
fHRulerAlign: TAlign;
procedure SetHRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignHRuler: TAlign read fHRulerAlign write SetHRulerAlign default alNone;
property Color default clYellow;
property Height default 33;
property Width default 768;
property Visible;
end;
type
TVRuler = class(TGraphicControl)
private
{ Private declarations }
fVRulerAlign: TAlign;
procedure SetVRulerAlign(Value: TAlign);
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property AlignVRuler: TAlign read fVRulerAlign write SetVRulerAlign default alNone;
property Color default clYellow;
property Height default 1008;
property Width default 33;
property Visible;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [THRuler, TVRuler]);
end;
procedure THRuler.SetHRulerAlign(Value: TAlign);
begin
if Value in [alTop, alBottom, alNone] then
begin
fHRulerAlign := Value;
Align := Value;
end;
end;
constructor THRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AlignHRuler := alNone;
Color := clYellow;
Height := 33;
Width := 768;
end;
procedure THRuler.Paint;
var a12th, N, X: word;
begin
a12th := Screen.PixelsPerInch div 12;
N := 0; X := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while X < Width do
begin
MoveTo(X, 1);
LineTo(X, 6 * (1 + byte(N mod 3 = 0) +
byte(N mod 6 = 0) +
byte(N mod 12 = 0)));
if (N > 0) and (N mod 12 = 0) then
TextOut(PenPos.X + 3, 9, IntToStr(N div 12));
N := N + 1;
X := X + a12th;
end;
end;
end;
{*********************************************}
procedure TVRuler.SetVRulerAlign(Value: TAlign);
begin
if Value in [alLeft, alRight, alNone] then
begin
fVRulerAlign := Value;
Align := Value;
end;
end;
constructor TVRuler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AlignVRuler := alNone;
Color := clYellow;
Height := 1008;
Width := 33;
end;
procedure TVRuler.Paint;
var a6th, N, Y: word;
begin
a6th := Screen.PixelsPerInch div 6;
N := 0; Y := 0;
with Canvas do
begin
Brush.Color := Color;
FillRect(ClientRect);
with ClientRect do
Rectangle(Left, Top, Right, Bottom);
while Y < Height do
begin
MoveTo(1, Y);
LineTo(6 * (2 + byte(N mod 3 = 0) +
byte(N mod 6 = 0)), Y);
if (N > 0) and (N mod 6 = 0) then
TextOut(12, PenPos.Y - 16, IntToStr(N div 6));
N := N + 1;
Y := Y + a6th;
end;
end;
end;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
Переадресация
Переадресация
Переадресация
Заголовок HTTP-ответа
Мы уже знаем, что CGI-программа отсылает серверу заголовок, не отображаемый браузером: WriteLn('Content-Type: text/html');
WriteLn('');
Вид заголовка для переадресации
Следует отметить, что в заголовке может быть приведено множество других директив, в частности, CGI-программа может переадресовать запрос на другую страницу... Для переадресации достаточно вывести заголовок в следующем виде:
WriteLn('Location: redirection.htm');
WriteLn('');
Кроме того, ваш сервер автоматически добавляет в этот заголовок еще и свои собственные сообщения.
Допустим, вы запрашиваете в браузере URL http://yahoo.com. В этом случае вы получите от сервера следующий ответ:
HTTP/1.0 302 Found
Location: http://www.yahoo.com
Получив такой заголовок, браузер перезапрашивает у сервера новый URL http://www.yahoo.com, и в ответ получает следующее:
HTTP/1.0 200 OK
Content-Length: 9332
Expires: Wed, 18 Mar 1998 08:00:03 GMT
Content-Type: text/html
<html><head><title>Yahoo!</title>
<base href="http://www.yahoo.com/"></head>
<body><center>
<form action="http://search.yahoo.com/bin/search">
<a href="/bin/top3">
<img width=460 height=59 border=0 usemap="#top3" ismap
src="http://us.yimg.com/i/main32.gif" alt="Yahoo!"></a>
<br>
<table cellpadding=3 cellspacing=0>
<tr>
<td align=center nowrap>
...
Таким образом происходит просто переадресация на другую страницу!
И последнее замечание: вам не нужно заботиться самим о выводе строк типа "HTTP/1.0...", и "Content-Length: ...", поскольку это делает автоматически сам сервер.
Перебор всех компонентов на форме
Перебор всех компонентов на форме
Например, надо найти все TCheckBox на форме и установить из все в положение checked:
var i: integer;
begin
for i := 0 to ComponentCount - 1 do
if Components[i] is TCheckBox then
(Components[i] as TCheckBox).Checked := true;
end;
Автор Vit
Взято с Vingrad.ru
Передача параметров
Передача параметров
Передача параметров
Методы GET и POST
Существует по крайней мере два метода передачи параметров CGI-программе. <form method=GET action="program.exe">
<form method=POST action="program.exe">
Чтобы определить, каким именно методом CGI-программе переданы параметры, достаточно в вашей программе проверить переменную среды REQUEST_METHOD.
Ниже привдена функция, с помощью которой можно получить значение переменной среды окружения:
function getvar(varname:string):string;
{$IFDEF LINUX}
begin
result:=getenv(PChar(varname));
end;
{$ELSE}
var
buffer:array[0..1024] of char;
size:integer;
begin
size:=GetEnvironmentVariable(PChar(varname),buffer,sizeof(buffer));
if size=0 then getvar:='' else getvar:=String(buffer);
end;
{$ENDIF}
Автор предпочитает работать не с массивами, а со строками, поэтому результат функции преобразовывается в строку...
Теперь посмотрим, как определить значение переменной среды под DOS в .BAT файле:
@ECHO OFF
ECHO content-type: text/html
ECHO.
ECHO ^<HTML^>^<HEAD^>^<TITLE^>^</TITLE^>^</HEAD^>^<BODY^>
ECHO REQUEST_METHOD=%REQUEST_METHOD%
ECHO ^</BODY^>^</HTML^>
Обратите внимание, что специальные символы, используемые в DOS (такие, как "<", ">", "&",...), необходимо предварять знаком "^".
Таким образом, если мы обратимся к функции в виде GetVar('REQUEST_METHOD'), то получим в виде строки метод, которым были переданы параметры: 'GET' или 'POST'.
Согласно Спецификации CGI, параметры могут быть прочитаны:
·Из переменной окружения QUERY_STRING для метода GET
·Из стандартного ввода (STDIN) с помощью процедуры ReadLn для метода POST
Метод POST используется в тех случаях, когда необходимо передать большое количество параметров или большой объем данных. При использовании же метода GET для хранения всех передаваемых параметров используется переменная среды окружения, а она, как вы понимаете, не резиновая, так что ее максимального размера в некоторых случаях может не хватить...
Метод GET и переменная QUERY_STRING
Переменная среды окружения QUERY_STRING содержит список имен и значений параметров, переданных из формы... Но сначала рассмотри код HTML: <form method="GET" action="program.exe">
<input type=text name="toto" value="titi">
<input type=submit value="GO">
</form>
Кликнув на "GO" (здесь кликать не надо, это просто пример!), вы запускаете на сервере программу "program.exe" передавая серверу запрос в виде:
http://www.ваш_сервер/cgi-bin/program.exe?toto=titi
Вы видите, что сразу за именем программы следует знак вопроса и передаваемый в программу параметр. В переменную QUERY_STRING как раз и будет помещено все, что находится после символа "?". Заметим, что точно так же можно задать параметры и в обычной ссылке:
<a href="http://www.ваш_сервер/cgi-bin/program.exe?toto=titi">...</a>
И последнее уточнение: если запрос содержит несколько параметров, то они отделяются друг от друга амперсандом &. Кроме того, некоторые символы в значениях параметров (например, "&") должны быть представлены в шестнадцатеричной форме %hh, где "hh" - шестнадцатеричный код символа в таблице ANSI. Например, символ амперсанда "&" должен быть представлен в виде "%26".
Представьте, что вам требуется на сайте yahoo.com найти результаты поиска по ключевым словам cgi и delphi, для чего в окне поиска вы вводите "cgi + delphi".
Тогда в результате вашего запроса будет сгенерирован следующий URL:
http://search.yahoo.com/bin/search?p=cgi+%2B+delphi
Тем самым, вы обратитесь к программе "search" и зададите значение параметра "p" равным "cgi + delphi", при этом символ "+" будет автоматически заменен браузером на "%2B", а пробелы - на "+".
Метод POST
Для получения данных, переданных по методу POST, необходимо читать данные из "устройства стандартного ввода" STDIN. Размер данных, переданных по этому методу, помещается сервером в переменную окружения CONTENT_LENGTH. Посмотрим, как это выглядит в Delphi:
// Получение переданных параметров
if getvar('REQUEST_METHOD')='POST' then begin
parmstring:=getvar('CONTENT_LENGTH');
if parmstring<>'' then begin
size:=strtoint(parmstring);
setlength(parmstring,size);
for i:=1 to size do read(parmstring[i]);
end;
end else
parmstring:=getvar('QUERY_STRING');
В заключение я предлагаю вашему вниманию маленькую CGI-программу, которая просто выводит то, что происходит на сервере:
program log;
{$apptype console}
// прикручивание к Linux попробуйте сделать сами :)
uses
windows, sysutils;
var
i:integer;
s:string;
p:pchar;
flog:textfile;
begin
assignfile(flog,'c:\temp\log.txt');
rewrite(flog);
WriteLn('Content-Type: text/html');
WriteLn('');
WriteLn('<html><head><title>Dump CGI</title></head><body>');
WriteLn('<h1>Dump CGI:</h1>');
WriteLn('<a href=#Parms>Параметры программы</a><br>');
WriteLn('<a href=#Query>Параметры CGI</a><br>');
WriteLn('<a href=#Env>Переменные окружения</a><br>');
WriteLn('<a href=#Info>Дополнительная информация о CGI</a><br>');
WriteLn('<hr>');
WriteLn('<a name=Parms><h2>ParamCount=',IntToStr(ParamCount),'</h2><ul>');
WriteLn(fLog,'ParamCount=',IntToStr(ParamCount));
for i:=0 to ParamCount do begin
WriteLn('<li>',ParamStr(i));
WriteLn(fLog,'-',ParamStr(i));
end;
// Стандартный Ввод
WriteLn(fLog,'Input :');
WriteLn('<h2>StdInput:</h2><ul>');
if Not Eof(Input) then begin
Read(Input,s);
WriteLn('<li>',s);
WriteLn(fLog,s);
end;
Writeln(fLog,'QUERY_STRING=',ParmString);
WriteLn('<a name=Env><h2>Переменные окружения:</h2><ul>');
p:=GetEnvironmentStrings;
while StrLen(p)<>0 do begin
WriteLn('<li>',p);
WriteLn(fLog,':',p);
p:=strend(p);
inc(p);
end;
WriteLn('</ul><hr>');
WriteLn('<a name=Info><a href="http://www.multimania.com/tothpaul">');
WriteLn('Дополнительная информация о CGI</a>');
WriteLn('</body></html>');
end.
Примечание:
Кроме стандартного вывода информация параллельно выводится еще и в лог-файл.
Передача параметров ADO запросу
Передача параметров ADO запросу
CONECT_STR= 'Provider=Microsoft.Jet.OLEDB.4.0;Password=" " ;User ID=Admin;' + {Data Source=D:\ExBd\ТЕРМО\Bd0.mdb;}
'Data Source=%s; Mode=Read|Write|Share Deny None;Extended Properties=" " ;' +
'Locale Identifier=1049;Persist Security Info=True;Jet OLEDB:System database=" " ;' +
'Jet OLEDB:Registry Path=" " ;Jet OLEDB:Database Password=" " ;Jet OLEDB:Engine Type=4;' +
'Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;' +
'Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password=" " ;' +
'Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;' +
'Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False';
function TdmR3.GetCountForPeriod(LastDate: TDateTime; IsPlan: boolean): Integer;
var qu: TADOQuery;
S: string;
begin
qu := TADOQuery.Create(nil);
try
S := FormatDateTime('dd.mm.yy', LastDate);
qu.ConnectionString := WideString(Format(CONECT_STR, [db_file]));
qu.SQL.Text := 'select count(*) from DecadaVal as d where d.LastDate=:LastDate and IsPlan=:IsPlan';
qu.Parameters[0].Value := LastDate;
qu.Parameters[1].Value := IsPlan;
qu.Open;
Result := qu.Fields[0].AsInteger;
finally
qu.Free;
end;
end;
Взято из
function TdmR3.GetCountForPeriod(LastDate: TDateTime; IsPlan: boolean): Integer;
var qu: TADOQuery;
S: string;
begin
qu := TADOQuery.Create(nil);
try
// S := FormatDateTime('dd.mm.yy', LastDate); нам не нужна эта строка
qu.ConnectionString := Format(CONECT_STR, [db_file]); //Delphi автоматически приводит тип String в WideString
qu.SQL.Text := 'select count(*) from DecadaVal as d where d.LastDate=:LastDate and IsPlan=:IsPlan';
//Дельфи вовсе не автоматом распознает параметры, мы должны заставить его правильно провести парсинг параметров, для чего и служит следующая строка:
qu.Parameters.ParseSQL(qu.SQL.Text, true); //если кверя создана в дизайне и текст SQL присвоен в дизайне то эта строка не понадобится
// я предпочитаю обращаться к параметрам по имени, это избавит от многочисленных и сложных в отладке ошибок
qu.Parameters.ParamByName('LastDate').Value := LastDate;
qu.Parameters.ParamByName('IsPlan').Value := IsPlan;
qu.Open;
Result := qu.Fields[0].AsInteger;
finally
qu.Free;
end;
end;
Передача переменной в отчет ReportSmith
Передача переменной в отчет ReportSmith
Следующий код показывает, как передать переменную в отчет.
В примере строковой переменной отчета 'City' присваивается значение ('Bombey').
Подразумевается, что есть готовый отчет с данной переменной.
Поместите компонент TReport на форму и установите требуемые свойства для вызова
печати отчета.
Напишите обработчик OnClick для кнопки Button1 на форме
(кнопка - для простоты) :
procedure TForm1.Button1Click(Sender: TObject);
var s: string;
begin
s:='CA';
Report1.InitialValues.Add('@state=<'+s+'>');
Report1.run;
end;
Источник:
Переход с Oracle на Interbase
Переход с Oracle на Interbase
Автор: Shawn Wu
Я пытаюсь преобразовать мою базу данных на Oracle в базу данных local Interbase server. Все таблицы Oracle ссылаются на имя схемы. Interbase поддерживает такого типа имена схем?
Нет, Interbase не использует понятие классификатора таблицы (владельца), как это делают другие сервера, например, Oracle или Sybase. Наилучшее решение в этом случае - использование директив компиляции, позволяющее контролировать соглашение о стиле имен Oracle или Interbase, используемое в генерируемом .exe-файле.
Также, Delphi читает все атрибуты Oracle типа Number и конвертирует их в FloatField. Interbase при этом использует тип SmallIntField. Так, для преобразования необходимо пройтись по всем таблицам, удалить поля и затем снова их добавить. Можно это сделать как-то по-человечески?
Если я правильно понял то, что вы хотели сказать, то этот вопрос относится к специфике Interbase. Например, Interbase использует короткое поле (short field) с масштабированием вместо реального типа, если заданная при создании таблицы точность не превышает 10. [например, CREATE TABLE xxx (FLOATFIELD NUMERIC (5, 2)) обычно означает реальный тип с точностью 5 цифр с 2-мя цифрами после запятой. Но Interbase знает, что сможет поместить 5 цифр в короткое поле, поэтому она создаст короткое поле и запись и смасштабирует его с коэффициентом 2.] Проблема в следующем: BDE "спрашивает" Interbase о полях таблицы и их типах, Interbase честно рапортует, что поля имеют тип short, т.е. они "короткие". Но BDE ничего не знает о масштабировании.
Чтобы обойти этот неприятный момент, необходимо создать поле с точностью более 10, заставляя Interbase делать поля реального, а не короткого типа.
Могу ли я менять один тип SQL на другой, или это - несбыточная мечта?
Проблема в том, что каждый производитель создал свой диалект и реализацию SQL, который не обязательно был совместимым с SQL других производителей, особенно в рамках расширений "стандартного" SQL.
Существует ли возможность инкапсуляции общего кода для работы с базой данных от специфических реализаций конкретных версий баз, что позволило бы клиенту легко переходить от одного типа таблиц к другому?
Как я уже говорил выше: директивы компилятора.
Взято из
Перехват API функций, на примере MessageBoxA
Перехват API функций, на примере MessageBoxA
DLL:
libraryMouse_mes;
uses
sysutils,
windows,
messages;
type
TImageImportDescriptor=packed record
OriginalFirstThunk : DWORD;
TimeDateStamp : DWORD;
ForwarderChain : DWORD;
Name : DWORD;
FirstThunk : DWORD;
end;
PImageImportDescriptor=^TImageImportDescriptor;
var filename:array[0..max_path-1] of char;
hook:HHook=0;
PEHeader:PImageNtHeaders;
ImageBase:cardinal;
function MyHookProcedure(hWnd: HWND; lpText, lpCaption: PWideChar; uType: UINT): Integer;
stdcall;
begin
result:=MessageBoxA(0, 'Notepad', 'my hook', 0);
//Но уже через нашу табл. импорта
end;
procedure ProcessImports(PImports:PImageImportDescriptor);
Var
PImport:PImageImportDescriptor;
PRVA_Import:LPDWORD;
ProcAddress:pointer;
Temp_Cardinal:cardinal;
begin{1}
ProcAddress:=GetProcAddress(GetModuleHandle('USER32.DLL'), 'MessageBoxA');
PImport:=PImports;
while PImport.Name<>0 do
begin{2}
PRVA_Import:=LPDWORD(pImport.FirstThunk+ImageBase);
while PRVA_Import^<>0 do
begin{3}
if PPointer(PRVA_Import)^=ProcAddress
then
begin{4}
VirtualProtect(PPointer(PRVA_Import),4,PAGE_READWRITE,Temp_Cardinal);
PPointer(PRVA_Import)^:=@MyHookProcedure; //пишем свою...
VirtualProtect(PPointer(PRVA_Import),4,Temp_Cardinal,Temp_Cardinal);
end;{1}
Inc(PRVA_Import);
end;{2}
Inc(PImport);
end;{3}
end;{4}
procedure DllEntryPoint(reson:longint);stdcall;
begin
case reson of
DLL_PROCESS_ATTACH:
begin
DisableThreadLibraryCalls(hInstance);
ZeroMemory(@FileName, SizeOf(FileName));
GetModuleFileName(GetModuleHandle(nil), @FileName, SizeOf(FileName));
if Pos('NOTEPAD.EXE',AnsiUpper(@FileName))<>0 then //сейчас я хочу попробовать все это дело надо нотепадом
begin
ImageBase:=GetModuleHandle(nil);
PEHeader:=pointer(int64(ImageBase)+PImageDosHeader(ImageBase)._lfanew);//pe header
ProcessImports(pointer(PEHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress+ImageBase));
end;
end;
end;
end;
function nexthook(code:integer;wParam,lParam:longint):longint;stdcall;
begin
result:=callnexthookex(hook,code,wParam,lParam);
end;
procedure sethook(flag:bool);export; stdcall;
begin
if flag then
hook:=setwindowshookex(wh_getmessage,@nexthook,hInstance,0)
else
begin
unhookwindowshookex(hook);
hook:=0;
end;
end;
exports sethook;
begin
DLLProc:=@DllEntryPoint;
DllEntryPoint(DLL_PROCESS_ATTACH)
end.
EXE:
program Project2;
uses windows;
var
sethook:procedure(flag:bool)stdcall;
hDll:hModule;
begin
hDll:=LoadLibrary('Mouse_mes.dll');
@sethook:=GetProcAddress(hDll, 'sethook');
sethook(true);
messagebox(0,'Не закрывай, пока идет работа','',0);
sethook(false);
FreeLibrary(hDll);
end.
Автор:
SongВзято из
Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)
Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)
Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)
Сообщение WM_SYSCOMMAND приходит перед выполнением соответствующей команды,
что дает возможность переопределить код.
Описание :
WM_SYSCOMMAND
uCmdType = wParam; // type of system command requested
xPos = LOWORD(lParam); // horizontal postion, in screen coordinates
yPos = HIWORD(lParam); // vertical postion, in screen coordinates
Например, перехват события минимизации окна приложения:
Type TMain = class(TForm)
....
protected
Procedure WMGetSysCommand(var Message : TMessage); message WM_SYSCOMMAND;
end;
.....
//----------------------------------------------------------------
// Обработка сообщения WM_SYSCOMMAND (перехват минимизации окна)
//----------------------------------------------------------------
Procedure TMain.WMGetSysCommand(var Message : TMessage) ;
Begin
IF (Message..wParam = SC_MINIMIZE)
Then Main.Visible:=False
Else Inherited;
End;
Взято с сайта
